'From Pharo2.0a of ''18 April 2012'' [Latest update: #20582] on 4 March 2013 at 2:54:09 pm'! BracketSliderMorph subclass: #AColorSelectorMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !AColorSelectorMorph commentStamp: 'gvc 5/18/2007 13:52' prior: 0! ColorComponentSelector showing an alpha gradient over a hatched background.! !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: '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: 'initialization' stamp: 'gvc 9/26/2006 11:54'! initialize "Initialize the receiver." super initialize. self value: 1.0; color: Color black! ! !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])! ! !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: 'private' stamp: 'gvc 9/22/2006 09:17'! hatchForm "Answer a form showing a grid hatch pattern." ^ColorPresenterMorph hatchForm! ! AbstractGroupAnnouncement subclass: #AGroupHasBeenAdded instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'GroupManager-Announcements'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AGroupHasBeenAdded class instanceVariableNames: ''! !AGroupHasBeenAdded class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 4/14/2011 16:32'! group: aGroup into: anHolder ^ self group: aGroup from: anHolder! ! AbstractGroupAnnouncement subclass: #AGroupHasBeenCreated instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'GroupManager-Announcements'! AbstractGroupAnnouncement subclass: #AGroupHasBeenRegistered instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'GroupManager-Announcements'! !AGroupHasBeenRegistered methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/14/2011 13:39'! group ^ group! ! !AGroupHasBeenRegistered methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/14/2011 13:39'! group: anObject group := anObject! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AGroupHasBeenRegistered class instanceVariableNames: ''! !AGroupHasBeenRegistered class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 4/14/2011 13:40'! with: aGroup ^ self new group: aGroup! ! AbstractGroupAnnouncement subclass: #AGroupHasBeenRemoved instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'GroupManager-Announcements'! AbstractGroupAnnouncement subclass: #AGroupHasBeenRenamed instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'GroupManager-Announcements'! AbstractGroupAnnouncement subclass: #AGroupHasBeenUnregistered instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'GroupManager-Announcements'! !AGroupHasBeenUnregistered methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/14/2011 13:39'! group ^ group! ! !AGroupHasBeenUnregistered methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/14/2011 13:39'! group: anObject group := anObject! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AGroupHasBeenUnregistered class instanceVariableNames: ''! !AGroupHasBeenUnregistered class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 4/14/2011 13:40'! with: aGroup ^ self new group: aGroup! ! AJInstruction subclass: #AJAlignmentInstruction instanceVariableNames: 'alignTo' classVariableNames: '' poolDictionaries: 'AJConstants' category: 'AsmJit-Instructions'! !AJAlignmentInstruction commentStamp: '' prior: 0! 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: 'accessing'! align ^ alignTo! ! !AJAlignmentInstruction methodsFor: 'accessing'! align: bytesSize "align the data to the given byte count" alignTo := bytesSize! ! !AJAlignmentInstruction methodsFor: 'accessing' stamp: 'CamilloBruni 4/12/2012 13:56'! name ^ String streamContents: [ :s| self printSelfOn: s]! ! !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: 'alignment' stamp: 'CamilloBruni 4/12/2012 13:50'! alignByte self align: 1! ! !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: '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: '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: 'initialize-release'! initialize super initialize. self alignByte.! ! !AJAlignmentInstruction methodsFor: 'visitor' stamp: 'CamilloBruni 4/12/2012 13:38'! accept: anObject self shouldBeImplemented ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AJAlignmentInstruction class instanceVariableNames: ''! !AJAlignmentInstruction class methodsFor: 'instance creation' stamp: 'CamilloBruni 4/12/2012 13:50'! align: byteSize ^ self new align: byteSize! ! !AJAlignmentInstruction class methodsFor: 'instance creation'! alignDouble ^ self new alignDouble! ! !AJAlignmentInstruction class methodsFor: 'instance creation'! alignQuad ^ self new alignQuad! ! !AJAlignmentInstruction class methodsFor: 'instance creation'! alignWord ^ self new alignWord! ! Object subclass: #AJAssembler instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-Core'! AJOperand subclass: #AJBaseReg instanceVariableNames: 'size code name' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-Operands'! !AJBaseReg methodsFor: 'accessing'! code "Answer the value of code" ^ code! ! !AJBaseReg methodsFor: 'accessing'! 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'! index ^ code bitAnd: RegCodeMask! ! !AJBaseReg methodsFor: 'accessing' stamp: 'CamilloBruni 7/17/2012 11:24'! influencingRegisters ^ #()! ! !AJBaseReg methodsFor: 'accessing'! name ^ name! ! !AJBaseReg methodsFor: 'accessing'! size ^ size! ! !AJBaseReg methodsFor: 'accessing' stamp: 'CamilloBruni 4/17/2012 17:59'! type ^ code bitAnd: RegTypeMask! ! !AJBaseReg methodsFor: 'comparing'! = otherReg ^ (self class == otherReg class) and: [ code = otherReg code ]! ! !AJBaseReg methodsFor: 'comparing'! hash ^ code hash! ! !AJBaseReg methodsFor: 'initialize-release'! initializeWithCode: aRegisterCode name: aSymbol super initialize. code := aRegisterCode. name := aSymbol! ! !AJBaseReg methodsFor: 'printing' stamp: 'CamilloBruni 7/17/2012 11:07'! descriptionOn: aStream self subclassResponsibility! ! !AJBaseReg methodsFor: 'testing'! isGeneralPurpose self subclassResponsibility ! ! !AJBaseReg methodsFor: 'testing'! isUpperBank "Used for emitting the REX Prefix Byte on 64bit machines" ^ self index > 7! ! !AJBaseReg methodsFor: 'testing' stamp: 'CamilloBruni 7/17/2012 10:58'! isX86 "Return whether this register is available in the standard x86 instruction set" ^ self isUpperBank not and: [ self is64 not ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AJBaseReg class instanceVariableNames: ''! !AJBaseReg class methodsFor: 'instance creation'! code: aRegisterCode name: aSymbol ^ self basicNew initializeWithCode: aRegisterCode name: aSymbol! ! AJStackInstruction subclass: #AJCallArgument instanceVariableNames: 'size stackOffset first' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-StackManagement'! !AJCallArgument methodsFor: 'accessing'! instructionName ^ #push! ! !AJCallArgument methodsFor: 'accessing'! name ^ 'argument push:'! ! !AJCallArgument methodsFor: 'accessing'! size ^ size ! ! !AJCallArgument methodsFor: 'accessing'! size: aSmallInteger size := aSmallInteger! ! !AJCallArgument methodsFor: 'accessing'! stackOffset: anOffset stackOffset := anOffset ! ! !AJCallArgument methodsFor: 'function calls'! prepareCallAlignments callInfo noticeArgument: self ! ! !AJCallArgument methodsFor: 'visitor'! accept: anObject ^ anObject visitCallArgument: self ! ! AJStackInstruction subclass: #AJCallCleanup instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-StackManagement'! !AJCallCleanup methodsFor: 'accessing'! callInfo ^ callInfo! ! !AJCallCleanup methodsFor: 'accessing'! callInfo: anObject callInfo := anObject! ! !AJCallCleanup methodsFor: 'accessing'! name ^ 'call cleanup'! ! !AJCallCleanup methodsFor: 'function calls'! prepareCallAlignments callInfo callCleanup: self ! ! !AJCallCleanup methodsFor: 'visitor'! accept: anObject ^ anObject visitCallCleanup: self! ! Object subclass: #AJCallInfo instanceVariableNames: 'asm stackAlignment stackSize arguments callCleanup prepareForCall noCleanup alignInsertionPoint' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-StackManagement'! !AJCallInfo methodsFor: 'accessing'! alignment: aStackAlignment stackAlignment := aStackAlignment ! ! !AJCallInfo methodsFor: 'accessing'! alignmentInsertionPoint: instruction alignInsertionPoint := instruction! ! !AJCallInfo methodsFor: 'accessing'! asm: assembler asm := assembler! ! !AJCallInfo methodsFor: 'accessing'! callCleanup: aCallCleanup self assert: callCleanup isNil. callCleanup := aCallCleanup ! ! !AJCallInfo methodsFor: 'accessing'! defaultArgumentSize self subclassResponsibility ! ! !AJCallInfo methodsFor: 'accessing'! disableCleanup noCleanup := true! ! !AJCallInfo methodsFor: 'accessing'! name ^ 'call info' ! ! !AJCallInfo methodsFor: 'accessing'! noCleanup ^ noCleanup ! ! !AJCallInfo methodsFor: 'accessing'! noticeArgument: aCallArgument arguments add: aCallArgument. stackSize := stackSize + aCallArgument size.! ! !AJCallInfo methodsFor: 'accessing'! stackSize ^ stackSize! ! !AJCallInfo methodsFor: 'accessing'! stackSize: anObject stackSize := anObject! ! !AJCallInfo methodsFor: 'initialize-release'! initialize arguments := OrderedCollection new. stackSize := 0. stackAlignment := 1. noCleanup := false.! ! !AJCallInfo methodsFor: 'pushing args'! push: anArgument asm pushArgument: anArgument forCall: self. ! ! !AJCallInfo methodsFor: 'testing'! needsAlignment ^ stackAlignment > 1! ! AJCallInfo subclass: #AJCdeclCallInfo instanceVariableNames: 'savedSP' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-StackManagement'! !AJCdeclCallInfo methodsFor: 'accessing'! 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: '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! ! !AJCdeclCallInfo methodsFor: 'emitting code' stamp: 'CamilloBruni 4/4/2012 16:57'! emitAlignmentIfNeeded | alignment | self needsAlignment ifTrue: [ ^ self emitAlignment ]. self emitCleanup! ! !AJCdeclCallInfo methodsFor: 'emitting code'! emitCleanup noCleanup ifTrue: [ ^ self ]. asm insert: ( asm instructionsFor: [ self needsAlignment ifTrue: [ self alignedCleanup ] ifFalse: [ self normalCleanup ] ] ) after: callCleanup! ! !AJCdeclCallInfo methodsFor: 'emitting code'! normalCleanup stackSize > 0 ifTrue: [ asm add: asm ESP with: stackSize ]! ! SharedPool subclass: #AJConstants instanceVariableNames: '' classVariableNames: 'CcA CcABOVE CcABOVEEQUAL CcAE CcB CcBE CcBELOW CcBELOWEQUAL CcC CcE CcEQUAL CcFPNOTUNORDERED CcFPUNORDERED CcG CcGE CcGREATER CcGREATEREQUAL CcL CcLE CcLESS CcLESSEQUAL CcNA CcNAE CcNB CcNBE CcNC CcNE CcNEGATIVE CcNG CcNGE CcNL CcNLE CcNO CcNOCONDITION CcNOOVERFLOW CcNOTEQUAL CcNOTSIGN CcNOTZERO CcNP CcNS CcNZ CcO CcOVERFLOW CcP CcPARITYEVEN CcPARITYODD CcPE CcPO CcPOSITIVE CcS CcSIGN CcZ CcZERO InstCMOVA InstJA O64Only OFM1 OFM10 OFM2 OFM24 OFM248 OFM4 OFM48 OFM4810 OFM8 OG16 OG163264 OG32 OG3264 OG64 OG8 OG8163264 OIMM OMEM OMM OMMMEM OMMXMM OMMXMMMEM ONOREX OXMM OXMMMEM OpImm OpLabel OpMem OpNONE OpREG PrefetchNTA PrefetchT0 PrefetchT1 PrefetchT2 RIDEAX RIDEBP RIDEBX RIDECX RIDEDI RIDEDX RIDESI RIDESP RegCodeMask RegGPB RegGPD RegGPQ RegGPW RegHighByteMask RegMM RegTypeMask RegX87 RegXMM SegmentCS SegmentDS SegmentES SegmentFS SegmentGS SegmentNONE SegmentSS SizeByte SizeDQWord SizeDWord SizeQWord SizeTWord SizeWord' poolDictionaries: '' category: 'AsmJit-Core'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AJConstants class instanceVariableNames: ''! !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.! ! !AJConstants class methodsFor: 'initialization' stamp: 'CamilloBruni 3/20/2012 18:36'! 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. 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'! 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'! 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. ! ! AJInstruction subclass: #AJData instanceVariableNames: 'data alignment' classVariableNames: '' poolDictionaries: 'AJConstants' category: 'AsmJit-Instructions'! !AJData commentStamp: '' prior: 0! 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 ^ machineCode! ! !AJData methodsFor: 'accessing' stamp: 'CamilloBruni 4/12/2012 14:22'! data: aByteArray "the will be put in the executable." machineCode := aByteArray! ! !AJData methodsFor: 'accessing'! name name ifNotNil: [ ^ name ]. "standard data sections" self is8 ifTrue: [ ^ 'db' ]. self is16 ifTrue: [ ^ 'dw' ]. self is32 ifTrue: [ ^ 'dd' ].! ! !AJData methodsFor: 'accessing'! size ^ self data size! ! !AJData methodsFor: 'emitting code' stamp: 'CamilloBruni 4/12/2012 14:22'! emitCode: asm machineCode ifNil: [ machineCode := #[] ]! ! !AJData methodsFor: 'testing'! is16 ^ self size = 2! ! !AJData methodsFor: 'testing'! is32 ^ self size = 4! ! !AJData methodsFor: 'testing'! is64 ^ self size = 8! ! !AJData methodsFor: 'testing'! is8 ^ self size = 1! ! !AJData methodsFor: 'visitor'! accept: anObject anObject instructionData: self! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AJData class instanceVariableNames: ''! !AJData class methodsFor: 'instance creation'! byte: aByteValue ^ self data: (ByteArray with: aByteValue)! ! !AJData class methodsFor: 'instance creation'! data: aDataByteArray ^ self new data: aDataByteArray; yourself! ! !AJData class methodsFor: 'instance creation'! label: aLabel data: aDataByteArray ^ self new label: aLabel; data: aDataByteArray; yourself! ! Object subclass: #AJGeneratedCode instanceVariableNames: 'bytes labels' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-Core'! !AJGeneratedCode methodsFor: 'accessing'! bytes ^ bytes! ! !AJGeneratedCode methodsFor: 'accessing'! bytes: aBytes bytes := aBytes ! ! !AJGeneratedCode methodsFor: 'accessing'! labels: aLabels "turn labels into a simple name->offset pairs" aLabels keysAndValuesDo: [:name :lbl | labels at: name put: lbl paddedOffset ]. ! ! !AJGeneratedCode methodsFor: 'accessing'! offsetAt: aLabelName ^ labels at: aLabelName! ! !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: 'initialize-release'! initialize labels := Dictionary new. ! ! !AJGeneratedCode methodsFor: 'output'! 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: 'output'! saveToFile self saveToFile: 'asm.bin'! ! !AJGeneratedCode methodsFor: 'output'! saveToFile: fileName (FileStream forceNewFileNamed: fileName) nextPutAll: bytes; close ! ! !AJGeneratedCode methodsFor: 'printing'! printOn: aStream bytes notNil ifTrue: [ aStream nextPutAll: self dumpWithLabels ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AJGeneratedCode class instanceVariableNames: ''! !AJGeneratedCode class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/25/2012 12:44'! fromInstructions: instructions ^ self new fromInstructions: instructions! ! AJOperand subclass: #AJImmediate instanceVariableNames: 'label size isUnsigned relocMode value' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-Operands'! !AJImmediate commentStamp: '' prior: 0! I am an immediate (constant integer) operand used by the assembler. Example: asm := AJx64Assembler new. "create an immediate from an integer" 1 asImm. "implicitely use an immediate in an assembly instrution" asm add: 1 to: asm RAX. ! !AJImmediate methodsFor: '*NativeBoost-core' stamp: 'IgorStasenko 11/18/2012 16:49'! asNBExternalType: gen ^ NBFFIConst value: self! ! !AJImmediate methodsFor: 'accessing'! extractLabels: aBlock label ifNotNil: [ label extractLabels: aBlock ] ! ! !AJImmediate methodsFor: 'accessing'! ivalue: aValue "signed integer value" value := aValue. isUnsigned := false.! ! !AJImmediate methodsFor: 'accessing'! label: aLabelName label := aLabelName! ! !AJImmediate methodsFor: 'accessing'! relocMode ^ relocMode ifNil: [#RelocNone ]! ! !AJImmediate methodsFor: 'accessing'! size ^ size! ! !AJImmediate methodsFor: 'accessing'! size: aSize size := aSize! ! !AJImmediate methodsFor: 'accessing'! 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: 'accessing'! uvalue: aValue "unsigned value" self assert: (aValue >=0). value := aValue. isUnsigned := true.! ! !AJImmediate methodsFor: 'accessing'! value ^ value! ! !AJImmediate methodsFor: 'converting'! 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: '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: '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: 'converting'! 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: '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: '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: 'initialize-release'! initialize value := 0. 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: '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: 'testing'! isImm ^ true! ! !AJImmediate methodsFor: 'testing' stamp: 'CamilloBruni 4/4/2012 16:54'! isInt32 ^ value >= -2147483648 and: [ value <= 2147483647 ] ! ! !AJImmediate methodsFor: 'testing'! isInt8 ^ size ifNil: [ self fitsInSize: 1 ] ifNotNil: [ size = 1 ]! ! !AJImmediate methodsFor: 'testing'! isSigned ^ isUnsigned not! ! !AJImmediate methodsFor: 'testing'! isUnsigned ^ isUnsigned! ! !AJImmediate methodsFor: 'testing'! isZero ^ value = 0! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AJImmediate class instanceVariableNames: ''! !AJImmediate class methodsFor: 'as yet unclassified'! ivalue: aValue ^ self new ivalue: aValue! ! Object subclass: #AJInstruction instanceVariableNames: 'name operands machineCode position next annotation level' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-Instructions'! !AJInstruction methodsFor: 'accessing'! annotation ^ annotation! ! !AJInstruction methodsFor: 'accessing'! annotation: anObject annotation := anObject! ! !AJInstruction methodsFor: 'accessing'! extractLabels: aBlock operands ifNotNil: [ operands do: [:each | each extractLabels: aBlock ]]! ! !AJInstruction methodsFor: 'accessing'! increaseLevel: num level := level + num! ! !AJInstruction methodsFor: 'accessing'! insert: anInstructions | n | self halt. n := next. next := anInstructions. anInstructions do: [:each | each increaseLevel: level ]. anInstructions last next: n! ! !AJInstruction methodsFor: 'accessing'! instructionName ^ name! ! !AJInstruction methodsFor: 'accessing'! level ^ level! ! !AJInstruction methodsFor: 'accessing'! level: aLevel level := aLevel ! ! !AJInstruction methodsFor: 'accessing'! machineCodeSize ^ machineCode ifNil: [ 0 ] ifNotNil: [ machineCode size ]! ! !AJInstruction methodsFor: 'accessing'! name ^ name ifNil: ['undefined']! ! !AJInstruction methodsFor: 'accessing'! name: anObject name := anObject! ! !AJInstruction methodsFor: 'accessing'! next ^ next! ! !AJInstruction methodsFor: 'accessing'! next: anObject next := anObject! ! !AJInstruction methodsFor: 'accessing'! operands ^ operands! ! !AJInstruction methodsFor: 'accessing'! operands: anObject operands := anObject! ! !AJInstruction methodsFor: 'accessing'! position ^ position! ! !AJInstruction methodsFor: 'accessing'! position: anObject position := anObject! ! !AJInstruction methodsFor: 'emitting code'! emitCode: asm machineCode := #[] ! ! !AJInstruction methodsFor: 'emitting code'! emitCodeAtOffset: offset assembler: asm position := offset. self emitCode: asm. next ifNotNil: [ next emitCodeAtOffset: offset + self machineCodeSize assembler: asm ].! ! !AJInstruction methodsFor: 'function calls'! prepareCallAlignments "do nothing"! ! !AJInstruction methodsFor: 'helpers'! find: aByteString self shouldBeImplemented.! ! !AJInstruction methodsFor: 'initialize-release'! initialize level := 0! ! !AJInstruction methodsFor: 'iterating'! do: aBlock "evaluate all instructions for the list" | nn | nn := self. [ nn notNil ] whileTrue: [ aBlock value: nn. nn := nn next. ].! ! !AJInstruction methodsFor: 'iterating'! last "answer the last instruction in the list" | nn l | nn := self. [ (l := nn next) notNil ] whileTrue: [ nn := l ]. ^ nn! ! !AJInstruction methodsFor: 'manipulating'! 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: 'manipulating'! 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: 'printing' stamp: 'CamilloBruni 7/16/2012 15:33'! printAnnotationOn: aStream annotation ifNil: [^ self]. aStream nextPut: $"; nextPutAll: annotation asString; nextPut: $"; cr. self printIndentOn: aStream! ! !AJInstruction methodsFor: 'printing' stamp: 'CamilloBruni 7/23/2012 16:44'! printIndentOn: aStream level ifNil: [ ^ self ]. level timesRepeat: [ aStream nextPutAll: '| ']! ! !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: '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/16/2012 15:24'! printOn: aStream "[ ^self ] value." self printListOn: aStream asLineStream! ! !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: 'printing' stamp: 'CamilloBruni 7/16/2012 15:26'! printSelfOn: aStream self printAnnotationOn: aStream. aStream nextPutAll: (self name padRightTo: 4). self printOperandsOn: aStream. self printMachineCodeOn: aStream! ! !AJInstruction methodsFor: 'printing'! printStringLimitedTo: aNumber ^ String streamContents: [:s | self printOn: s] ! ! !AJInstruction methodsFor: 'printing'! storeOn: aStream "store machine code to binary stream" machineCode ifNotNil: [ aStream nextPutAll: machineCode ]! ! !AJInstruction methodsFor: 'testing'! hasLabel self shouldBeImplemented.! ! !AJInstruction methodsFor: 'testing'! isLabelUsed: anAJJumpLabel ^ false! ! !AJInstruction methodsFor: 'visitor'! accept: anObject self subclassResponsibility! ! !AJInstruction methodsFor: 'visitor'! processTempsWith: anObject "do nothing"! ! !AJInstruction methodsFor: 'visitor'! setPrologue: anInstrucitons "do nothing"! ! AJInstruction subclass: #AJInstructionDecoration instanceVariableNames: 'end' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-Instructions'! !AJInstructionDecoration methodsFor: 'accessing'! end end := true! ! !AJInstructionDecoration methodsFor: 'accessing'! start end := false! ! !AJInstructionDecoration methodsFor: 'printing' stamp: 'CamilloBruni 7/23/2012 16:43'! printIndentOn: aStream end ifFalse: [ super printIndentOn: aStream. aStream cr ]. ^ super printIndentOn: aStream! ! !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: 'visitor'! accept: anObject anObject instructionDecoration: self! ! AJInstruction subclass: #AJJumpInstruction instanceVariableNames: 'label description' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-Instructions'! !AJJumpInstruction methodsFor: 'accessing'! codeSize ^ machineCode size! ! !AJJumpInstruction methodsFor: 'accessing' stamp: 'CamilloBruni 4/17/2012 17:54'! description ^ description! ! !AJJumpInstruction methodsFor: 'accessing' stamp: 'CamilloBruni 4/17/2012 17:55'! description: anInstructionDescription description := anInstructionDescription! ! !AJJumpInstruction methodsFor: 'accessing'! label ^ label! ! !AJJumpInstruction methodsFor: 'accessing'! label: anObject label := anObject! ! !AJJumpInstruction methodsFor: 'printing'! 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: 'testing'! isLabelUsed: anAJJumpLabel ^ label = anAJJumpLabel ! ! !AJJumpInstruction methodsFor: 'visitor'! accept: anObject ^ anObject jumpInstruction: self! ! AJInstruction subclass: #AJJumpLabel instanceVariableNames: 'isSet' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-Instructions'! !AJJumpLabel methodsFor: 'accessing'! extractLabels: aBlock aBlock value: name value: position! ! !AJJumpLabel methodsFor: 'accessing'! isSet ^ isSet == true! ! !AJJumpLabel methodsFor: 'accessing'! isSet: anObject isSet := anObject! ! !AJJumpLabel methodsFor: 'emitting code'! emitCode: asm ! ! !AJJumpLabel methodsFor: 'printing'! printAsOperandOn: aStream aStream nextPutAll: '@@'; nextPutAll: name asString ! ! !AJJumpLabel methodsFor: 'printing'! printOn: aStream aStream nextPutAll: '@@'; nextPutAll: name asString ! ! !AJJumpLabel methodsFor: 'printing' stamp: 'CamilloBruni 7/17/2012 14:48'! printSelfOn: aStream aStream nextPutAll: '@@'; nextPutAll: name asString ! ! !AJJumpLabel methodsFor: 'testing' stamp: 'CamilloBruni 8/22/2012 16:43'! isLabel ^ true! ! !AJJumpLabel methodsFor: 'visitor'! accept: anObject anObject jumpLabel: self! ! Object subclass: #AJLineStream instanceVariableNames: 'lineStart writeStream' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-Extension'! !AJLineStream methodsFor: 'error handling' stamp: 'CamilloBruni 7/16/2012 14:59'! doesNotUnderstand: aMessage writeStream perform: aMessage selector withArguments: aMessage arguments! ! !AJLineStream methodsFor: 'writing'! cr self updateLineStart. writeStream cr! ! !AJLineStream methodsFor: 'writing'! crlf self updateLineStart. writeStream crlf! ! !AJLineStream methodsFor: 'writing'! lf self updateLineStart. writeStream lf! ! !AJLineStream methodsFor: 'writing' stamp: 'CamilloBruni 7/16/2012 15:00'! on: aStream ^ self new writeStream: aStream; yourself! ! !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'! updateLineStart lineStart := writeStream position! ! !AJLineStream methodsFor: 'writing' stamp: 'CamilloBruni 7/16/2012 15:22'! writeStream: aWriteStream writeStream := aWriteStream. self updateLineStart! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AJLineStream class instanceVariableNames: ''! !AJLineStream class methodsFor: 'instance creation' stamp: 'CamilloBruni 7/16/2012 15:33'! on: aWriteStream ^ self new writeStream: aWriteStream; yourself! ! AJBaseReg subclass: #AJMMRegister instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-x86-Operands'! !AJMMRegister methodsFor: 'accessing'! code: aCode code := aCode. size := 8.! ! !AJMMRegister methodsFor: 'printing' stamp: 'CamilloBruni 7/17/2012 11:13'! descriptionOn: s s nextPutAll: 'An MMX register'.! ! !AJMMRegister methodsFor: 'testing'! isGeneralPurpose ^ false! ! !AJMMRegister methodsFor: 'testing'! isRegTypeMM ^ true! ! AJOperand subclass: #AJMem instanceVariableNames: 'size base index shift segmentPrefix hasLabel target displacement' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-Operands'! !AJMem commentStamp: '' prior: 0! I am memory operand used in asembly instructions. Example: asm := AJx86Assembler new. "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: 'accessing'! * aScale self scale: aScale! ! !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: 'accessing'! base "Answer the value of base" ^ base! ! !AJMem methodsFor: 'accessing'! base: anObject "Set the value of base" base := anObject! ! !AJMem methodsFor: 'accessing'! displacement "Answer the value of displacement" ^ displacement! ! !AJMem methodsFor: 'accessing'! displacement: anImm "Set the value of displacement" self assert: anImm isImm. displacement := anImm! ! !AJMem methodsFor: 'accessing'! hasLabel "Answer the value of hasLabel" ^ false! ! !AJMem methodsFor: 'accessing'! hasLabel: anObject "Set the value of hasLabel" hasLabel := anObject! ! !AJMem methodsFor: 'accessing'! index "Answer the value of index" ^ index! ! !AJMem methodsFor: 'accessing'! index: anIndex "Set the value of index, must be a general purpose register" self assert: (anIndex isGeneralPurpose). index := anIndex! ! !AJMem methodsFor: 'accessing'! scale: aScale "a valid scale values is 0 , 2 , 4 and 8" aScale = 0 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: 'accessing'! segmentPrefix "Answer the value of segmentPrefix" ^ segmentPrefix! ! !AJMem methodsFor: 'accessing'! segmentPrefix: anObject "Set the value of segmentPrefix" segmentPrefix := anObject! ! !AJMem methodsFor: 'accessing'! shift "Answer the value of shift" ^ shift! ! !AJMem methodsFor: 'accessing'! shift: value "Set the value of shift" self assert: (value >=0 and: [ value < 4 ]). shift := value! ! !AJMem methodsFor: 'accessing'! size ^ size ifNil: [ base size ]! ! !AJMem methodsFor: 'accessing'! size: anObject "Set the value of size" size := anObject! ! !AJMem methodsFor: 'emitting'! 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: 'emitting'! 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: 'emitting' stamp: 'CamilloBruni 4/4/2012 16:52'! emitModRM: emitter code: rCode immSize: immSize "Receiver is memory location" "[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: 'emitting'! 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: 'initialize-release'! initialize displacement := AJImmediate new. shift := 0.! ! !AJMem methodsFor: 'printing' stamp: 'CamilloBruni 10/5/2012 14:38'! printOn: aStream self printAnnotationOn: aStream. aStream nextPutAll: 'mem['. base ifNotNil: [ aStream nextPutAll: base printAsMemBase. (index isNil and: [ displacement isNil ]) ifFalse: [ aStream nextPutAll: ' + ' ]]. index ifNotNil: [ aStream nextPutAll: index registerName . displacement ifNotNil: [ aStream nextPutAll: ' + ']]. displacement ifNotNil: [ aStream print: displacement ]. aStream nextPut: $].! ! !AJMem methodsFor: 'testing'! hasBase ^ base notNil! ! !AJMem methodsFor: 'testing'! hasIndex ^ index notNil! ! !AJMem methodsFor: 'testing'! hasSegmentPrefix ^ segmentPrefix notNil! ! !AJMem methodsFor: 'testing'! isMem ^ true! ! !AJMem methodsFor: 'testing'! isRip ^ self base isRip! ! !AJMem methodsFor: 'testing'! isUpperBank "see `AJBaseReg >> #isUpperBank` " ^ self base isUpperBank! ! Object subclass: #AJOperand instanceVariableNames: 'data compilerData operandId x64padding annotation' classVariableNames: '' poolDictionaries: 'AJConstants' category: 'AsmJit-Operands'! !AJOperand methodsFor: 'accessing'! annotation ^ annotation! ! !AJOperand methodsFor: 'accessing'! annotation: anObject annotation := anObject! ! !AJOperand methodsFor: 'accessing'! clearId operandId := 0.! ! !AJOperand methodsFor: 'accessing'! compilerData ^ compilerData! ! !AJOperand methodsFor: 'accessing'! operandId ^ operandId! ! !AJOperand methodsFor: 'accessing'! size "Return size of operand in bytes." self shouldBeImplemented ! ! !AJOperand methodsFor: 'accessing'! size16 ^ self size: 2! ! !AJOperand methodsFor: 'accessing'! size32 ^ self size: 4! ! !AJOperand methodsFor: 'accessing'! size64 ^ self size: 8! ! !AJOperand methodsFor: 'accessing'! size8 ^ self size: 1! ! !AJOperand methodsFor: 'accessing'! stackSize ^ self size! ! !AJOperand methodsFor: 'code generation'! emitPushOnStack: asm asm push: self! ! !AJOperand methodsFor: 'converting'! asAJOperand "receiver is already an operand. no nothing"! ! !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: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'! ptr32 "turn receiver into a memory operand with receiver as base, with 4 bytes size" ^ self ptr size: 4! ! !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: '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: 'labels'! extractLabels: aBlockClosure " do nothing"! ! !AJOperand methodsFor: 'printing' stamp: 'CamilloBruni 8/24/2012 13:56'! printAnnotationOn: aStream annotation ifNil: [ ^ self ]. aStream nextPut: $" ; nextPutAll: annotation asString; nextPut: $"; space.! ! !AJOperand methodsFor: 'printing'! printAsOperandOn: aStream ^ self printOn: aStream ! ! !AJOperand methodsFor: 'testing'! is16 ^ self size == 2! ! !AJOperand methodsFor: 'testing'! is32 ^ self size == 4! ! !AJOperand methodsFor: 'testing'! is64 ^ self size == 8! ! !AJOperand methodsFor: 'testing'! is8 ^ self size == 1! ! !AJOperand methodsFor: 'testing'! isImm ^ false ! ! !AJOperand methodsFor: 'testing'! isLabel ^ false! ! !AJOperand methodsFor: 'testing'! isMem ^ false! ! !AJOperand methodsFor: 'testing'! isNone "Return true if operand is none (OP_NONE)." self shouldBeImplemented ! ! !AJOperand methodsFor: 'testing'! isReg ^ false! ! !AJOperand methodsFor: 'testing'! isRegCode: aRegCode self shouldBeImplemented ! ! !AJOperand methodsFor: 'testing'! isRegIndex: aRegIndex ^ self isReg and: [ self index == (aRegIndex bitAnd: RegCodeMask ) ] ! ! !AJOperand methodsFor: 'testing'! isRegMem ^ self isReg or: [ self isMem ]! ! !AJOperand methodsFor: 'testing'! isRegMem: aRegType self shouldBeImplemented ! ! !AJOperand methodsFor: 'testing'! isRegType: aRegType ^ self isReg and: [self type == aRegType]! ! !AJOperand methodsFor: 'testing'! isRegTypeGPB ^ self isRegType: RegGPB! ! !AJOperand methodsFor: 'testing'! isRegTypeGPD ^ self isRegType: RegGPD! ! !AJOperand methodsFor: 'testing'! isRegTypeGPQ ^ self isRegType: RegGPQ! ! !AJOperand methodsFor: 'testing'! isRegTypeGPW ^ self isRegType: RegGPW! ! !AJOperand methodsFor: 'testing'! isRegTypeMM ^ false! ! !AJOperand methodsFor: 'testing'! isRegTypeX87 ^ false! ! !AJOperand methodsFor: 'testing'! isRegTypeXMM ^ false! ! !AJOperand methodsFor: 'testing'! isRip ^ false! ! AJBaseReg subclass: #AJRegister instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-Operands'! !AJRegister methodsFor: 'accessing'! code: aCode code := aCode. size := 1 << (( code bitAnd: RegTypeMask ) >> 4).! ! !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'! size ^ 1 << (( code bitAnd: RegTypeMask ) >> 4).! ! !AJRegister methodsFor: 'testing'! isGeneralPurpose ^ false! ! !AJRegister methodsFor: 'testing'! isReg ^ true! ! AJInstruction subclass: #AJReleaseTemps instanceVariableNames: 'count' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-StackManagement'! !AJReleaseTemps methodsFor: 'accessing'! count ^ count! ! !AJReleaseTemps methodsFor: 'accessing'! count: anObject count := anObject! ! !AJReleaseTemps methodsFor: 'printing'! printOn: aStream ^ self printSelfOn: aStream ! ! !AJReleaseTemps methodsFor: 'printing'! printSelfOn: aStream aStream nextPutAll: 'Release temps: '; print: count ! ! !AJReleaseTemps methodsFor: 'visitor'! accept: anObject anObject visitReleaseTemps: self ! ! !AJReleaseTemps methodsFor: 'visitor'! processTempsWith: anObject anObject releaseTemps: count! ! AJInstruction subclass: #AJReserveTemp instanceVariableNames: 'operand size' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-StackManagement'! !AJReserveTemp commentStamp: 'IgorStasenko 1/18/2012 13:09' prior: 0! note: assembler should set size even before realizing a temp into stack location reference! !AJReserveTemp methodsFor: 'accessing' stamp: 'CamilloBruni 8/24/2012 13:32'! name ^ name ifNil: [ 'Reserve temp' ]! ! !AJReserveTemp methodsFor: 'accessing'! operand ^ operands first! ! !AJReserveTemp methodsFor: 'accessing'! operand: anObject anObject annotation: annotation. operands := Array with: anObject ! ! !AJReserveTemp methodsFor: 'accessing'! size ^ size! ! !AJReserveTemp methodsFor: 'accessing'! size: number size := number! ! !AJReserveTemp methodsFor: 'accessing'! stackSize ^ self size! ! !AJReserveTemp methodsFor: 'converting'! asAJOperand ^ operands first! ! !AJReserveTemp methodsFor: 'emitting code'! emitPushOnStack: asm ^ asm push: self! ! !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: 'printing'! printOn: aStream ^ self printSelfOn: aStream ! ! !AJReserveTemp methodsFor: 'testing'! isMem ^ true! ! !AJReserveTemp methodsFor: 'visitor'! accept: anObject ^ anObject reserveTemp: self! ! !AJReserveTemp methodsFor: 'visitor'! processTempsWith: anObject anObject reserveTemp: self ! ! AJInstruction subclass: #AJRoutineEpilogue instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-Instructions'! AJInstruction subclass: #AJRoutinePrologue instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-Instructions'! !AJRoutinePrologue commentStamp: 'IgorStasenko 5/11/2011 00:32' prior: 0! 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: 'accessing'! name ^ 'prologue' ! ! !AJRoutinePrologue methodsFor: 'emitting code'! emitCode: asm machineCode := #[]! ! !AJRoutinePrologue methodsFor: 'visitor'! accept: anObject ^ anObject visitRoutinePrologue: self! ! !AJRoutinePrologue methodsFor: 'visitor' stamp: 'CamilloBruni 10/4/2012 18:54'! setPrologue: anInstructions "do nothing" | old | old := next. next := anInstructions. anInstructions last next: old ! ! Object subclass: #AJRoutineStackManager instanceVariableNames: 'calls instructions assembler noStackFrame temps maxTemps extraStackBytes' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-StackManagement'! !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'! emitEpilogue: popExtraBytes assembler: asm asm leave. popExtraBytes > 0 ifTrue: [ asm ret: popExtraBytes asUImm ] ifFalse: [ asm ret. ].! ! !AJRoutineStackManager methodsFor: 'as yet unclassified'! newCdeclCall self stackFrameCheck. ^ calls add: (AJCdeclCallInfo new)! ! !AJRoutineStackManager methodsFor: 'as yet unclassified'! newStdCall self stackFrameCheck. ^ calls add: (AJStdCallCallInfo new) ! ! !AJRoutineStackManager methodsFor: 'as yet unclassified'! noStackFrame noStackFrame := true.! ! !AJRoutineStackManager methodsFor: 'as yet unclassified'! releaseTemps: count temps := temps - count! ! !AJRoutineStackManager methodsFor: 'as yet unclassified'! reserveExtraBytesOnStack: numBytes self stackFrameCheck. extraStackBytes := numBytes ! ! !AJRoutineStackManager methodsFor: 'as yet unclassified'! reserveTemp: anAJReserveTemp self stackFrameCheck. temps := temps + 1. maxTemps := maxTemps max: temps . anAJReserveTemp operand: (assembler strackFrameValueAtOffset: extraStackBytes + (temps * assembler wordSize )).! ! !AJRoutineStackManager methodsFor: 'as yet unclassified'! stackFrameCheck noStackFrame ifTrue: [ self error: 'Operation requires stack frame management to be enabled for generated code' ].! ! !AJRoutineStackManager methodsFor: 'emitting'! 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: 'initialize-release'! initialize self reset. noStackFrame := false.! ! !AJRoutineStackManager methodsFor: 'initialize-release'! reset instructions := nil. assembler := nil. calls := OrderedCollection new. temps := maxTemps := extraStackBytes := 0. ! ! AJInstruction subclass: #AJStackInstruction instanceVariableNames: 'callInfo' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-StackManagement'! !AJStackInstruction methodsFor: 'accessing'! callInfo ^ callInfo! ! !AJStackInstruction methodsFor: 'accessing'! callInfo: anObject callInfo := anObject! ! AJCallInfo subclass: #AJStdCallCallInfo instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-StackManagement'! !AJStdCallCallInfo commentStamp: 'IgorStasenko 8/5/2011 06:17' prior: 0! 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'! emitAlignment "do nothing" "stdcall calling convention requires no stack alignment, no stack cleanup after call"! ! !AJStdCallCallInfo methodsFor: 'emitting code'! emitAlignmentIfNeeded "do nothing" "stdcall calling convention requires no stack alignment, no stack cleanup after call"! ! AJx86Assembler subclass: #AJx64Assembler instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-x86'! !AJx64Assembler commentStamp: '' prior: 0! I am an assembler for the Intel x86-64 architecture.! !AJx64Assembler methodsFor: 'accessing' stamp: 'CamilloBruni 4/17/2012 18:17'! instructionDesciptions ^ AJx64InstructionDescription instructions! ! !AJx64Assembler methodsFor: 'accessing' stamp: 'CamilloBruni 4/18/2012 15:25'! newInstruction ^ AJx64Instruction new! ! !AJx64Assembler methodsFor: 'accessing' stamp: 'CamilloBruni 4/18/2012 15:24'! newJumpInstruction ^ AJx64JumpInstruction new! ! !AJx64Assembler methodsFor: 'accessing'! numGPRegisters ^ 16! ! !AJx64Assembler methodsFor: 'accessing'! pointerSize "see AJx86Assembler >> #pointerSize" ^ 8! ! !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'! 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'! R10 "A 64bit general purpose register This register overlaps with R10B, R10W, R10D, R10" ^ R10! ! !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: 'AsmJIT 8/21/2012 17:47'! R10D "A 32bit general purpose register This register overlaps with R10B, R10W, R10D, R10" ^ R10D! ! !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:48'! R11 "A 64bit general purpose register This register overlaps with R11B, R11W, R11D, R11" ^ R11! ! !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: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: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: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'! 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: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: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'! R13 "A 64bit general purpose register This register overlaps with R13B, R13W, R13D, R13" ^ R13! ! !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'! 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'! 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'! 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: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'! 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:47'! R14W "A 16bit general purpose register This register overlaps with R14B, R14W, R14D, R14" ^ R14W! ! !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 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 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'! 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'! R8 "A 64bit general purpose register This register overlaps with R8B, R8W, R8D, R8" ^ R8! ! !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'! 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:48'! R8W "A 16bit general purpose register This register overlaps with R8B, R8W, R8D, R8" ^ R8W! ! !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:48'! R9B "A 8bit general purpose register This register overlaps with R9B, R9W, R9D, R9" ^ R9B! ! !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'! 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'! 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'! RBP "A 64bit general purpose register This register overlaps with CH, CX, ECX, RCX" ^ RBP! ! !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'! 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'! RDI "A 64bit general purpose register This register overlaps with BH, BX, EBX, RBX" ^ RDI! ! !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: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'! 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'! 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'! XMM10 "An SSE register" ^ XMM10! ! !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'! XMM12 "An SSE register" ^ XMM12! ! !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'! XMM14 "An SSE register" ^ XMM14! ! !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'! XMM8 "An SSE register" ^ XMM8! ! !AJx64Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM9 "An SSE register" ^ XMM9! ! !AJx64Assembler methodsFor: 'initialize-release' stamp: 'CamilloBruni 4/17/2012 18:16'! initialize super initialize. is64 := true.! ! !AJx64Assembler methodsFor: 'register'! accumulator ^ RAX! ! !AJx64Assembler methodsFor: 'register'! basePointer ^ RBP ! ! !AJx64Assembler methodsFor: 'register'! counter ^ RCX! ! !AJx64Assembler methodsFor: 'register'! data ^ RDX! ! !AJx64Assembler methodsFor: 'register'! destinationIndex ^ RDI! ! !AJx64Assembler methodsFor: 'register'! instructionPointer ^ RIP! ! !AJx64Assembler methodsFor: 'register'! sourceIndex ^ RSI! ! !AJx64Assembler methodsFor: 'register'! stackPointer ^ RSP! ! !AJx64Assembler methodsFor: 'testing'! is32 ^ false! ! AJx86Instruction subclass: #AJx64Instruction instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-x86-Instructions'! !AJx64Instruction methodsFor: 'accessing'! instructionDesciptions ^ AJx64InstructionDescription instructions! ! !AJx64Instruction methodsFor: 'testing'! is32BitMode ^ false! ! !AJx64Instruction methodsFor: 'testing'! is64BitMode ^ true! ! AJx86InstructionDescription subclass: #AJx64InstructionDescription instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-x86-Instructions'! !AJx64InstructionDescription methodsFor: 'code emitting'! 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 ]. self upperBankHighByteGuardOp1: op1 op2: op2. ^ 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'! 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: '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: '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'! 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 ! ! !AJx64InstructionDescription methodsFor: 'code emitting'! 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" self upperBankHighByteGuardOp1: dst op2: src. emitter emitX86RM: opCode1 size: dst size regOrCode: dst rm: src ! ! !AJx64InstructionDescription methodsFor: 'code emitting'! 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 ! ! AJx86JumpInstruction subclass: #AJx64JumpInstruction instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-x86-Instructions'! !AJx64JumpInstruction methodsFor: 'accessing'! instructionDesciptions ^ AJx64InstructionDescription instructions! ! AJx86GPRegister subclass: #AJx64RipRegister instanceVariableNames: '' classVariableNames: '' poolDictionaries: 'AJx86Registers' category: 'AsmJit-x86-Operands'! !AJx64RipRegister commentStamp: '' prior: 0! 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: 'accessing'! code self ripAccessError! ! !AJx64RipRegister methodsFor: 'accessing'! index self ripAccessError! ! !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: 'converting'! as16 ^ AJx86Registers at: #IP! ! !AJx64RipRegister methodsFor: 'converting'! as32 ^ AJx86Registers at: #EIP! ! !AJx64RipRegister methodsFor: 'converting'! as64 ^ AJx86Registers at: #RIP! ! !AJx64RipRegister methodsFor: 'converting'! as8 self error: 'No 8bit register available for instruction pointer relative addressing'! ! !AJx64RipRegister methodsFor: 'error'! ripAccessError self error: 'RIP register ', self name, ' cannot be used only for 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'! isGeneralPurpose ^ false! ! !AJx64RipRegister methodsFor: 'testing'! isRip ^ true! ! !AJx64RipRegister methodsFor: 'testing'! isUpperBank ^ false! ! !AJx64RipRegister methodsFor: 'testing' stamp: 'CamilloBruni 7/17/2012 11:01'! isX86 ^ false! ! AJAssembler subclass: #AJx86Assembler instanceVariableNames: 'instructions last labels stackManager level is64' classVariableNames: '' poolDictionaries: 'AJConstants AJx86Registers' category: 'AsmJit-x86'! !AJx86Assembler commentStamp: '' prior: 0! 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: 'accessing' stamp: 'CamilloBruni 8/23/2012 16:01'! instructionDesciptions ^ AJx86InstructionDescription instructions! ! !AJx86Assembler methodsFor: 'accessing' stamp: 'CamilloBruni 4/18/2012 15:26'! newInstruction ^ AJx86Instruction new! ! !AJx86Assembler methodsFor: 'accessing' stamp: 'CamilloBruni 8/22/2012 14:26'! newJumpInstruction ^ AJx86JumpInstruction new! ! !AJx86Assembler methodsFor: 'accessing'! numGPRegisters "answer the total number of general-purpose registers for target platform" ^ 8 ! ! !AJx86Assembler methodsFor: 'accessing'! pointerSize "the default pointer size in bytes on this CPU" ^ 4! ! !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: '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: '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: 'accessing'! 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: 'accessing'! stackManager: aStackManager stackManager := aStackManager ! ! !AJx86Assembler methodsFor: 'accessing'! 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: 'accessing'! wordSize ^ 4! ! !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: '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: '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'! BH "A 8bit general purpose register This register overlaps with BH, BX, EBX, RBX" ^ BH! ! !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:48'! BP "A 16bit general purpose register This register overlaps with CH, CX, ECX, RCX" ^ BP! ! !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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: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'! ESP "A 32bit general purpose register This register overlaps with AH, AX, EAX, RAX" ^ ESP! ! !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:47'! MM1 "An MMX register" ^ MM1! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! MM2 "An MMX register" ^ MM2! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! MM3 "An MMX register" ^ MM3! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! MM4 "An MMX register" ^ MM4! ! !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'! MM6 "An MMX register" ^ MM6! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! MM7 "An MMX register" ^ MM7! ! !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: '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: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! ST0 "A floating point register" ^ ST0! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! ST1 "A floating point register" ^ ST1! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! ST2 "A floating point register" ^ ST2! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! ST3 "A floating point register" ^ ST3! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! ST4 "A floating point register" ^ ST4! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! ST5 "A floating point register" ^ ST5! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! ST6 "A floating point register" ^ ST6! ! !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:47'! XMM0 "An SSE register" ^ XMM0! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM1 "An SSE register" ^ XMM1! ! !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'! XMM3 "An SSE register" ^ XMM3! ! !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'! XMM5 "An SSE register" ^ XMM5! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:48'! XMM6 "An SSE register" ^ XMM6! ! !AJx86Assembler methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM7 "An SSE register" ^ XMM7! ! !AJx86Assembler methodsFor: 'alignment' stamp: 'CamilloBruni 4/12/2012 13:52'! align: aByteSize self addInstruction: (AJAlignmentInstruction align: aByteSize)! ! !AJx86Assembler methodsFor: 'alignment'! alignDouble self addInstruction: AJAlignmentInstruction alignDouble! ! !AJx86Assembler methodsFor: 'alignment'! alignQuad self addInstruction: AJAlignmentInstruction alignQuad! ! !AJx86Assembler methodsFor: 'alignment'! alignWord self addInstruction: AJAlignmentInstruction alignWord! ! !AJx86Assembler methodsFor: 'code generation'! bytes ^ self generatedCode bytes.! ! !AJx86Assembler methodsFor: 'code generation'! generatedCode ^ AJGeneratedCode new fromInstructions: self prepareInstructions. ! ! !AJx86Assembler methodsFor: 'code generation'! 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: 'convenience'! db: aByteValue ^ self addInstruction: (AJData byte: aByteValue)! ! !AJx86Assembler methodsFor: 'convenience' stamp: 'CamilloBruni 4/19/2012 13:20'! dd: aByteArray self assert: aByteArray size == SizeDWord. ^ self addInstruction: (AJData data: aByteArray)! ! !AJx86Assembler methodsFor: 'convenience'! dw: aByteArray self assert: aByteArray size == SizeWord. ^ self addInstruction: (AJData data: aByteArray)! ! !AJx86Assembler methodsFor: 'convenience'! mov: assoc "convenience" ^ self mov: assoc key to: assoc value! ! !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: 'convenience'! movsx: src to: dest "Ensure right src/dest order" ^ self movsx: dest with: src! ! !AJx86Assembler methodsFor: 'convenience'! movzx: src to: dest "Ensure right src/dest order" ^ self movzx: dest with: src! ! !AJx86Assembler methodsFor: 'converting'! imm: value ^ value asImm ! ! !AJx86Assembler methodsFor: 'converting'! operand: anObject anObject isInteger ifTrue: [ ^ anObject asImm ]. anObject isString ifTrue: [ ^ anObject ]. ^ anObject! ! !AJx86Assembler methodsFor: 'debugging'! gccDisassemble ^ self gccDisassemble: self bytes.! ! !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: 'debugging' stamp: 'IgorStasenko 5/28/2012 02:25'! writeCodeToFile: aFileName aFileName asReference asReference delete writeStreamDo: [:s| s nextPutAll: self bytes ] ! ! !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: 'function calls'! callCleanup: anAJCdeclCallInfo ^ self addInstruction: (AJCallCleanup new callInfo: anAJCdeclCallInfo )! ! !AJx86Assembler methodsFor: 'function calls'! cdeclCall: aBlock alignment: align ^ self performingCall: (self newCdeclCall alignment: align) in: aBlock ! ! !AJx86Assembler methodsFor: 'function calls'! newCdeclCall "answer an instance of CallInfo" ^ stackManager newCdeclCall asm: self.! ! !AJx86Assembler methodsFor: 'function calls'! newStdCall ^ stackManager newStdCall asm: self ! ! !AJx86Assembler methodsFor: 'function calls'! noticePush: numBytes forCall: aCallInfo self addInstruction: (AJCallArgument new size: numBytes; callInfo: aCallInfo ). ! ! !AJx86Assembler methodsFor: 'function calls'! performingCall: ci in: aBlock ci asm: self; alignmentInsertionPoint: last. aBlock value: ci. self callCleanup: ci.! ! !AJx86Assembler methodsFor: 'function calls'! 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: 'initialize-release' stamp: 'CamilloBruni 3/30/2012 16:20'! initialize is64 := false. self reset.! ! !AJx86Assembler methodsFor: 'initialize-release'! reset instructions := last := nil. labels := Dictionary new. stackManager ifNil: [stackManager := AJRoutineStackManager new.] ifNotNil: #reset. level := 0. self addInstruction: AJRoutinePrologue new. ! ! !AJx86Assembler methodsFor: 'instruction list'! 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: '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: '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: '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: 'instruction list'! 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: 'instruction list'! insert: newInstruction before: anInstruction "insert one or more instructions before an instruction" ^ instructions := instructions insert: newInstruction before: anInstruction! ! !AJx86Assembler methodsFor: 'instruction list'! instructionsFor: aBlockWithCode | old new | old := instructions. instructions := nil. [ aBlockWithCode value. ] ensure: [ new := instructions. instructions := old ]. ^ new! ! !AJx86Assembler methodsFor: 'instruction list' stamp: 'CamilloBruni 8/22/2012 14:24'! 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 ! ! !AJx86Assembler methodsFor: 'instruction list' stamp: 'CamilloBruni 8/22/2012 14:43'! 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 ! ! !AJx86Assembler methodsFor: 'instruction list'! replace: anInstruction with: otherInstructions "replace a single instruction with one or more other instructions" ^ instructions := instructions replace: anInstruction with: otherInstructions.! ! !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: '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'! amdprefetch: aMemoryOperand " " ^ self addInstruction: #amdprefetch operands: { aMemoryOperand }! ! !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'! and: aRegisterOrMemoryOperand with: aSource "Logical AND " ^ self addInstruction: #and operands: { aRegisterOrMemoryOperand . aSource }! ! !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'! 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'! 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'! 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'! 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'! 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'! 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'! 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'! 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'! cmova: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmova operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovae: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmovae operands: { aRegister . aSourceRegisterOrMemory }! ! !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: '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'! cmovc: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmovc operands: { aRegister . aSourceRegisterOrMemory }! ! !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'! cmovg: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmovg operands: { aRegister . aSourceRegisterOrMemory }! ! !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'! 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'! cmovle: aRegister with: aSourceRegisterOrMemory "Conditional Move - less or equal/not greater ((ZF=1) OR (SF!!=OF)) " ^ self addInstruction: #cmovle operands: { aRegister . 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'! cmovnae: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmovnae operands: { aRegister . aSourceRegisterOrMemory }! ! !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: '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'! cmovnc: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmovnc operands: { aRegister . aSourceRegisterOrMemory }! ! !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'! cmovng: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmovng operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovnge: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmovnge operands: { aRegister . aSourceRegisterOrMemory }! ! !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'! 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'! 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'! 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'! 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'! cmovnz: aRegister with: aSourceRegisterOrMemory "Conditional Move - not zero/not equal (ZF=1) " ^ self addInstruction: #cmovnz 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'! 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'! cmovpe: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmovpe operands: { aRegister . aSourceRegisterOrMemory }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmovpo: aRegister with: aSourceRegisterOrMemory " " ^ self addInstruction: #cmovpo operands: { aRegister . aSourceRegisterOrMemory }! ! !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: '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: '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'! cmpxchg16b: aMemoryOperand "... " ^ self addInstruction: #cmpxchg16b operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! cmpxchg8b: aMemoryOperand "Compare and Exchange Bytes " ^ self addInstruction: #cmpxchg8b 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'! 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'! 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: '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'! 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: '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'! fadd: aX87Register1 with: aX87Register2 " see #fadd" ^ self addInstruction: #fadd operands: { aX87Register1 . aX87Register2 }! ! !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'! 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'! 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'! fcmovb: aX87Register "FP Conditional Move - below (CF=1) " ^ self addInstruction: #fcmovb operands: { aX87Register }! ! !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'! fcmove: aX87Register "FP Conditional Move - equal (ZF=1) " ^ self addInstruction: #fcmove operands: { aX87Register }! ! !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'! 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'! fcmovne: aX87Register "FP Conditional Move - not equal (ZF=0) " ^ self addInstruction: #fcmovne operands: { aX87Register }! ! !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'! fcmovu: aX87Register "FP Conditional Move - unordered (PF=1) " ^ self addInstruction: #fcmovu operands: { aX87Register }! ! !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'! fcom: aX87Register1 with: aX87Register2 " see #fcom" ^ self addInstruction: #fcom operands: { aX87Register1 . aX87Register2 }! ! !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'! fcomip: aX87Register "Compare Floating Point Values and Set EFLAGS and Pop " ^ self addInstruction: #fcomip operands: { aX87Register }! ! !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'! fcomp: aX87Register1 with: aX87Register2 " see #fcomp" ^ self addInstruction: #fcomp operands: { aX87Register1 . aX87Register2 }! ! !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'! fdiv: aX87Register1 with: aX87Register2 " see #fdiv" ^ self addInstruction: #fdiv operands: { aX87Register1 . aX87Register2 }! ! !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'! fdivr: aMemoryOperand "Reverse Divide " ^ self addInstruction: #fdivr operands: { aMemoryOperand }! ! !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: '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'! ffree: aX87Register "Free Floating-Point Register " ^ self addInstruction: #ffree operands: { aX87Register }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fiadd: aMemoryOperand "Add " ^ self addInstruction: #fiadd operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! ficom: aMemoryOperand "Compare Integer " ^ self addInstruction: #ficom operands: { aMemoryOperand }! ! !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'! fidiv: aMemoryOperand "Divide " ^ self addInstruction: #fidiv operands: { aMemoryOperand }! ! !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'! 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'! fimul: aMemoryOperand "Multiply " ^ self addInstruction: #fimul operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fist: aMemoryOperand "Store Integer " ^ self addInstruction: #fist operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fistp: aMemoryOperand "Store Integer and Pop " ^ self addInstruction: #fistp operands: { aMemoryOperand }! ! !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'! fisub: aMemoryOperand "Subtract " ^ self addInstruction: #fisub operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fisubr: aMemoryOperand "Reverse Subtract " ^ self addInstruction: #fisubr 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'! fldcw: aMemoryOperand "Load x87 FPU Control Word " ^ self addInstruction: #fldcw operands: { aMemoryOperand }! ! !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'! fmul: aMemoryOperand "Multiply " ^ self addInstruction: #fmul operands: { aMemoryOperand }! ! !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'! fnsave: aMemoryOperand "Store x87 FPU State " ^ self addInstruction: #fnsave operands: { aMemoryOperand }! ! !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'! fnstenv: aMemoryOperand "Store x87 FPU Environment " ^ self addInstruction: #fnstenv operands: { aMemoryOperand }! ! !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'! fsave: aMemoryOperand "Store x87 FPU State " ^ self addInstruction: #fsave operands: { aMemoryOperand }! ! !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'! fstcw: aMemoryOperand "Store x87 FPU Control Word " ^ self addInstruction: #fstcw operands: { aMemoryOperand }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fstenv: aMemoryOperand "Store x87 FPU Environment " ^ self addInstruction: #fstenv operands: { aMemoryOperand }! ! !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: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! fsub: aMemoryOperand "Subtract " ^ self addInstruction: #fsub operands: { aMemoryOperand }! ! !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'! fsubp: aX87Register "Subtract and Pop " ^ self addInstruction: #fsubp operands: { aX87Register }! ! !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'! fsubr: aX87Register1 with: aX87Register2 " see #fsubr" ^ self addInstruction: #fsubr operands: { aX87Register1 . aX87Register2 }! ! !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: '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'! 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'! 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'! 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'! 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'! 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'! 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'! 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'! 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: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! imul: aRegister with: aRegisterOrMemoryOrImmediate " see #imul" ^ self addInstruction: #imul operands: { aRegister . aRegisterOrMemoryOrImmediate }! ! !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'! 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: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! ja: targetLabel " " ^ self addInstruction: #ja operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jae: targetLabel " " ^ self addInstruction: #jae operands: { targetLabel }! ! !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: '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: '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'! je: targetLabel " " ^ self addInstruction: #je operands: { targetLabel }! ! !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'! jge: targetLabel " " ^ self addInstruction: #jge operands: { targetLabel }! ! !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'! jle: targetLabel "Jump short if less or equal/not greater ((ZF=1) OR (SF!!=OF)) " ^ self addInstruction: #jle operands: { targetLabel }! ! !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: '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'! jnae: targetLabel " " ^ self addInstruction: #jnae operands: { targetLabel }! ! !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'! jnbe: targetLabel "Jump short if not below or equal/above (CF=0 AND ZF=0) " ^ self addInstruction: #jnbe operands: { targetLabel }! ! !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'! jne: targetLabel " " ^ self addInstruction: #jne operands: { targetLabel }! ! !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'! jnge: targetLabel " " ^ self addInstruction: #jnge operands: { targetLabel }! ! !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'! 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'! jno: targetLabel "Jump short if not overflow (OF=0) " ^ self addInstruction: #jno operands: { targetLabel }! ! !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: '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: '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'! jo: targetLabel "Jump short if overflow (OF=1) " ^ self addInstruction: #jo operands: { targetLabel }! ! !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: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jpe: targetLabel " " ^ self addInstruction: #jpe operands: { targetLabel }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! jpo: targetLabel " " ^ self addInstruction: #jpo operands: { targetLabel }! ! !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: '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: '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'! lea: aDestinationRegister with: aSourceMemory "Load Effective Address " ^ self addInstruction: #lea operands: { aDestinationRegister . aSourceMemory }! ! !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: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! movPtr: aRegisterOrImmedate1 with: aRegisterOrImmedate2 " " ^ self addInstruction: #movPtr operands: { aRegisterOrImmedate1 . aRegisterOrImmedate2 }! ! !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: '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: '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'! 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'! 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: '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'! 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'! 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: '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'! 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: '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: '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'! 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: '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'! 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: '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: '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: '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: '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'! 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: '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'! 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'! 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'! 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: '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'! 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'! 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'! 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'! 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'! 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'! 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: '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: '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'! rcr: aDestinationRegisterOrMemory with: aRegisterOrImmediate "Rotate " ^ self addInstruction: #rcr operands: { aDestinationRegisterOrMemory . aRegisterOrImmediate }! ! !AJx86Assembler methodsFor: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! ret: anImmediate " " ^ self addInstruction: #ret operands: { anImmediate }! ! !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'! ror: aDestinationRegisterOrMemory with: aRegisterOrImmediate "Rotate " ^ self addInstruction: #ror operands: { aDestinationRegisterOrMemory . aRegisterOrImmediate }! ! !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'! sar: aDestinationRegisterOrMemory with: aRegisterOrImmediate "Shift " ^ self addInstruction: #sar operands: { aDestinationRegisterOrMemory . aRegisterOrImmediate }! ! !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'! shl: aDestinationRegisterOrMemory with: aRegisterOrImmediate "Shift " ^ self addInstruction: #shl operands: { aDestinationRegisterOrMemory . aRegisterOrImmediate }! ! !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: 'instructions generated' stamp: 'CamilloBruni 7/17/2012 13:38'! shr: aDestinationRegisterOrMemory with: aRegisterOrImmediate "Shift " ^ self addInstruction: #shr operands: { aDestinationRegisterOrMemory . aRegisterOrImmediate }! ! !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'! 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'! 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'! 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: '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'! 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'! 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: 'labels' stamp: 'CamilloBruni 5/29/2012 13:15'! label: aNameOrLabel ^ self label: aNameOrLabel ifPresent: [ self error: 'label ', aNameOrLabel asString, ' already set' ].! ! !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: '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: 'labels'! uniqueLabelName: aName ^ self labelNamed: aName, labels size asString! ! !AJx86Assembler methodsFor: 'options'! noStackFrame stackManager noStackFrame.! ! !AJx86Assembler methodsFor: 'register'! accumulator ^ self is32BitMode ifTrue: [ EAX ] ifFalse: [ AX ]! ! !AJx86Assembler methodsFor: 'register'! basePointer ^ self is32BitMode ifTrue: [ EBP ] ifFalse: [ BP ]! ! !AJx86Assembler methodsFor: 'register'! counter ^ self is32BitMode ifTrue: [ ECX ] ifFalse: [ CX ]! ! !AJx86Assembler methodsFor: 'register'! data ^ self is32BitMode ifTrue: [ EDX ] ifFalse: [ DX ]! ! !AJx86Assembler methodsFor: 'register'! destinationIndex ^ self is32BitMode ifTrue: [ EDI ] ifFalse: [ DI ]! ! !AJx86Assembler methodsFor: 'register'! instructionPointer "not available on 32bit x86 CPUs" self notYetImplemented ! ! !AJx86Assembler methodsFor: 'register'! sourceIndex ^ self is32BitMode ifTrue: [ RSI ] ifFalse: [ SI ]! ! !AJx86Assembler methodsFor: 'register'! stackPointer ^ self is32BitMode ifTrue: [ ESP ] ifFalse: [ SP ]! ! !AJx86Assembler methodsFor: 'stack management'! emitEpilogue: popExtraBytes ^ stackManager emitEpilogue: popExtraBytes assembler: self! ! !AJx86Assembler methodsFor: 'stack management'! releaseTemps: count ^ self addInstruction: (AJReleaseTemps new count: count).! ! !AJx86Assembler methodsFor: 'stack management'! reserveExtraBytesOnStack: numBytes ^ stackManager reserveExtraBytesOnStack: numBytes ! ! !AJx86Assembler methodsFor: 'stack management'! reserveTemp ^ self addInstruction: (AJReserveTemp new size: self wordSize). ! ! !AJx86Assembler methodsFor: 'stack management'! strackFrameValueAtOffset: offset ^ EBP ptr32 - offset! ! !AJx86Assembler methodsFor: 'testing'! hasLabelNamed: aName ^ labels includesKey: aName ! ! !AJx86Assembler methodsFor: 'testing'! is32 ^ true! ! !AJx86Assembler methodsFor: 'testing'! isLabelUsed: aLabel | used | used := false. instructions do: [:instr | used := used or: [instr isLabelUsed: aLabel ] ]. ^ used! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AJx86Assembler class instanceVariableNames: ''! !AJx86Assembler class methodsFor: 'debugging'! gccDisassemble: bytesArray "compile the given bytes to a C binary and disassemble it using gdb" ^ self new gccDisassemble: bytesArray! ! !AJx86Assembler class methodsFor: 'instance creation' stamp: 'CamilloBruni 4/19/2012 11:46'! noStackFrame ^ self new noStackFrame! ! AJRegister subclass: #AJx86GPRegister instanceVariableNames: '' classVariableNames: '' poolDictionaries: 'AJx86Registers' category: 'AsmJit-x86-Operands'! !AJx86GPRegister commentStamp: 'sig 12/7/2009 03:22' prior: 0! A general purpose x86 & x64 registers! !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: 'accessing' stamp: 'CamilloBruni 3/20/2012 18:48'! registerName ^ name asString.! ! !AJx86GPRegister methodsFor: 'accessing'! stackSize ^ self size! ! !AJx86GPRegister methodsFor: 'converting' stamp: 'CamilloBruni 7/17/2012 12:51'! as16 self isHighByte ifTrue: [ ^ self asLowByte as16 ]. ^ AJx86Registers code: (16r10 + self index)! ! !AJx86GPRegister methodsFor: 'converting' stamp: 'CamilloBruni 7/17/2012 13:07'! as32 self isHighByte ifTrue: [ ^ self asLowByte as32 ]. ^ AJx86Registers code: (16r20 + self index)! ! !AJx86GPRegister methodsFor: 'converting' stamp: 'CamilloBruni 7/17/2012 13:07'! as64 self isHighByte ifTrue: [ ^ self asLowByte as64 ]. ^ AJx86Registers code: (16r30 + self index)! ! !AJx86GPRegister methodsFor: 'converting' stamp: 'CamilloBruni 7/17/2012 13:03'! as8 self is8 ifTrue: [ ^ self ]. (self index >= 4 and: [ self index <= 7 ] ) ifTrue: [ Error signal: 'Cannot map ', self asString, ' to corrsponding 8bit register']. ^ AJx86Registers code: (0 + self index)! ! !AJx86GPRegister methodsFor: 'converting' stamp: 'CamilloBruni 7/17/2012 13:01'! asHighByte self isHighByte ifTrue: [ ^ self ]. self isLowByte ifFalse: [ Error signal: 'Can only convert high byte 8bit register to low byte' ]. ^ AJx86Registers code: self index + 2r100! ! !AJx86GPRegister methodsFor: 'converting' stamp: 'CamilloBruni 7/17/2012 13:05'! asLowByte self isLowByte ifTrue: [ ^ self ]. self isHighByte ifFalse: [ Error signal: 'Can only convert high byte 8bit register to low byte' ]. ^ AJx86Registers code: self index - 2r100! ! !AJx86GPRegister methodsFor: 'converting'! ptr "turn receiver into a memory operand with receiver as base" ^ AJMem new base: self! ! !AJx86GPRegister methodsFor: 'emitting'! 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: 'printing'! printAsMemBase ^ self registerName ! ! !AJx86GPRegister methodsFor: 'printing'! printOn: aStream aStream nextPutAll: self registerName ! ! !AJx86GPRegister methodsFor: 'testing'! isGeneralPurpose ^ true! ! !AJx86GPRegister methodsFor: 'testing' stamp: 'CamilloBruni 7/17/2012 13:03'! isHighByte "return true for 8bit high-byte registers (AH - DH)" ^ self is8 and: [ (self code bitAnd: RegHighByteMask) = 2r100 ]! ! !AJx86GPRegister methodsFor: 'testing' stamp: 'CamilloBruni 7/17/2012 12:57'! isLowByte "return true for 8bit low-byte register (AL - DL)" ^ self code <= 3! ! AJInstruction subclass: #AJx86Instruction instanceVariableNames: 'description' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-x86-Instructions'! !AJx86Instruction methodsFor: 'accessing' stamp: 'CamilloBruni 4/17/2012 17:55'! description ^ description! ! !AJx86Instruction methodsFor: 'accessing' stamp: 'CamilloBruni 4/17/2012 17:55'! description: anInstructionDescription description := anInstructionDescription! ! !AJx86Instruction methodsFor: 'accessing' stamp: 'CamilloBruni 8/23/2012 16:01'! instructionDesciptions ^ AJx86InstructionDescription instructions! ! !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: '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'! 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'! emitImmediate: imm size: size ^ imm emitUsing: self size: size! ! !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: 'code generation'! 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: 'code generation'! 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: 'code generation'! emitRexForInteger: anInt op2: op2 self emitRexPrefixW: op2 is64 R: false X: false B: op2 isUpperBank.! ! !AJx86Instruction methodsFor: 'code generation'! emitRexForOp1: op1 op2: op2 "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 op2 register. Use of the REX.B prefix permits access to additional registers (R8-R15) for the op1 register. 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: false B: op2 isUpperBank.! ! !AJx86Instruction methodsFor: 'code generation'! 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'! 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 " "no-op in 32 bit mode" self is32BitMode ifTrue: [ ^ self ]. "an empty REX prefix has no effect, hence we ignore it" (w or: [ r or: [ x or: b]]) ifFalse: [ ^ self ]. self emitByte: 2r0100 << 4 | (w asBit << 3) | (r asBit << 2)| (x asBit << 1) | (b asBit)! ! !AJx86Instruction methodsFor: 'code generation'! emitRexR: w opReg: opReg regCode: regCode "no-op in 32 bit mode" ! ! !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: 'code generation'! emitScale: shift index: indexCode base: baseCode self emitByte: shift << 3 + indexCode << 3 + baseCode! ! !AJx86Instruction methodsFor: 'code generation'! emitSegmentPrefix: aMem (aMem isMem and: [ aMem hasSegmentPrefix ]) ifTrue: [ self emitByte: aMem segmentPrefixCode. ] ! ! !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: 'code generation'! 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'! 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: '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'! setLabelPosition: label "set label position for immediate operand(s), if any" label position: self position + machineCode size. ! ! !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: 'emitting code'! emitWord: aWord "little-endian" self emitByte: (aWord bitAnd: 255); emitByte: ((aWord >> 8) bitAnd: 255) ! ! !AJx86Instruction methodsFor: 'testing'! is32BitMode ^ true! ! !AJx86Instruction methodsFor: 'testing'! is64BitMode ^ false! ! !AJx86Instruction methodsFor: 'testing'! 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 ]! ! !AJx86Instruction methodsFor: 'visitor'! accept: anObject "generic instruction" ^ anObject visitInstruction: self ! ! Object subclass: #AJx86InstructionDescription instanceVariableNames: 'name group comment description o1Flags o2Flags opCodeR opCode1 opCode2 groupEmitSelector' classVariableNames: '' poolDictionaries: 'AJConstants AJx86Registers' category: 'AsmJit-x86-Instructions'! !AJx86InstructionDescription commentStamp: 'sig 12/7/2009 10:36' prior: 0! 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: 'accessing' stamp: 'CamilloBruni 4/13/2012 15:44'! comment ^ comment! ! !AJx86InstructionDescription methodsFor: 'accessing' stamp: 'CamilloBruni 4/13/2012 15:44'! comment: aString comment := aString! ! !AJx86InstructionDescription methodsFor: 'accessing' stamp: 'CamilloBruni 4/13/2012 14:51'! description ^ description! ! !AJx86InstructionDescription methodsFor: 'accessing' stamp: 'CamilloBruni 4/13/2012 14:51'! description: aString description := aString! ! !AJx86InstructionDescription methodsFor: 'accessing'! group ^ group! ! !AJx86InstructionDescription methodsFor: 'accessing'! group: anObject "Set the value of group" group := anObject! ! !AJx86InstructionDescription methodsFor: 'accessing'! name ^ name! ! !AJx86InstructionDescription methodsFor: 'accessing'! name: anObject "Set the value of name" name := anObject! ! !AJx86InstructionDescription methodsFor: 'accessing'! o1Flags "Answer the value of o1Flags" ^ o1Flags! ! !AJx86InstructionDescription methodsFor: 'accessing'! o1Flags: anObject "Set the value of o1Flags" o1Flags := anObject! ! !AJx86InstructionDescription methodsFor: 'accessing'! o2Flags "Answer the value of o2Flags" ^ o2Flags! ! !AJx86InstructionDescription methodsFor: 'accessing'! o2Flags: anObject "Set the value of o2Flags" o2Flags := anObject! ! !AJx86InstructionDescription methodsFor: 'accessing'! opCode1 "Answer the value of opCode1" ^ opCode1! ! !AJx86InstructionDescription methodsFor: 'accessing'! opCode1: anObject "Set the value of opCode1" opCode1 := anObject! ! !AJx86InstructionDescription methodsFor: 'accessing'! opCode2 "Answer the value of opCode2" ^ opCode2! ! !AJx86InstructionDescription methodsFor: 'accessing'! opCode2: anObject "Set the value of opCode2" opCode2 := anObject! ! !AJx86InstructionDescription methodsFor: 'accessing'! opCodeR "Answer the value of opCodeR" ^ opCodeR! ! !AJx86InstructionDescription methodsFor: 'accessing'! opCodeR: anObject "Set the value of opCodeR" opCodeR := anObject! ! !AJx86InstructionDescription methodsFor: 'code emitting' stamp: 'CamilloBruni 3/30/2012 17:36'! emittest: emitter operand1: op1 operand2: op2 operand3: op3 | immSize | op1 isRegMem & op2 isReg ifTrue: [ (op1 size = op2 size) ifFalse: [ self error: 'Operands ', op1 asString, ' and ', op2 asString, ' don''t match in size: ', op1 size asString, ' !!= ', op2 size asString ]. self upperBankHighByteGuardOp1: op1 op2: op2. ^ emitter emitX86RM: 16r84 + (op1 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: 'code emitting'! upperBankHighByteGuardOp1: op1 op2: op2 "REX prefix and AH BH CH DH don't go along on 64bit" (((op1 isUpperBank or: [op1 is64]) and: [{ AH. BH. CH. DH} includes: op2 ]) or: [ ((op2 isUpperBank or: [op2 is64]) and: [{ AH. BH. CH. DH} includes: op1 ])]) ifTrue: [ Error signal: '64 bit mode doesn''t allow operand combination ', op1 asString, ' with ', op2 asString ]! ! !AJx86InstructionDescription methodsFor: 'emitting'! 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: 'emitting'! 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: '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: 'emitting'! 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: 'emitting'! 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'! 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: 'emitting'! emitemit: emitter operand1: op1 operand2: op2 operand3: op3 ^ emitter emitOpCode: opCode1! ! !AJx86InstructionDescription methodsFor: 'emitting'! 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: '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'! 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: 'emitting'! 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: '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'! 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: 'emitting'! 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'! emitmmuMovD: emitter operand1: op1 operand2: op2 operand3: op3 self shouldBeImplemented! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitmmuMovQ: emitter operand1: op1 operand2: op2 operand3: op3 self shouldBeImplemented! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitmmuPextr: emitter operand1: op1 operand2: op2 operand3: op3 self shouldBeImplemented! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitmmuPrefetch: emitter operand1: op1 operand2: op2 operand3: op3 self shouldBeImplemented! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitmmuRm3DNow: emitter operand1: op1 operand2: op2 operand3: op3 self shouldBeImplemented! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitmmuRmImm8: emitter operand1: op1 operand2: op2 operand3: op3 self shouldBeImplemented! ! !AJx86InstructionDescription methodsFor: 'emitting'! emitmmurmi: emitter operand1: op1 operand2: op2 operand3: op3 self shouldBeImplemented! ! !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'! 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: 'emitting'! 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'! emitmovbe: anAJx86Assembler operand1: anUndefinedObject operand2: anUndefinedObject3 operand3: anUndefinedObject4 self shouldBeImplemented! ! !AJx86InstructionDescription methodsFor: 'emitting'! 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: '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'! 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: 'emitting'! 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'! 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'! 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'! 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 methodsFor: 'emitting'! 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'! 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: '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'! 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'! emitx87fstsw: anAJx86Assembler operand1: anUndefinedObject operand2: anUndefinedObject3 operand3: anUndefinedObject4 self shouldBeImplemented! ! !AJx86InstructionDescription methodsFor: 'emitting'! 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: 'emitting'! 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: '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'! 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: 'emitting-dispatch'! 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-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: 'errors'! invalidInstruction self error: 'invalid instruction'! ! !AJx86InstructionDescription methodsFor: 'initialize-release'! 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: 'initialize-release'! 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: 'printing'! printDWord: value | str | str := value printStringBase: 16. [str size < 8] whileTrue: [ str:= '0',str ]. ^ '16r', str! ! !AJx86InstructionDescription methodsFor: 'printing'! 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: 'testing'! is32BitOnly ^ (o1Flags bitAnd: 2r1000000000) ~= 0! ! !AJx86InstructionDescription methodsFor: 'testing'! is64BitOnly ^ (o1Flags bitAnd: 2r100000000) ~= 0! ! !AJx86InstructionDescription methodsFor: 'testing'! isJump ^ group == #cjmp or: [ group == #jmp ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AJx86InstructionDescription class instanceVariableNames: 'instructions reference'! !AJx86InstructionDescription class methodsFor: 'accessing'! instructions ^ instructions ifNil: [ self initInstructions ]! ! !AJx86InstructionDescription class methodsFor: 'initialization' stamp: 'CamilloBruni 4/17/2012 17:39'! at: instructionName ^ instructions at: instructionName ! ! !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'! initialize self initInstructions.! ! !AJx86InstructionDescription class methodsFor: 'initialization'! 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 ) (#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: 'initialization'! 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: '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: 'instance creation' stamp: 'CamilloBruni 4/13/2012 14:30'! fromArray: aSpecArray ^ self basicNew fromArray: aSpecArray! ! !AJx86InstructionDescription class methodsFor: 'printing'! printInstructions " AJInstructionDescription printInstructions. AJInstructionDescription printInstructions openInWorkspaceWithTitle: 'x86 instructions' " ^ String streamContents: [:str | self printInstructionsOn: str ] ! ! !AJx86InstructionDescription class methodsFor: 'printing'! 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: 'testing'! 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)) ]. ]. ! ! AJJumpInstruction subclass: #AJx86JumpInstruction instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-x86-Instructions'! !AJx86JumpInstruction methodsFor: 'accessing'! codeSize machineCode ifNil: [ ^ 2 ]. ^ machineCode size! ! !AJx86JumpInstruction methodsFor: 'accessing' stamp: 'CamilloBruni 8/23/2012 16:01'! instructionDesciptions ^ AJx86InstructionDescription instructions! ! !AJx86JumpInstruction methodsFor: 'accessing'! machineCodeSize machineCode ifNil: [ ^ 2 ]. ^ machineCode size! ! !AJx86JumpInstruction methodsFor: 'convenience' stamp: 'CamilloBruni 8/22/2012 18:07'! errorUndefinedLabel: aLabel ^ self error: 'undefined label: ', aLabel name! ! !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: '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: 'emitting code'! 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'! 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: 'emitting code'! emitShortJump: desc offset: delta "short jump" ^ self isConditional ifTrue: [ {(16r70 + desc opCode1). (delta asByte)} asByteArray ] ifFalse: [ {16rEB. (delta asByte)} asByteArray ]! ! !AJx86JumpInstruction methodsFor: 'emitting code'! emitUnconditionalJumpTo: addr ^ { 16rE9. (addr bitAnd: 255). (addr >> 8 bitAnd: 255). (addr >> 16 bitAnd: 255). (addr >> 24 bitAnd: 255)} asByteArray! ! !AJx86JumpInstruction methodsFor: 'testing'! isConditional ^ name ~~ #jmp! ! SharedPool subclass: #AJx86Registers instanceVariableNames: '' classVariableNames: 'AH AL AX BH BL BP BX CH CL CX Codes DH DI DL DX EAX EBP EBX ECX EDI EDX EIP ESI ESP IP MM0 MM1 MM2 MM3 MM4 MM5 MM6 MM7 R10 R10B R10D R10W R11 R11B R11D R11W R12 R12B R12D R12W R13 R13B R13D R13W R14 R14B R14D R14W R15 R15B R15D R15W R8 R8B R8D R8W R9 R9B R9D R9W RAX RBP RBX RCX RDI RDX RIP RSI RSP SI SP ST0 ST1 ST2 ST3 ST4 ST5 ST6 ST7 XMM0 XMM1 XMM10 XMM11 XMM12 XMM13 XMM14 XMM15 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 XMM8 XMM9' poolDictionaries: '' category: 'AsmJit-x86'! !AJx86Registers commentStamp: '' prior: 0! I am a SHaredPool which initializes all the registers needed by the Assmbler.! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AJx86Registers class instanceVariableNames: ''! !AJx86Registers class methodsFor: 'accessing'! all ^ Codes values collect: [ :each| self classPool at: each ]! ! !AJx86Registers class methodsFor: 'accessing'! all16 ^ self all select: [:reg| reg is16 ]! ! !AJx86Registers class methodsFor: 'accessing'! all32 ^ self all select: [:reg| reg is32 ]! ! !AJx86Registers class methodsFor: 'accessing'! all64 ^ self all select: [:reg| reg is64 ]! ! !AJx86Registers class methodsFor: 'accessing'! all8 ^ self all select: [:reg| reg is8 ]! ! !AJx86Registers class methodsFor: 'accessing' stamp: 'CamilloBruni 7/17/2012 10:54'! at: aRegisterIdentifierSymbol ^ self classPool at: aRegisterIdentifierSymbol! ! !AJx86Registers class methodsFor: 'accessing'! code: registerCode "Access a register by its code. Example: RBP == (self code: RBP code)" ^ self classPool at: (Codes at: registerCode)! ! !AJx86Registers class methodsFor: 'accessing'! doesNotUnderstand: aMessage self classPool at: aMessage selector ifPresent: [:val| ^ val ]. ^ super doesNotUnderstand: aMessage! ! !AJx86Registers class methodsFor: 'accessing'! generalPurpose ^ self all select: [ :reg| reg isGeneralPurpose ]! ! !AJx86Registers class methodsFor: 'accessing'! generalPurpose16 ^ self sortRegistersByIndex: (self generalPurpose select: [:reg| reg is16 ])! ! !AJx86Registers class methodsFor: 'accessing'! generalPurpose32 ^ self sortRegistersByIndex: (self generalPurpose select: [:reg| reg is32 ])! ! !AJx86Registers class methodsFor: 'accessing'! generalPurpose64 ^ self sortRegistersByIndex: (self generalPurpose select: [:reg| reg is64 ])! ! !AJx86Registers class methodsFor: 'accessing'! generalPurpose8 ^ self sortRegistersByIndex: (self generalPurpose select: [:reg| reg is8 ])! ! !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: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'! 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'! BH "A 8bit general purpose register This register overlaps with BH, BX, EBX, RBX" ^ self at: #BH! ! !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'! 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: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: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'! 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: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'! 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:47'! DI "A 16bit general purpose register This register overlaps with BH, BX, EBX, RBX" ^ self at: #DI! ! !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:47'! DX "A 16bit general purpose register This register overlaps with DL, DX, EDX, RDX" ^ self at: #DX! ! !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'! 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'! 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'! EDI "A 32bit general purpose register This register overlaps with BH, BX, EBX, RBX" ^ self at: #EDI! ! !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'! EIP "A 32bit instruction pointer register This register overlaps with IP, EIP, RIP" ^ self at: #EIP! ! !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'! 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'! IP "A 16bit instruction pointer register This register overlaps with IP, EIP, RIP" ^ self at: #IP! ! !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:47'! MM1 "An MMX register" ^ self at: #MM1! ! !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'! MM3 "An MMX register" ^ self at: #MM3! ! !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:47'! MM5 "An MMX register" ^ self at: #MM5! ! !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:48'! MM7 "An MMX register" ^ self at: #MM7! ! !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'! 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: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'! 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: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: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: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: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: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'! R12B "A 8bit general purpose register This register overlaps with R12B, R12W, R12D, R12" ^ self at: #R12B! ! !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: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'! 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'! R13B "A 8bit general purpose register This register overlaps with R13B, R13W, R13D, R13" ^ self at: #R13B! ! !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:47'! R13W "A 16bit general purpose register This register overlaps with R13B, R13W, R13D, R13" ^ self at: #R13W! ! !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 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'! 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'! 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:48'! R15 "A 64bit general purpose register This register overlaps with R15B, R15W, R15D, R15" ^ self at: #R15! ! !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'! 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'! 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: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'! R8B "A 8bit general purpose register This register overlaps with R8B, R8W, R8D, R8" ^ self at: #R8B! ! !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: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'! 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: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'! 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'! 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'! RAX "A 64bit general purpose register This register overlaps with AL, AX, EAX, RAX" ^ self at: #RAX! ! !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! ! !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: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'! RDI "A 64bit general purpose register This register overlaps with BH, BX, EBX, RBX" ^ self at: #RDI! ! !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: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'! 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: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'! 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: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'! ST0 "A floating point register" ^ self at: #ST0! ! !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'! ST2 "A floating point register" ^ self at: #ST2! ! !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'! ST4 "A floating point register" ^ self at: #ST4! ! !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:48'! ST6 "A floating point register" ^ self at: #ST6! ! !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:47'! XMM0 "An SSE register" ^ self at: #XMM0! ! !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:48'! XMM10 "An SSE register" ^ self at: #XMM10! ! !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'! XMM12 "An SSE register" ^ self at: #XMM12! ! !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'! XMM14 "An SSE register" ^ self at: #XMM14! ! !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'! XMM2 "An SSE register" ^ self at: #XMM2! ! !AJx86Registers class methodsFor: 'accessing registers' stamp: 'AsmJIT 8/21/2012 17:47'! XMM3 "An SSE register" ^ self at: #XMM3! ! !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'! XMM5 "An SSE register" ^ self at: #XMM5! ! !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'! XMM7 "An SSE register" ^ self at: #XMM7! ! !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'! XMM9 "An SSE register" ^ self at: #XMM9! ! !AJx86Registers class methodsFor: 'initialization' stamp: 'CamilloBruni 8/23/2012 17:12'! initialize | author | 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: 'initialization' stamp: 'CamilloBruni 7/17/2012 11:04'! initializeGeneralPurpose16BitRegisters "initialize general purpose 16 bit registers " self registerBase: 16r10 class: AJx86GPRegister values: #( #AX #CX #DX #BX #SP #BP #SI #DI #R8W #R9W #R10W #R11W #R12W #R13W #R14W #R15W ).! ! !AJx86Registers class methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2012 11:04'! initializeGeneralPurpose32BitRegisters "initialize general purpose 32 bit registers " self registerBase: 16r20 class: AJx86GPRegister values: #( #EAX #ECX #EDX #EBX #ESP #EBP #ESI #EDI #R8D #R9D #R10D #R11D #R12D #R13D #R14D #R15D ).! ! !AJx86Registers class methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2012 11:04'! initializeGeneralPurpose64BitRegisters "initialize general purpose 64 bit registers" self registerBase: 16r30 class: AJx86GPRegister values: #( #RAX #RCX #RDX #RBX #RSP #RBP #RSI #RDI #R8 #R9 #R10 #R11 #R12 #R13 #R14 #R15).! ! !AJx86Registers class methodsFor: 'initialization' stamp: 'CamilloBruni 7/17/2012 11:04'! initializeGeneralPurpose8BitRegisters "general purpose 8 bit registers " self registerBase: 0 class: AJx86GPRegister values: #( #AL #CL #DL #BL #AH #CH #DH #BH #R8B #R9B #R10B #R11B #R12B #R13B #R14B #R15B).! ! !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: 'initialization'! initializeMMXRegisters " MMX registers " self registerBase: 16r60 class: AJMMRegister values: #( #MM0 #MM1 #MM2 #MM3 #MM4 #MM5 #MM6 #MM7 ).! ! !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: '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: '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: 'initialization'! sortRegistersByIndex: aRegisterCollection ^ aRegisterCollection sort: [ :regA :regB| regA index < regB index ].! ! !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: '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: '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: '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: $"! ! AJBaseReg subclass: #AJx87Register instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-x86-Operands'! !AJx87Register commentStamp: '' prior: 0! I am an c87 Floating Point register! !AJx87Register methodsFor: 'accessing'! code: aCode code := aCode bitOr: RegX87. size := 10.! ! !AJx87Register methodsFor: 'printing' stamp: 'CamilloBruni 7/17/2012 11:12'! descriptionOn: s s nextPutAll: 'A floating point register'.! ! !AJx87Register methodsFor: 'testing'! isGeneralPurpose ^ false! ! !AJx87Register methodsFor: 'testing'! isRegTypeX87 ^ true! ! AJBaseReg subclass: #AJxMMRegister instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AsmJit-x86-Operands'! !AJxMMRegister methodsFor: 'accessing'! code: aCode code := aCode. size := 16! ! !AJxMMRegister methodsFor: 'printing' stamp: 'CamilloBruni 7/17/2012 11:15'! descriptionOn: s s nextPutAll: 'An SSE register'.! ! !AJxMMRegister methodsFor: 'testing'! isGeneralPurpose ^ false! ! !AJxMMRegister methodsFor: 'testing'! isRegTypeXMM ^ true! ! WeakIdentityKeyDictionary subclass: #ASTCache instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Parser'! !ASTCache commentStamp: '' prior: 0! 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: 'CamilloBruni 2/17/2012 14:32'! at: aCompiledMethod ^ self at: aCompiledMethod ifAbsentPut: [ aCompiledMethod parseTree annotateInClass: aCompiledMethod methodClass ]! ! !ASTCache methodsFor: 'accessing' stamp: 'CamilloBruni 2/17/2012 14:29'! reset self removeAll! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ASTCache class instanceVariableNames: 'default'! !ASTCache class methodsFor: 'accessing' stamp: 'CamilloBruni 2/17/2012 14:22'! at: aCompiledMethod ^ default at: aCompiledMethod! ! !ASTCache class methodsFor: 'accessing' stamp: 'CamilloBruni 2/17/2012 14:30'! default ^ default! ! !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: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: 'system startup' stamp: 'CamilloBruni 2/17/2012 15:10'! shutDown self reset.! ! Exception subclass: #Abort instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Exceptions'! !Abort methodsFor: 'as yet unclassified' 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! ! DialogWindow subclass: #AboutDialogWindow instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Windows'! !AboutDialogWindow commentStamp: 'gvc 5/18/2007 13:53' prior: 0! 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}! ! Path variableSubclass: #AbsolutePath instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Core-Kernel'! !AbsolutePath commentStamp: '' prior: 0! I represent an absolute path (a position starting from Path root)! !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: 'enumerating' stamp: 'EstebanLorenzano 4/2/2012 11:42'! withParents ^ super withParents addFirst: (Path root); yourself! ! !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 methodsFor: 'testing' stamp: 'cwp 2/26/2011 11:03'! isRoot ^ self size = 0! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbsolutePath class instanceVariableNames: ''! !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! ! ComposableModel subclass: #AbstractApiSetter instanceVariableNames: 'choice method model selector retrievingMethod isSetting' classVariableNames: '' poolDictionaries: '' category: 'Spec-Tools-Editor'! !AbstractApiSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/11/2012 17:50'! choice ^ choice! ! !AbstractApiSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/12/2012 20:35'! isSetting ^ isSetting! ! !AbstractApiSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/12/2012 20:35'! isSetting: aBoolean isSetting := aBoolean ! ! !AbstractApiSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/11/2012 17:50'! method ^ method contents! ! !AbstractApiSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/11/2012 17:50'! method: anObject method contents: anObject! ! !AbstractApiSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/11/2012 17:50'! model ^ model contents! ! !AbstractApiSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/11/2012 17:50'! model: anObject model contents: anObject! ! !AbstractApiSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/11/2012 17:50'! retrievingMethod ^ retrievingMethod contents! ! !AbstractApiSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/11/2012 17:50'! retrievingMethod: anObject retrievingMethod contents: anObject! ! !AbstractApiSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/11/2012 17:50'! selector ^ selector! ! !AbstractApiSetter methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 7/12/2012 20:35'! initialize "Initialization code for BooleanApiSetter" method := nil asValueHolder. model := nil asValueHolder. retrievingMethod := nil asValueHolder. isSetting := false. super initialize. self registerEvents! ! !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 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: '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: '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: '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: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 18:46'! initialExtent ^ 450@25! ! !AbstractApiSetter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/12/2012 20:34'! internUpdateWith: aValue self subclassResponsibility! ! !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: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 18:59'! updateWith: aValue self isSetting ifFalse: [ self isSetting: true. self internUpdateWith: aValue. self isSetting: false ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbstractApiSetter class instanceVariableNames: ''! !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! ! ComposableModel subclass: #AbstractBasicWidget instanceVariableNames: 'helpHolder borderWidth borderColor enabledHolder' classVariableNames: '' poolDictionaries: '' category: 'Spec-Widgets'! !AbstractBasicWidget commentStamp: '' prior: 0! AbstractBasicWidget is an abstract class for basic widgets! !AbstractBasicWidget methodsFor: 'as yet unclassified' stamp: 'BenjaminVanRyseghem 2/22/2013 00:22'! buildWithSpec: aSpec "Build the widget using the spec name provided as argument" | widget | (self spec notNil and: [ self needRebuild not ]) ifTrue: [ ^ self widget ] ifFalse: [ widget := SpecInterpreter buildWidgetFor: self withSpec: aSpec ]. self ensureExtentFor: widget. self ensureKeyBindingsFor: widget. self announce: (WidgetBuilt model: self widget: widget). ^ widget! ! !AbstractBasicWidget methodsFor: 'as yet unclassified' stamp: 'BenjaminVanRyseghem 2/22/2013 00:22'! buildWithSpecLayout: aSpecLayout "Build the widget using the spec name provided as argument" | widget | (self spec notNil and: [ self needRebuild not ]) ifTrue: [ ^ self widget ] ifFalse: [ widget := SpecInterpreter interpretASpec: aSpecLayout model: self ]. self ensureExtentFor: widget. self ensureKeyBindingsFor: widget. self announce: (WidgetBuilt model: self widget: widget). ^ widget! ! !AbstractBasicWidget methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 7/16/2012 18:09'! initialize "Initialization code for AbstractBasicWidget" super initialize. helpHolder := nil asValueHolder. borderWidth := 0 asValueHolder. borderColor := Color transparent asValueHolder. enabledHolder := true asValueHolder. helpHolder whenChangedDo: [:string | self widget ifNotNil: [:w | w setBalloonText: string ]]. borderWidth whenChangedDo: [:int | self widget ifNotNil: [:w | w borderWidth: int ]]. borderColor whenChangedDo: [:color | self widget ifNotNil: [:w | w borderColor: color ]]. enabledHolder whenChangedDo: [:b | self widget ifNotNil: [:w | w enabled: b ]].! ! !AbstractBasicWidget methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/12/2012 18:10'! initializeWidgets "ignore this method since there is no composition in basic widgets"! ! !AbstractBasicWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 05:27'! borderColor "Return the border color" ^ borderColor contents! ! !AbstractBasicWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 19:31'! borderColor: aColor "Set the border width" borderColor contents: aColor ! ! !AbstractBasicWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 05:17'! borderWidth "Return the border width" ^ borderWidth contents! ! !AbstractBasicWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 17:46'! borderWidth: anInteger "Set the border width" borderWidth contents: anInteger! ! !AbstractBasicWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/18/2012 16:51'! color ^ self widget ifNil: [ Color white ] ifNotNil: [:w | w color ]! ! !AbstractBasicWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/18/2012 16:51'! color: aColor ^ self widget ifNotNil: [:w | w color: aColor ]! ! !AbstractBasicWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 18:06'! disable "Disable the label" self enabled: false! ! !AbstractBasicWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 18:06'! enable "Enable the label" self enabled: true! ! !AbstractBasicWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 18:02'! enabled ^ enabledHolder contents! ! !AbstractBasicWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 18:02'! enabled: aBoolean "Set if the button is enabled (clickable)" enabledHolder contents: aBoolean! ! !AbstractBasicWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/12/2012 17:55'! help "Return the ballon text" ^ helpHolder contents! ! !AbstractBasicWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 05:18'! help: aString "Set the help string" helpHolder contents: aString! ! !AbstractBasicWidget 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! ! !AbstractBasicWidget 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! ! !AbstractBasicWidget 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! ! !AbstractBasicWidget 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! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbstractBasicWidget class instanceVariableNames: ''! !AbstractBasicWidget class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 6/13/2012 16:36'! defaultSpec ^ SpecLayout composed! ! Object subclass: #AbstractBindings instanceVariableNames: 'classSymbols selectorSymbols' classVariableNames: '' poolDictionaries: '' category: 'Spec-Bindings'! !AbstractBindings commentStamp: '' prior: 0! AbstractHolder is an abstract class which handle two dictionaries: one for classes symbol, and one for selectors symbols.! !AbstractBindings methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 3/23/2012 14:55'! initialize "Initialization code for AbstractHolder" super initialize. classSymbols := self initializeClassesDictionary. selectorSymbols := self initializeSelectorsDictionary! ! !AbstractBindings methodsFor: 'initialization'! initializeClassesDictionary ^ IdentityDictionary new! ! !AbstractBindings methodsFor: 'initialization'! initializeSelectorsDictionary ^ IdentityDictionary new! ! !AbstractBindings methodsFor: 'protocol'! classSymbolFor: aSymbol ^ classSymbols at: aSymbol! ! !AbstractBindings methodsFor: 'protocol'! classSymbolFor: aSymbol ifAbsent: aBlock ^ classSymbols at: aSymbol ifAbsent: aBlock! ! !AbstractBindings methodsFor: 'protocol'! classSymbolFor: aSymbol is: aClassSymbol ^ classSymbols at: aSymbol put: aClassSymbol! ! !AbstractBindings methodsFor: 'protocol'! selectorSymbolFor: aSymbol ^ selectorSymbols at: aSymbol! ! !AbstractBindings methodsFor: 'protocol'! selectorSymbolFor: aSymbol ifAbsent: aBlock ^ selectorSymbols at: aSymbol ifAbsent: aBlock! ! !AbstractBindings methodsFor: 'protocol'! selectorSymbolFor: aSymbol is: aSelector ^ selectorSymbols at: aSymbol put: aSelector! ! AbstractWidget subclass: #AbstractCategoryWidget instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Nautilus-Widgets'! !AbstractCategoryWidget commentStamp: '' prior: 0! AbstractCategoryWidget is an abstraction describing a widget used to manage categories! !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: 'drag and drop'! dropMethod: aCollectionOfMethods inARow: aRow self model dropMethod: aCollectionOfMethods inARow: aRow! ! !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: 'icon'! thereIsNoIconsOnCategories! ! !AbstractCategoryWidget methodsFor: 'item creation'! buildCategoriesList ^ self subclassResponsibility! ! !AbstractCategoryWidget methodsFor: 'protocol'! categoriesMenu: aMenuMorph shifted: aBoolean ^ self model categoriesMenu: aMenuMorph shifted: aBoolean ! ! !AbstractCategoryWidget methodsFor: 'protocol'! categoriesSelection ^ self subclassResponsibility! ! !AbstractCategoryWidget methodsFor: 'protocol'! keyPressedOnCategory: anEvent ^ self subclassResponsibility! ! !AbstractCategoryWidget methodsFor: 'protocol'! label: aString ^ self subclassResponsibility! ! !AbstractCategoryWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/17/2012 16:57'! okToChange ^ self model okToChange! ! !AbstractCategoryWidget methodsFor: 'protocol'! searchedElement: index ^ self subclassResponsibility! ! !AbstractCategoryWidget methodsFor: 'protocol'! selectedCategories ^ self subclassResponsibility! ! !AbstractCategoryWidget methodsFor: 'protocol'! selectedCategory ^ self model selectedCategory! ! !AbstractCategoryWidget methodsFor: 'protocol'! showInstance ^ self model showInstance! ! !AbstractCategoryWidget methodsFor: 'protocol'! takeKeyboardFocus ^ self subclassResponsibility! ! !AbstractCategoryWidget methodsFor: 'protocol'! vScrollValue ^ self subclassResponsibility! ! !AbstractCategoryWidget methodsFor: 'protocol'! vScrollValue: aNumber ^ self subclassResponsibility! ! Object subclass: #AbstractDescription instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Spec-Builder'! !AbstractDescription methodsFor: 'processing' stamp: 'BenjaminVanRyseghem 2/27/2012 07:35'! generate ^ self generateSpec asOrderedCollection addFirst: #model; asArray! ! !AbstractDescription methodsFor: 'processing' stamp: 'BenjaminVanRyseghem 2/27/2012 06:44'! generateSpec ^ self subclassResponsibility! ! Object subclass: #AbstractEcryptor instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KeyChain'! !AbstractEcryptor commentStamp: '' prior: 0! 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! ! Object subclass: #AbstractEcryptorDecryptor instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KeyChain'! !AbstractEcryptorDecryptor commentStamp: '' prior: 0! 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! ! FileSystemVisitor subclass: #AbstractEnumerationVisitor instanceVariableNames: 'out block' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Core-Implementation'! !AbstractEnumerationVisitor commentStamp: '' prior: 0! 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: 'EstebanLorenzano 4/2/2012 11:37'! breadthFirst: aReference ^ self visit: aReference with: (BreadthFirstGuide 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:38'! preorder: aReference ^ self visit: aReference with: (PreorderGuide for: self)! ! !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: 'CamilloBruni 8/9/2011 15:48'! visitReference: anEntry self subclassResponsibility! ! SingleTreeTest subclass: #AbstractEnumerationVisitorTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Tests-Core'! !AbstractEnumerationVisitorTest methodsFor: 'as yet unclassified' stamp: 'EstebanLorenzano 4/2/2012 11:43'! 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 = expected! ! !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 class instanceVariableNames: ''! !AbstractEnumerationVisitorTest class methodsFor: 'as yet unclassified' stamp: 'EstebanLorenzano 4/3/2012 09:42'! isAbstract ^ self name = #AbstractEnumerationVisitorTest! ! Object subclass: #AbstractFileReference instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Core-Public'! !AbstractFileReference commentStamp: '' prior: 0! 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: '*Network-Url' stamp: 'CamilloBruni 7/10/2012 15:03'! asUrl "Convert my path into a file:// type url - a FileUrl." ^ self path asUrl! ! !AbstractFileReference methodsFor: '*Polymorph-Widgets' stamp: 'CamilloBruni 1/23/2013 12:41'! item ^ self! ! !AbstractFileReference methodsFor: '*codeimport' stamp: 'CamilloBruni 7/10/2012 20:14'! fileIn self readStreamDo: [ :stream | CodeImporter evaluateFileStream: stream ]! ! !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: 'accessing' stamp: 'PavelKrivanek 11/23/2012 12:21'! absolutePath "Returns the absolute path" ^ self subclassResponsibility! ! !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: '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: '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: '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 20:51'! creationTime ^ self resolve creationTime ! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 15:04'! entry ^ self resolve entry! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 15:30'! extension ^ self fullPath extension.! ! !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: 'accessing' stamp: 'CamilloBruni 7/10/2012 15:01'! fileSystem ^ self resolve fileSystem! ! !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: 'accessing' stamp: 'PavelKrivanek 11/23/2012 12:21'! fullPath "Returns the absolute path, better use absolutePath" ^ self subclassResponsibility! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 22:12'! humanReadableSize ^ self size humanReadableSIByteSize! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 20:51'! modificationTime ^ self resolve modificationTime ! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 15:31'! pathSegments ^ self fullPath segments! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 21:29'! permissions "Return the FileSystemPermission for this node" ^ self resolve permissions! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 22:05'! size ^ self resolve size! ! !AbstractFileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 15:31'! uri "Convert my path into a file:// type url. For odd characters use %20 notation." self flag: 'TODO: return a real URI object instead of a string'. ^(String streamContents: [:strm | strm nextPutAll: 'file:'. self pathSegments do: [:each | strm nextPut: $/; nextPutAll: each encodeForHTTP]. strm nextPut: $/]) asURI! ! !AbstractFileReference methodsFor: 'comparing' stamp: 'CamilloBruni 7/10/2012 15:20'! <= other ^ self path <= self other path! ! !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: 'comparing' stamp: 'CamilloBruni 7/10/2012 15:32'! containsPath: aPath ^ self fullPath containsPath: aPath! ! !AbstractFileReference methodsFor: 'comparing' stamp: 'CamilloBruni 8/9/2012 12:31'! hash "Hash is reimplemented because #= is reimplemented" ^ self path hash! ! !AbstractFileReference methodsFor: 'comparing' stamp: 'CamilloBruni 9/5/2012 18:07'! isContainedBy: anObject "DoubleDispatch helper for #contains:" ^ anObject containsReference: self resolve! ! !AbstractFileReference methodsFor: 'converting' stamp: 'PavelKrivanek 11/23/2012 12:21'! asAbsolute self subclassResponsibility! ! !AbstractFileReference methodsFor: 'converting' stamp: 'PavelKrivanek 11/23/2012 12:21'! asFileReference self subclassResponsibility ! ! !AbstractFileReference methodsFor: 'copying' stamp: 'PavelKrivanek 11/23/2012 12:21'! copyWithPath: newPath self subclassResponsibility! ! !AbstractFileReference methodsFor: 'delegated' stamp: 'CamilloBruni 7/10/2012 15:04'! asPathWith: anObject ^ self resolve asPathWith: anObject! ! !AbstractFileReference methodsFor: 'delegated' stamp: 'CamilloBruni 7/10/2012 15:04'! copyTo: aReference ^ self resolve copyTo: aReference resolve! ! !AbstractFileReference methodsFor: 'delegated' stamp: 'CamilloBruni 7/10/2012 15:04'! exists ^ self resolve exists! ! !AbstractFileReference methodsFor: 'delegated' stamp: 'CamilloBruni 7/10/2012 15:04'! filesystem self deprecated: 'Use fileSystem' on: '3 April 2012' in: 'Pharo 1.4'. ^ self fileSystem! ! !AbstractFileReference methodsFor: 'delegated' stamp: 'CamilloBruni 7/10/2012 15:04'! fullName ^ self resolve fullName! ! !AbstractFileReference methodsFor: 'delegated' stamp: 'CamilloBruni 7/10/2012 15:04'! macTypeAndCreator ^ self resolve macTypeAndCreator! ! !AbstractFileReference methodsFor: 'delegated' stamp: 'CamilloBruni 7/10/2012 15:04'! mimeTypes ^ self resolve mimeTypes! ! !AbstractFileReference methodsFor: 'delegated' stamp: 'CamilloBruni 7/10/2012 15:04'! parent ^ self withPath: self path parent! ! !AbstractFileReference methodsFor: 'delegated' stamp: 'CamilloBruni 7/10/2012 15:04'! pathString ^ self resolve pathString! ! !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: '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: 'enumerating' stamp: 'CamilloBruni 7/10/2012 15:35'! allEntries ^ CollectVisitor breadthFirst: self resolve! ! !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: 'enumerating' stamp: 'CamilloBruni 8/9/2012 11:38'! childNames ^ self children collect: #basename! ! !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 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: '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: '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 8/9/2012 11:38'! directoryNames ^ self directories collect: #basename! ! !AbstractFileReference methodsFor: 'enumerating' stamp: 'CamilloBruni 7/10/2012 15:04'! entries ^ self resolve entries! ! !AbstractFileReference methodsFor: 'enumerating' stamp: 'CamilloBruni 7/10/2012 15:30'! fileNames ^ self files collect: #basename! ! !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: '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 15:35'! glob: aBlock ^ SelectVisitor breadthFirst: self resolve select: aBlock! ! !AbstractFileReference methodsFor: 'navigating' stamp: 'CamilloBruni 7/10/2012 15:08'! , extension ^ self withPath: self path, extension! ! !AbstractFileReference methodsFor: 'navigating' stamp: 'CamilloBruni 7/10/2012 20:36'! / aString ^ self withPath: self path / aString! ! !AbstractFileReference methodsFor: 'navigating' stamp: 'CamilloBruni 7/10/2012 15:49'! makeRelative: anObject ^ anObject relativeToReference: self resolve! ! !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: 'navigating' stamp: 'CamilloBruni 7/10/2012 15:50'! relativeToPath: landmarkPath ^ self fullPath relativeTo: landmarkPath! ! !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: 'PavelKrivanek 11/23/2012 12:21'! resolve ^ self subclassResponsibility ! ! !AbstractFileReference methodsFor: 'navigating' stamp: 'CamilloBruni 7/10/2012 15:05'! resolve: anObject ^ anObject asResolvedBy: self! ! !AbstractFileReference methodsFor: 'navigating' stamp: 'CamilloBruni 7/10/2012 15:18'! resolvePath: aPath ^ self withPath: (self path resolvePath: aPath)! ! !AbstractFileReference methodsFor: 'navigating' stamp: 'CamilloBruni 7/10/2012 15:18'! resolveReference: aReference ^ aReference isAbsolute ifTrue: [ aReference ] ifFalse: [ self withPath: aReference path ]! ! !AbstractFileReference methodsFor: 'navigating' stamp: 'PavelKrivanek 11/23/2012 12:21'! resolveString: aString self subclassResponsibility! ! !AbstractFileReference methodsFor: 'navigating' stamp: 'CamilloBruni 7/10/2012 15:05'! withExtension: aString ^ self withPath: (self path withExtension: aString)! ! !AbstractFileReference methodsFor: 'navigating' stamp: 'CamilloBruni 7/10/2012 15:18'! withPath: newPath ^ self path == newPath ifTrue: [ self ] ifFalse: [ self copyWithPath: newPath ]! ! !AbstractFileReference methodsFor: 'operations' stamp: 'CamilloBruni 7/10/2012 15:51'! copyAllTo: aResolvable CopyVisitor copy: self resolve asAbsolute to: aResolvable resolve! ! !AbstractFileReference methodsFor: 'operations' stamp: 'CamilloBruni 7/10/2012 15:52'! createDirectory self resolve createDirectory! ! !AbstractFileReference methodsFor: 'operations' stamp: 'CamilloBruni 7/10/2012 15:04'! delete ^ self resolve delete! ! !AbstractFileReference methodsFor: 'operations' stamp: 'CamilloBruni 7/10/2012 15:52'! deleteAll "delete this directory and all children of it" DeleteVisitor delete: self resolve! ! !AbstractFileReference methodsFor: 'operations' stamp: 'CamilloBruni 7/10/2012 15:52'! deleteAllChildren "delete all children of the receiver" self children do: [:aReference | aReference deleteAll ]! ! !AbstractFileReference methodsFor: 'operations' stamp: 'CamilloBruni 7/10/2012 15:56'! deleteIfAbsent: aBlock self resolve deleteIfAbsent: aBlock! ! !AbstractFileReference methodsFor: 'operations' stamp: 'CamilloBruni 7/10/2012 15:54'! ensureDeleted self deleteIfAbsent: [].! ! !AbstractFileReference methodsFor: 'operations' stamp: 'CamilloBruni 7/10/2012 15:04'! ensureDirectory ^ self resolve ensureDirectory! ! !AbstractFileReference methodsFor: 'operations' stamp: 'CamilloBruni 7/10/2012 15:53'! ensureFile "Create if necessary a file for the receiver." self writeStream close. ! ! !AbstractFileReference methodsFor: 'operations' stamp: 'CamilloBruni 7/10/2012 15:04'! moveTo: aReference ^ self resolve moveTo: aReference! ! !AbstractFileReference methodsFor: 'operations' stamp: 'PavelKrivanek 11/23/2012 12:21'! renameTo: newBasename self subclassResponsibility! ! !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: 'resolving' stamp: 'CamilloBruni 7/10/2012 15:20'! asResolvedBy: anObject ^ anObject resolveReference: self! ! !AbstractFileReference methodsFor: 'streams' stamp: 'CamilloBruni 7/10/2012 20:16'! openWritable: aBoolean ^ self resolve openWritable: aBoolean! ! !AbstractFileReference methodsFor: 'streams' stamp: 'PavelKrivanek 11/23/2012 12:21'! readStream self subclassResponsibility! ! !AbstractFileReference methodsFor: 'streams' stamp: 'CamilloBruni 7/10/2012 15:26'! readStreamDo: aBlock | stream | stream := self readStream. ^ [ aBlock value: stream ] ensure: [ stream close ]! ! !AbstractFileReference methodsFor: 'streams' stamp: 'CamilloBruni 7/10/2012 15:26'! readStreamDo: doBlock ifAbsent: absentBlock ^ self isFile ifTrue: [ self readStreamDo: doBlock ] ifFalse: absentBlock! ! !AbstractFileReference methodsFor: 'streams' stamp: 'CamilloBruni 7/10/2012 15:26'! readStreamIfAbsent: absentBlock ^ self isFile ifTrue: [ self readStream ] ifFalse: absentBlock! ! !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: 'streams' stamp: 'PavelKrivanek 11/23/2012 12:21'! writeStream self subclassResponsibility! ! !AbstractFileReference methodsFor: 'streams' stamp: 'CamilloBruni 7/10/2012 15:24'! writeStreamDo: aBlock | stream | stream := self writeStream. ^ [ aBlock value: stream ] ensure: [ stream close ]! ! !AbstractFileReference methodsFor: 'streams' stamp: 'CamilloBruni 7/10/2012 15:24'! writeStreamDo: doBlock ifPresent: presentBlock ^ self isFile ifTrue: presentBlock ifFalse: [ self writeStreamDo: doBlock ]! ! !AbstractFileReference methodsFor: 'streams' stamp: 'CamilloBruni 7/10/2012 15:24'! writeStreamIfPresent: presentBlock ^ self isFile ifTrue: presentBlock ifFalse: [ self writeStream ]! ! !AbstractFileReference methodsFor: 'testing' stamp: 'CamilloBruni 7/10/2012 15:05'! hasChildren ^self resolve hasChildren! ! !AbstractFileReference methodsFor: 'testing' stamp: 'CamilloBruni 7/10/2012 15:05'! hasDirectories ^self resolve hasDirectories! ! !AbstractFileReference methodsFor: 'testing' stamp: 'CamilloBruni 7/10/2012 15:05'! hasFiles ^self resolve hasFiles! ! !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: 'testing' stamp: 'PavelKrivanek 11/23/2012 12:21'! isAbsolute self subclassResponsibility ! ! !AbstractFileReference methodsFor: 'testing' stamp: 'CamilloBruni 7/10/2012 20:17'! isChildOf: anObject ^ self parent = anObject! ! !AbstractFileReference methodsFor: 'testing' stamp: 'CamilloBruni 7/10/2012 15:04'! isDirectory ^ self resolve isDirectory! ! !AbstractFileReference methodsFor: 'testing' stamp: 'CamilloBruni 7/10/2012 15:04'! isFile ^ self resolve isFile! ! !AbstractFileReference methodsFor: 'testing' stamp: 'CamilloBruni 7/10/2012 15:04'! isReadable ^ self resolve isReadable! ! !AbstractFileReference methodsFor: 'testing' stamp: 'PavelKrivanek 11/23/2012 12:21'! isRelative self subclassResponsibility ! ! !AbstractFileReference methodsFor: 'testing' stamp: 'CamilloBruni 7/10/2012 15:04'! isRoot ^ self resolve isRoot! ! !AbstractFileReference methodsFor: 'testing' stamp: 'CamilloBruni 7/10/2012 20:19'! isWritable ^ self resolve isWritable! ! !AbstractFileReference methodsFor: 'utility' stamp: 'CamilloBruni 7/10/2012 15:04'! nextVersion ^ self resolve nextVersion! ! !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! ! Object subclass: #AbstractFont instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Fonts'! !AbstractFont commentStamp: '' prior: 0! AbstractFont defines the generic interface that all fonts need to implement.! !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 7/29/2006 13:51'! displayUnderlineOn: aDisplayContext from: baselineStartPoint to: baselineEndPoint "display the underline if appropriate for the receiver"! ! !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: '*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: '*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: '*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: '*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: '*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: '*FreeType-addition' stamp: 'tween 3/10/2007 13:08'! kerningLeft: leftChar right: rightChar ^0! ! !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 4/3/2007 16:47'! widthAndKernedWidthOfLeft: leftCharacter right: rightCharacterOrNil into: aTwoElementArray "Set the first element of aTwoElementArray to the width of leftCharacter and the second element to the width of left character when kerned with rightCharacterOrNil. Answer aTwoElementArray" | w k | w := self widthOf: leftCharacter. rightCharacterOrNil isNil ifTrue:[ aTwoElementArray at: 1 put: w; at: 2 put: w] ifFalse:[ k := self kerningLeft: leftCharacter right: rightCharacterOrNil. aTwoElementArray at: 1 put: w; at: 2 put: w+k]. ^aTwoElementArray ! ! !AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:19'! ascent self subclassResponsibility. ! ! !AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:18'! ascentOf: aCharacter ^ self ascent. ! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 4/2/2004 11:06'! baseKern ^0! ! !AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:18'! basicAscentOf: aCharacter ^ self ascent. ! ! !AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:19'! basicDescentOf: aCharacter ^ self descent. ! ! !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: 'accessing' stamp: 'nk 3/15/2004 18:57'! derivativeFonts ^#()! ! !AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:20'! descent self subclassResponsibility. ! ! !AbstractFont methodsFor: 'accessing' stamp: 'yo 1/7/2005 11:20'! descentOf: aCharacter ^ self descent. ! ! !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: '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: 'accessing' stamp: 'nk 5/26/2003 09:45'! isRegular ^false! ! !AbstractFont methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:14'! lineGrid "Answer the relative space between lines" ^self subclassResponsibility! ! !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: 'accessing' stamp: 'nk 4/1/2004 10:48'! pointSize 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: '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: '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: 'caching' stamp: 'nk 3/15/2004 18:47'! releaseCachedState ! ! !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: '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: '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: '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: 'measuring' stamp: 'ar 5/19/2000 14:58'! widthOf: aCharacter "Return the width of the given character" ^self subclassResponsibility! ! !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: '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: '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: 'notifications' stamp: 'nk 4/2/2004 11:25'! pixelsPerInchChanged "The definition of TextStyle class>>pixelsPerInch has changed. Do whatever is necessary."! ! !AbstractFont methodsFor: 'testing' stamp: 'yo 2/12/2007 19:34'! isFontSet ^ false. ! ! !AbstractFont methodsFor: 'testing' stamp: 'nk 6/25/2003 12:54'! isTTCFont ^false! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbstractFont class instanceVariableNames: ''! !AbstractFont class methodsFor: '*system-settings-browser' stamp: 'alain.plantec 3/18/2009 14:49'! settingInputWidgetForNode: aSettingNode ^ aSettingNode inputWidgetForFont! ! !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 ]].! ! DialogWindow subclass: #AbstractFontSelectorDialogWindow instanceVariableNames: 'fontFamilies selectedFont textPreviewMorph fontFamilyIndex fontSizeIndex isBold isItalic isUnderlined isStruckOut previewText' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Windows'! !AbstractFontSelectorDialogWindow commentStamp: 'gvc 5/18/2007 13:04' prior: 0! Dialog based font chooser with preview.! !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: '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 14:30'! fontFamilyIndex "Answer the value of fontFamilyIndex" ^ fontFamilyIndex! ! !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 14:30'! fontSizeIndex "Answer the value of fontSizeIndex" ^ fontSizeIndex! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:19'! fontSizeIndex: anObject "Set the value of fontSizeIndex" fontSizeIndex := anObject. self updateSelectedFont! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:12'! isBold "Answer the value of isBold" ^ isBold! ! !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 5/3/2007 15:12'! isItalic "Answer the value of isItalic" ^ isItalic! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 4/21/2009 17:07'! isItalic: anObject "Set the value of isItalic" isItalic := anObject. self changed: #isItalic! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:12'! isStruckOut "Answer the value of isStruckOut" ^ isStruckOut! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 4/21/2009 17:07'! isStruckOut: anObject "Set the value of isStruckOut" isStruckOut := anObject. self changed: #isStruckOut! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 15:12'! isUnderlined "Answer the value of isUnderlined" ^ isUnderlined! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 4/21/2009 17:07'! isUnderlined: anObject "Set the value of isUnderlined" isUnderlined := anObject. self changed: #isUnderlined! ! !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/18/2007 13:07'! previewText: anObject "Set the value of previewText" previewText := anObject. self changed: #previewText! ! !AbstractFontSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 5/3/2007 13:41'! selectedFont "Answer the value of selectedFont" ^ selectedFont! ! !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 13:41'! textPreviewMorph "Answer the value of textPreviewMorph" ^ textPreviewMorph! ! !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 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: '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: '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: '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: '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: 'as yet unclassified' 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: '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:02'! newBoldButtonMorph "Answer a button for the boldness of the font." ^self newButtonFor: self getState: #isBold action: #toggleBold arguments: nil getEnabled: nil labelForm: self theme smallBoldIcon help: 'Toggle bold font' translated! ! !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: '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 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: '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: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:02'! newItalicButtonMorph "Answer a button for the italic emphasis of the font." ^self newButtonFor: self getState: #isItalic action: #toggleItalic arguments: nil getEnabled: nil labelForm: self theme smallItalicIcon help: 'Toggle italic font' translated! ! !AbstractFontSelectorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:02'! newStruckOutButtonMorph "Answer a button for the struck out emphasis of the font." ^self newButtonFor: self getState: #isStruckOut action: #toggleStruckOut arguments: nil getEnabled: nil labelForm: self theme smallStrikeOutIcon help: 'Toggle struck-out font' translated! ! !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: 'as yet unclassified' stamp: 'gvc 4/21/2009 17:02'! newUnderlinedButtonMorph "Answer a button for the italic emphasis of the font." ^self newButtonFor: self getState: #isUnderlined action: #toggleUnderlined arguments: nil getEnabled: nil labelForm: self theme smallUnderlineIcon help: 'Toggle underlined font' translated! ! !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 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:31'! toggleItalic "Toggle the font italic emphasis." self isItalic: self isItalic not. self updateSelectedFont! ! !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 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 4/21/2009 17:21'! updateFromSelectedFont "Update our state based on the selected font." self subclassResponsibility! ! !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 class instanceVariableNames: ''! !AbstractFontSelectorDialogWindow class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'AlainPlantec 10/19/2010 20:22'! taskbarIcon "Answer the icon for the receiver in a task bar." ^self theme smallFontsIcon! ! Object subclass: #AbstractGroup instanceVariableNames: 'name readOnly removable sortBlock isFillable' classVariableNames: '' poolDictionaries: '' category: 'GroupManager'! !AbstractGroup commentStamp: '' prior: 0! AbstractGroup is an abstraction of what a group is.! !AbstractGroup methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/2/2012 17:14'! isFillable ^ isFillable ifNil: [ isFillable := false ]! ! !AbstractGroup methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/2/2012 17:07'! isFillable: aBoolean isFillable := aBoolean! ! !AbstractGroup methodsFor: 'announcements' stamp: 'BenjaminVanRyseghem 4/14/2012 12:22'! classRemoved: anAnnouncement self subclassResponsibility! ! !AbstractGroup methodsFor: 'announcements' stamp: 'BenjaminVanRyseghem 4/14/2012 12:22'! methodModified: anAnnouncement self subclassResponsibility! ! !AbstractGroup methodsFor: 'announcements' stamp: 'BenjaminVanRyseghem 4/14/2012 12:22'! methodRemoved: anAnnouncement self subclassResponsibility! ! !AbstractGroup methodsFor: 'announcements registration' stamp: 'BenjaminVanRyseghem 4/14/2012 12:38'! registerToAnnouncements self registerToClassAnnouncements; registerToMethodAnnouncements! ! !AbstractGroup methodsFor: 'announcements registration' stamp: 'EstebanLorenzano 8/3/2012 13:57'! registerToClassAnnouncements SystemAnnouncer uniqueInstance weak on: ClassRemoved send: #classRemoved: to: self! ! !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: 'polymorphism' stamp: 'BenjaminVanRyseghem 3/28/2011 13:50'! blocks ^ { [ self elements ] }! ! !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: 'protocol' stamp: 'BenjaminVanRyseghem 3/18/2011 14:00'! beReadOnly readOnly := true! ! !AbstractGroup methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/18/2011 14:22'! elements ^ self subclassResponsibility! ! !AbstractGroup methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/14/2011 21:55'! isReadOnly ^ readOnly == true! ! !AbstractGroup methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/18/2011 14:03'! name ^ name! ! !AbstractGroup methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/18/2011 14:04'! name: aString self ifAllowed: [ name := aString ]! ! !AbstractGroup methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/24/2011 13:41'! removable ^ removable ifNil: [ removable := true ]! ! !AbstractGroup methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/24/2011 13:39'! removable: aBoolean removable := aBoolean! ! !AbstractGroup methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/21/2011 15:32'! unregister GroupsManager unregister: self! ! !AbstractGroup methodsFor: 'queries' stamp: 'BenjaminVanRyseghem 2/25/2012 15:28'! classes ^ self subclassResponsibility! ! !AbstractGroup methodsFor: 'queries' stamp: 'BenjaminVanRyseghem 2/25/2012 15:26'! methods ^ self elements! ! !AbstractGroup methodsFor: 'queries' stamp: 'BenjaminVanRyseghem 2/25/2012 15:38'! methodsFor: aClass ^ self methods select: [:e | e methodClass = aClass ].! ! !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: 'queries' stamp: 'BenjaminVanRyseghem 2/25/2012 15:32'! protocolsFor: aClass ^ aClass protocols select: [:e | self methods anySatisfy: [:m | m category = e ]].! ! !AbstractGroup methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/18/2011 16:57'! ifAllowed: aBlock ^ self ifAllowed: aBlock ifNot: []! ! !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 4/14/2012 12:17'! initialize super initialize. readOnly := false. self registerToAnnouncements.! ! !AbstractGroup methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/24/2011 13:20'! sortBlock ^ sortBlock ifNil: [ sortBlock := [:a :b | a printString <= b printString ]]! ! !AbstractGroup methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/24/2011 13:16'! sortBlock: aBlock sortBlock := aBlock! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbstractGroup class instanceVariableNames: ''! !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! ! Announcement subclass: #AbstractGroupAnnouncement instanceVariableNames: 'group holder' classVariableNames: '' poolDictionaries: '' category: 'GroupManager-Announcements'! !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 ^ holder! ! !AbstractGroupAnnouncement methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/14/2011 16:31'! holder: anObject holder := anObject! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbstractGroupAnnouncement class instanceVariableNames: ''! !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! ! Object subclass: #AbstractInstructionTests instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CompilerTests'! !AbstractInstructionTests commentStamp: 'BenjaminVanRyseghem 9/27/2011 14:04' prior: 0! Use for a test: ClosureCompilerTest>>#closureCases! !AbstractInstructionTests methodsFor: 'for test' stamp: 'BenjaminVanRyseghem 9/27/2011 14:07'! runBinaryConditionalJumps: anObject! ! AbstractNautilusPlugin subclass: #AbstractKeyPressedPlugin instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Plugin'! !AbstractKeyPressedPlugin commentStamp: '' prior: 0! 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! ! TestCase subclass: #AbstractKeymappingTest instanceVariableNames: 'default' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Tests'! !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 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 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 ! ! !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:52'! eventKey: character shift: aBoolean ^ self eventKey: character alt: false ctrl: false command: false shift: aBoolean! ! !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 2/19/2011 18:44'! tearDown KMRepository default: default! ! Object subclass: #AbstractMethodConverter instanceVariableNames: 'shouldShout method' classVariableNames: '' poolDictionaries: '' category: 'Tools-MethodConverters'! !AbstractMethodConverter commentStamp: '' prior: 0! 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'! method ^ method! ! !AbstractMethodConverter methodsFor: 'accessing'! method: aMessage method := aMessage! ! !AbstractMethodConverter methodsFor: 'initialization'! canCompile ^ false! ! !AbstractMethodConverter methodsFor: 'initialization'! handleStringSearch ^ true! ! !AbstractMethodConverter methodsFor: 'initialization'! shouldShout ^ false! ! !AbstractMethodConverter methodsFor: 'protocol'! getText method ifNil: [ ^ '' ]. ^ self internalGetText! ! !AbstractMethodConverter methodsFor: 'protocol'! getTextFor: aMethod method := aMethod. method ifNil: [ ^ '' ]. ^ self internalGetText! ! !AbstractMethodConverter methodsFor: 'private'! internalGetText ^ self subclassResponsibility! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbstractMethodConverter class instanceVariableNames: ''! !AbstractMethodConverter class methodsFor: 'instance creation'! method: aMessage ^ self new method: aMessage; yourself! ! Object subclass: #AbstractMethodIconAction instanceVariableNames: 'method browser icon' classVariableNames: '' poolDictionaries: '' category: 'Nautilus-Widgets'! !AbstractMethodIconAction commentStamp: '' prior: 0! 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: 'accessing' stamp: 'BenjaminVanRyseghem 1/2/2013 12:33'! browser ^ browser! ! !AbstractMethodIconAction methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/2/2013 12:33'! browser: aBrowser browser := aBrowser! ! !AbstractMethodIconAction methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/2/2013 12:34'! method ^ method! ! !AbstractMethodIconAction methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/2/2013 12:16'! method: aMethod method := aMethod! ! !AbstractMethodIconAction methodsFor: 'icon' stamp: 'BenjaminVanRyseghem 1/2/2013 12:18'! iconClass ^ NautilusIcons! ! !AbstractMethodIconAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 1/2/2013 12:50'! actionIcon "Return the icon for this action" ^ icon := self privateActionIcon! ! !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:53'! actionStateToCache "Return the state of the icon for caching purpose" ^ IconicButtonStateHolder forNautilus: icon! ! !AbstractMethodIconAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 1/2/2013 12:41'! isActionHandled "Return true if the provided method fits this action requirement" ^ self subclassResponsibility! ! !AbstractMethodIconAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 1/2/2013 12:50'! privateActionIcon ^ self subclassResponsibility! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbstractMethodIconAction class instanceVariableNames: ''! !AbstractMethodIconAction class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 1/2/2013 12:34'! for: aMethod in: aBrowser ^ self new method: aMethod; browser: aBrowser; yourself! ! AbstractMethodConverter subclass: #AbstractMethodReferenceConverter instanceVariableNames: 'referencesList' classVariableNames: '' poolDictionaries: '' category: 'RecentSubmissions-MessageWrappers'! !AbstractMethodReferenceConverter methodsFor: 'accessing'! referencesList: aListOfReferences referencesList := aListOfReferences! ! !AbstractMethodReferenceConverter methodsFor: 'initialization'! initialize "Initialization code for VersionMessageConverter" super initialize. referencesList := #()! ! !AbstractMethodReferenceConverter methodsFor: 'private'! 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: 'private'! 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 instanceVariableNames: ''! !AbstractMethodReferenceConverter class methodsFor: 'as yet unclassified'! methodReference: aMessage referencesList: aListOfReferences ^ (super method: aMessage) referencesList: aListOfReferences; yourself! ! AbstractWidget subclass: #AbstractMethodWidget instanceVariableNames: '' classVariableNames: 'MethodsIconsCache' poolDictionaries: '' category: 'Nautilus-Widgets'! !AbstractMethodWidget commentStamp: '' prior: 0! AbstractMethodWidget is an abstraction describing a widget used to manage methods! !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: 'icon'! 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: (self iconClass iconNamed: #arrowDoubleUp); color: Color transparent; extent: 12 @ 6; helpText: 'Browse overriden message'; borderWidth: 0. down := IconicButton new target: self model; actionSelector: #arrowDown:; arguments: { aMethod }; labelGraphic: (self iconClass iconNamed: #arrowDoubleDown); 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: 'icon' stamp: 'BenjaminVanRyseghem 1/2/2013 13:10'! methodIconFor: aMethod | actions result button action | button := nil. MethodsIconsCache at: aMethod ifPresent: [:icon | icon isArray ifTrue: [ ^ self rebuildUpAndDownArrowIconFrom: icon]. icon class == IconicButtonStateHolder ifFalse: [ ^ icon ]. ^ icon asIconTargetting: self model ]. 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: 'icon'! methodsIconsCache ^ MethodsIconsCache! ! !AbstractMethodWidget methodsFor: 'icon'! 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 methodsFor: 'icon'! 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: 'initialize-release'! initialize super initialize. MethodsIconsCache ifNil: [ MethodsIconsCache := WeakIdentityKeyDictionary new ]! ! !AbstractMethodWidget methodsFor: 'items creation'! buildMethodsList ^ self subclassResponsibility! ! !AbstractMethodWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/14/2012 11:56'! deselectMethod: aMethod self subclassResponsibility! ! !AbstractMethodWidget methodsFor: 'protocol'! elementsMenu: aMenuMorph shifted: aBoolean ^ self model elementsMenu: aMenuMorph shifted: aBoolean ! ! !AbstractMethodWidget methodsFor: 'protocol'! getMethods ^ self model getMethods! ! !AbstractMethodWidget methodsFor: 'protocol'! keyPressedOnElement: anEvent ^ self subclassResponsibility! ! !AbstractMethodWidget methodsFor: 'protocol'! label: aString ^ self subclassResponsibility! ! !AbstractMethodWidget methodsFor: 'protocol'! methodsSelection ^ self subclassResponsibility! ! !AbstractMethodWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/17/2012 17:13'! okToChange ^ self model okToChange. ! ! !AbstractMethodWidget methodsFor: 'protocol'! removeAllFromMethodsIconsCache: aMethod ^ self subclassResponsibility! ! !AbstractMethodWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/14/2012 11:57'! selectMethod: aMethod self subclassResponsibility! ! !AbstractMethodWidget methodsFor: 'protocol'! selectedMethod ^ self model selectedMethod! ! !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'! selectedMethods ^ self subclassResponsibility! ! !AbstractMethodWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/4/2012 16:05'! setIcon: icon for: method MethodsIconsCache at: method put: icon! ! !AbstractMethodWidget methodsFor: 'protocol'! showInstance ^ self model showInstance! ! !AbstractMethodWidget methodsFor: 'protocol'! takeKeyboardFocus ^ self subclassResponsibility! ! !AbstractMethodWidget methodsFor: 'protocol'! vScrollValue ^ self subclassResponsibility! ! !AbstractMethodWidget methodsFor: 'protocol'! vScrollValue: aNumber ^ self subclassResponsibility! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbstractMethodWidget class instanceVariableNames: ''! !AbstractMethodWidget class methodsFor: 'icon'! resetMethodsIconsCache MethodsIconsCache removeAll! ! Object subclass: #AbstractNautilusPlugin instanceVariableNames: 'model position' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Plugin'! !AbstractNautilusPlugin commentStamp: '' prior: 0! AbstractNautilusPlugin is an abstraction of what a plugin for Nautilus is. Mainly, it defines the protocol! !AbstractNautilusPlugin methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/4/2011 14:43'! model ^ model! ! !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 methodsFor: 'display' stamp: 'BenjaminVanRyseghem 5/2/2012 13:18'! name ^ self class name! ! !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: 'registration' stamp: 'BenjaminVanRyseghem 5/4/2011 14:45'! registerTo: aModel self subclassResponsibility! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbstractNautilusPlugin class instanceVariableNames: ''! !AbstractNautilusPlugin class methodsFor: 'display' stamp: 'BenjaminVanRyseghem 8/25/2011 14:18'! pluginName ^ self name! ! !AbstractNautilusPlugin class methodsFor: 'information' stamp: 'BenjaminVanRyseghem 2/17/2012 16:26'! description ^ 'No description available'! ! !AbstractNautilusPlugin class methodsFor: 'information' stamp: 'BenjaminVanRyseghem 8/25/2011 09:39'! possiblePositions ^ { #top. #middle. #bottom. #none. }! ! !AbstractNautilusPlugin class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 5/4/2011 14:43'! model: aModel ^ self new model: aModel! ! !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! ! AbstractTool subclass: #AbstractNautilusUI instanceVariableNames: 'model window hierarchyClass cachedHierarchy sourceTextArea firstColumn secondColumn groupsSelection packagesSelection classesSelection list list2 sourceCodePanel commentTextArea currentDisplayChoice sourceTextAreaLimit sourceCodeContainer list2Elements listElements shouldUpdateTitle testSemaphore sourceTextAreas multipleMethodsEditor contentSelection' classVariableNames: 'ClassesIconsCache GroupsIconsCache Icon NextFocusKey PackagesIconsCache PreviousFocusKey' poolDictionaries: '' category: 'Nautilus'! !AbstractNautilusUI commentStamp: '' prior: 0! 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: 'NOCompletion' stamp: 'BenjaminVanRyseghem 4/18/2012 13:16'! guessTypeForName: aString ^ nil! ! !AbstractNautilusUI methodsFor: 'NOCompletion' stamp: 'BenjaminVanRyseghem 4/18/2012 13:16'! receiverClass ^ self selectedClass! ! !AbstractNautilusUI methodsFor: 'NOCompletion' stamp: 'BenjaminVanRyseghem 4/18/2012 13:16'! selectedClassOrMetaClass ^ self selectedClass! ! !AbstractNautilusUI methodsFor: 'Shout'! shoutAboutToStyle: aPluggableShoutMorphOrView ^ aPluggableShoutMorphOrView == sourceTextArea! ! !AbstractNautilusUI methodsFor: 'SmalltalkEditor compatibility'! selectedBehavior ^ self selectedClass! ! !AbstractNautilusUI methodsFor: 'accessing'! currentDisplayChoice ^ currentDisplayChoice ifNil: [ currentDisplayChoice := self sourceCodeSymbol ]! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/3/2012 18:07'! currentDisplayChoice: aSymbol currentDisplayChoice := aSymbol. self changed: #showSource. self changed: #showByteCode. self changed: #showDecompile. self changed: #sourceCodeFrom:. self announce: (NautilusTextDisplayerChanged displayerSymbol: aSymbol)! ! !AbstractNautilusUI methodsFor: 'accessing'! groupsManager ^ self model groupsManager! ! !AbstractNautilusUI methodsFor: 'accessing'! hierarchyClass ^ hierarchyClass! ! !AbstractNautilusUI methodsFor: 'accessing'! hierarchyClass: aClass hierarchyClass := aClass. self setCachedHierarchyClass: aClass! ! !AbstractNautilusUI methodsFor: 'accessing'! model ^ model! ! !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: 'accessing' stamp: 'BenjaminVanRyseghem 3/23/2012 19:59'! selected | item | item := self ifGroups: [ self selectedGroup ] ifNot: [ self selectedPackage ]. ^self getList indexOf: item.! ! !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: 'accessing' stamp: 'CamilloBruni 10/4/2012 10:50'! selected2: anInteger | selection | selection := self getList2 at: anInteger ifAbsent: [nil]. self showInstance ifFalse: [selection ifNotNil: [selection := selection theMetaClass]]. self selectedClassWithoutChangingSelection: selection. self changed: #selected2. self changed: #currentHistoryIndex.! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'CamilloBruni 10/4/2012 10:50'! selected: anInteger | selection | list2Elements := nil. selection := self getList at: anInteger ifAbsent: [nil]. self ifGroups: [ self selectedGroupWithoutChangingSelection: selection ] ifNot: [ self selectedPackageWithoutChangingSelection: selection ]. self changed: #selected. self changed: #currentHistoryIndex.! ! !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: '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: 'accessing'! selectedClassWithoutChangingSelection: aClass ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'accessing'! selectedGroup ^ self model selectedGroup! ! !AbstractNautilusUI methodsFor: 'accessing'! selectedGroup: anObject self okToChange ifTrue: [ groupsSelection removeAll. anObject ifNotNil: [ self giveFocusTo: list ]. groupsSelection at: anObject put: true. self selectedGroupWithoutChangingSelection: anObject ]! ! !AbstractNautilusUI methodsFor: 'accessing'! selectedGroupWithoutChangingSelection: anObject self okToChange ifTrue: [ anObject ifNil: [ groupsSelection removeAll ]. self model selectedGroup: anObject. groupsSelection at: anObject put: true. self selectedClass: nil. self updateClassView ]! ! !AbstractNautilusUI methodsFor: 'accessing'! selectedPackage ^ self model selectedPackage! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/23/2012 20:01'! selectedPackage: aPackage " Force package selection, not used by the lists " self okToChange ifTrue: [ packagesSelection removeAll. packagesSelection at: aPackage put: true. aPackage ifNotNil: [ self giveFocusTo: list ]. self selectedPackageWithoutChangingSelection: aPackage]! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/3/2012 18:07'! selectedPackageWithoutChangingSelection: aPackage self okToChange ifTrue: [| class | class := self selectedClass. (self showPackages and: [class notNil and: [class package ~= aPackage]]) ifTrue: [ self selectedClass: nil ]. self model package: aPackage class: self selectedClass category: nil method: nil. packagesSelection at: aPackage put: true. self updateClassView. self update. self changed: #getComments. self changed: #sourceCodeFrom:]! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/3/2012 18:07'! selectedPackageWithoutChangingSelectionInternally: aPackage self okToChange ifTrue: [| 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: 'accessing'! showComment ^ self model showComment! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/3/2012 18:48'! showComment: aBoolean self okToChangeComment ifFalse: [ ^ self ]. self model showComment: aBoolean. self updateCodePanel! ! !AbstractNautilusUI methodsFor: 'accessing'! showGroups ^ self model showGroups! ! !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: 'accessing'! showGroupsSilently: aBoolean self model showGroups: aBoolean! ! !AbstractNautilusUI methodsFor: 'accessing'! showHierarchy ^ self model showHierarchy! ! !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: 'accessing'! showInstance ^ self model showInstance! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/5/2013 14:27'! showInstance: aBoolean self okToChange ifTrue:[ self model showInstance: aBoolean. classesSelection removeAll. self selectedClass ifNotNil: [:class | aBoolean ifTrue: [self selectedClass: class theNonMetaClass ] ifFalse: [self selectedClass: class theMetaClass ]]. self update. self changed: #instanceButtonState. self changed: #instanceButtonLabel ]! ! !AbstractNautilusUI methodsFor: 'accessing'! showPackages ^ self model showPackages! ! !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: 'accessing'! showPackagesSilently: aBoolean self model showPackages: aBoolean.! ! !AbstractNautilusUI methodsFor: 'accessing'! sourceCodeContainer ^ sourceCodeContainer! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/14/2012 17:33'! sourceCodePanel ^ sourceCodePanel! ! !AbstractNautilusUI methodsFor: 'accessing'! sourceTextArea ^ sourceTextArea! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/1/2012 19:46'! toggleShowComment self showComment: self showComment not. self changed: #commentButtonState! ! !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'! toggleShowGroups self showGroups: self showGroups not.! ! !AbstractNautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/22/2012 16:42'! toggleShowHierarchy self showHierarchy: self showHierarchy not. ! ! !AbstractNautilusUI methodsFor: 'accessing'! toggleShowInstance ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'accessing'! toggleShowPackages self showPackages: self showPackages not.! ! !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: 'accessing'! window ^ window! ! !AbstractNautilusUI methodsFor: 'accessing'! window: anObject window := anObject! ! !AbstractNautilusUI methodsFor: 'annotation pane'! annotationSeparator "Answer the separator to be used between annotations" ^ ' · '! ! !AbstractNautilusUI methodsFor: 'annotation pane'! defaultAnnotationInfo "see annotationRequests comment" ^ #(timeStamp messageCategory sendersCount implementorsCount allChangeSets)! ! !AbstractNautilusUI methodsFor: 'announcement registration'! announce: anAnnouncement ^ self model announce: anAnnouncement! ! !AbstractNautilusUI methodsFor: 'announcement registration'! announcer ^ self model announcer! ! !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: '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: '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: 'announcement registration' stamp: 'BenjaminVanRyseghem 12/20/2012 15:05'! 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: #classRecategorized: to: self; on: ProtocolRemoved send: #classRecategorized: to: self. ! ! !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: 'announcement registration'! unregisterAPlugin: aPlugin self announcer unsubscribe: aPlugin! ! !AbstractNautilusUI methodsFor: 'announcement registration'! unregisterAllPlugins self announcer subscriptions reset! ! !AbstractNautilusUI methodsFor: 'browser compatibility'! codeTextMorph ^ sourceTextArea! ! !AbstractNautilusUI methodsFor: 'browser compatibility'! sourceCode: aText self okToChange ifTrue: [ sourceTextArea setText: aText. sourceTextArea takeKeyboardFocus ]! ! !AbstractNautilusUI methodsFor: 'buttons behavior'! commentButtonAction self toggleShowComment.! ! !AbstractNautilusUI methodsFor: 'buttons behavior'! commentButtonLabel ^ self commentLabel! ! !AbstractNautilusUI methodsFor: 'buttons behavior'! commentButtonState ^ self showComment! ! !AbstractNautilusUI methodsFor: 'buttons behavior'! groupsButtonAction self toggleShowGroups! ! !AbstractNautilusUI methodsFor: 'buttons behavior'! groupsButtonLabel ^ self showGroups ifTrue: [ self packageLabel ] ifFalse: [ self groupsLabel ]! ! !AbstractNautilusUI methodsFor: 'buttons behavior'! groupsButtonState ^ false! ! !AbstractNautilusUI methodsFor: 'buttons behavior'! instanceButtonAction self toggleShowInstance! ! !AbstractNautilusUI methodsFor: 'buttons behavior' stamp: 'EstebanLorenzano 1/25/2013 18:22'! instanceButtonLabel | hasMethods label | hasMethods := false. self selectedClass ifNotNil: [:class | hasMethods := class theMetaClass methodDict notEmpty ]. label := 'Class side' asMorph. hasMethods ifTrue: [ label emphasis: 1 ] ifFalse: [ label emphasis: 2 ]. ^ label! ! !AbstractNautilusUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 12/20/2012 12:40'! instanceButtonState ^ "false" self showInstance not! ! !AbstractNautilusUI methodsFor: 'buttons behavior'! showDecompile ^ self currentDisplayChoice = self decompileSymbol! ! !AbstractNautilusUI methodsFor: 'buttons behavior'! switchToByteCodeButton self okToChange ifTrue: [ self currentDisplayChoice: self byteCodeSymbol ]! ! !AbstractNautilusUI methodsFor: 'buttons behavior'! switchToDecompileButton self okToChange ifTrue: [ self currentDisplayChoice: self decompileSymbol ]! ! !AbstractNautilusUI methodsFor: 'buttons behavior'! switchToSourceCodeButton self okToChange ifTrue: [ self currentDisplayChoice: self sourceCodeSymbol ]! ! !AbstractNautilusUI methodsFor: 'buttons behavior'! toggleButtonAction self toggleButtonEnabled ifTrue: [ self toggleShowPackages. self changed: #toggleButtonEnabled. ]! ! !AbstractNautilusUI methodsFor: 'buttons behavior'! toggleButtonEnabled ^ (self selectedClass ~~ nil or: [ self showPackages not ])! ! !AbstractNautilusUI methodsFor: 'buttons behavior'! toggleButtonLabel ^ self showPackages ifTrue: [ 'Hierarchy' ] ifFalse: [ 'Flat' ]! ! !AbstractNautilusUI methodsFor: 'buttons behavior'! toggleButtonState ^ self showPackages not! ! !AbstractNautilusUI methodsFor: 'code panel'! 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: '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: '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: 'code panel' stamp: 'StephaneDucasse 12/19/2012 15:53'! buildCodePanelWithCommentOnRight | splitter delta | splitter := ProportionalSplitterMorph new. delta := 2. splitter addLeftOrTop: multipleMethodsEditor. splitter addRightOrBottom: commentTextArea. sourceCodePanel addMorph: multipleMethodsEditor 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: commentTextArea fullFrame: ( (0.5@0 corner: 1@1) asLayoutFrame topLeftOffset: delta@0 ; bottomRightOffset: 0@0).! ! !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: 'code panel' stamp: 'StephaneDucasse 12/19/2012 15:56'! buildCodePanelWithoutComment sourceCodePanel addMorph: multipleMethodsEditor fullFrame: LayoutFrame identity! ! !AbstractNautilusUI methodsFor: 'dispatch' stamp: 'CamilloBruni 10/7/2012 23:27'! basicRenameClass: aClass self renameClass: aClass! ! !AbstractNautilusUI methodsFor: 'displaying'! addAll: aWindow self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'displaying' stamp: 'EstebanLorenzano 2/6/2013 17:34'! buildFirstColumn: aWindow | buttons | buttons := PanelMorph new. self setShortcuts: #NautilusPackageShortcuts to: buttons. buttons changeProportionalLayout; addMorph: self buildGroupsButton fullFrame: ( ( 0@0 corner: 0.5@0 ) asLayoutFrame bottomRightOffset: (-2)@25 ); addMorph: self buildToggleButton fullFrame: (( 0.5@0 corner: 1@0 ) asLayoutFrame topLeftOffset: 2@0 ; bottomRightOffset: 0@25 ); hResizing: #spaceFill; vResizing: #rigid; height: 25; yourself. ^ firstColumn := PanelMorph new changeProportionalLayout; addMorph: self buildList fullFrame: ( LayoutFrame identity bottomOffset: -25); addMorph: buttons fullFrame: ( (0@1 corner: 1@1 ) asLayoutFrame topOffset: -25); hResizing: #spaceFill; vResizing: #spaceFill; yourself.! ! !AbstractNautilusUI methodsFor: 'displaying' stamp: 'StephaneDucasse 12/19/2012 16:04'! 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; yourself. ^ secondColumn := PanelMorph new changeProportionalLayout; addMorph: self buildList2 fullFrame: (LayoutFrame identity bottomOffset: -25); addMorph: buttons fullFrame: ( (0@1 corner: 1@1 ) asLayoutFrame topOffset: -25); hResizing: #spaceFill; vResizing: #spaceFill; yourself.! ! !AbstractNautilusUI methodsFor: 'displaying'! buildTextAreaButtonsColumn: aWindow | column | column := PanelMorph new. column changeTableLayout; listDirection: #topToBottom. { self buildSwitchToSourceCodeButton. self buildSwitchToByteCodeButton. self buildSwitchToDecompileButton. self buildSeparator. self buildBrowseInstVarsButton. self buildBrowseClassVarsButton} reverse do: [:each | column addMorph: each ]. column vResizing: #spaceFill; width: 24; hResizing: #rigid. ^ column! ! !AbstractNautilusUI methodsFor: 'displaying' stamp: 'CamilloBruni 9/21/2012 13:47'! close window close! ! !AbstractNautilusUI methodsFor: 'displaying'! newGroupBoxMorph | morph | morph := GroupboxMorph new. morph contentMorph layoutInset: (0@0 corner: 0@0); cellInset: 0. ^ morph! ! !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: '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: 'displaying'! taskbarIcon ^ self class icon! ! !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: 'drag and drop' stamp: 'BenjaminVanRyseghem 5/9/2012 11:28'! dragTransferTypeForMorph: dragSource ^(dragSource isKindOf: PluggableListMorph) ifTrue: [ dragSource getListElementSelector ]! ! !AbstractNautilusUI methodsFor: 'drag and drop'! 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: 'drag and drop' stamp: 'BenjaminVanRyseghem 7/13/2012 14:38'! dropInAPackage: aCollection into: receiver aCollection do:[:aClass | self showGroups ifTrue: [ receiver addClasses: { aClass }. ActiveHand shiftPressed ifFalse: [ self selectedGroup removeClass: aClass. self updateClassView ]] ifFalse: [ aClass theNonMetaClass category: receiver name. ActiveHand shiftPressed ifTrue: [ self selectedClass: nil. self updateClassView ] ifFalse:[ self selectedPackage: receiver. self selectedClass: aClass. self updateBothView ]]]! ! !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: 'drag and drop' stamp: 'BenjaminVanRyseghem 3/23/2012 19:55'! dropInList: aCollection inARow: aRow | receiver | (aRow = 0) ifTrue: [ ^ self ]. receiver := self getList at: aRow. ( receiver isKindOf: Class ) ifTrue: [ self selectedClass isMeta ifTrue: [ receiver := receiver theMetaClass ] ifFalse: [ receiver := receiver theNonMetaClass ]]. self dropInAPackage: aCollection into: receiver! ! !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: 'events handling' stamp: 'BenjaminVanRyseghem 3/23/2012 19:20'! doubleClick self ifGroups: [ self doubleClickOnGroup ] ifNot: [ self doubleClickOnPackage ]! ! !AbstractNautilusUI methodsFor: 'events handling' stamp: 'BenjaminVanRyseghem 3/23/2012 19:21'! doubleClick2 self doubleClickOnClass! ! !AbstractNautilusUI methodsFor: 'events handling'! 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: 'events handling'! doubleClickOnGroup self selectedGroup ifNil: [ ^self ] ifNotNil:[:group | self model class openOnGroup: group ]! ! !AbstractNautilusUI methodsFor: 'events handling'! doubleClickOnPackage self selectedPackage ifNil: [ ^ self ] ifNotNil:[:package | self model class openOnPackage: package ]! ! !AbstractNautilusUI methodsFor: 'events handling'! keyPressedOnElement: anEvent ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'events handling' stamp: 'BenjaminVanRyseghem 2/26/2013 18:59'! listMouseDown: anEvent self showPackages ifFalse: [ self showPackages: true. list mouseDown: anEvent ]. ! ! !AbstractNautilusUI methodsFor: 'focus' stamp: 'BenjaminVanRyseghem 6/22/2012 17:57'! giveFocusToPackage self giveFocusTo: list! ! !AbstractNautilusUI methodsFor: 'focus' stamp: 'BenjaminVanRyseghem 6/22/2012 18:01'! giveFocusToSourceCode self giveFocusTo: sourceTextArea ! ! !AbstractNautilusUI methodsFor: 'group'! addClassesInGroup self selectedClasses ifNotNil: [:classes | self addClassesInGroup: classes ].! ! !AbstractNautilusUI methodsFor: 'group'! addClassesInGroup: aCollection (DialogGroupAdder new groups: self groupsManager; elementsToAdd: ((aCollection collect: #theNonMetaClass) asSet asArray sort: [:a :b | a name < b name])) open! ! !AbstractNautilusUI methodsFor: 'group' stamp: 'BenjaminVanRyseghem 1/24/2013 18:19'! addMatchingPackagesInGroups self selectedPackage ifNotNil: [:package || separatorIndex firstPartOfTheName packages | separatorIndex := package name indexOf: $- ifAbsent: [ package name size + 1]. firstPartOfTheName := package name copyFrom: 1 to: (separatorIndex - 1) . packages := self model packages select: [:each | each name beginsWith: firstPartOfTheName ]. [ ^ self addPackagesAsGroups: packages ] on: GroupsAlreadyExists do: [:ex | self alertGroupExisting: ex groupName. ^ nil ]]. ^ nil! ! !AbstractNautilusUI methodsFor: 'group'! addMatchingPackagesInGroupsAndBrowse ( self addMatchingPackagesInGroups ) ifNotNil: [:group | self selectedGroup: group. self showGroups: true]! ! !AbstractNautilusUI methodsFor: 'group' stamp: 'BenjaminVanRyseghem 1/24/2013 21:03'! addNewGroup [ self groupsManager createAnEmptyStaticGroup ] on: GroupAlreadyExists do:[ :ex | self alertGroupExisting: ex ]! ! !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: 'group'! addPackageAsGroupAndBrowse self addPackageAsGroup ifNotNil: [:group | self selectedGroup: group. self showGroups: true] ifNil: [ | group | group := self model class groupsManager groups detect: [:each | each name = self selectedPackage name] ifNone: [ nil ]. group ifNotNil: [ self selectedGroup: group. self showGroups: true ]]! ! !AbstractNautilusUI methodsFor: 'group' stamp: 'BenjaminVanRyseghem 1/24/2013 18:17'! addPackagesAsGroups [ self addPackagesAsGroups: self selectedPackages ] on: GroupAlreadyExists do: [:ex | self alertGroupExisting: ex groupName ]! ! !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: 'group' stamp: 'BenjaminVanRyseghem 4/6/2012 16:45'! addPackagesInGroup self addPackagesInGroup: self selectedPackages! ! !AbstractNautilusUI methodsFor: 'group'! 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: 'group announcements'! aGroupHasBeenAdded: anAnnouncement "(NautilusUI methodDict at: #aGroupHasBeenRegistered:) getSource" | group | window ifNil: [ ^ self ]. window isDisplayed ifFalse: [^ self ]. self showGroups ifFalse: [ ^ self ]. group := anAnnouncement group. (self groupsManager includes: group) ifTrue: [ self updateGroupView ]! ! !AbstractNautilusUI methodsFor: 'group announcements'! aGroupHasBeenRegistered: anAnnouncement "(NautilusUI methodDict at: #aGroupHasBeenRegistered:) getSource" | group | window ifNil: [ ^ self ]. window isDisplayed ifFalse: [^ self ]. self showGroups ifFalse: [ ^ self ]. group := anAnnouncement group. (self groupsManager includes: group) ifTrue: [ self updateGroupView ]! ! !AbstractNautilusUI methodsFor: 'group announcements'! aGroupHasBeenRemoved: anAnnouncement "(NautilusUI methodDict at: #aGroupHasBeenRegistered:) getSource" window ifNil: [ ^ self ]. window isDisplayed ifFalse: [^ self ]. self showGroups ifFalse: [ ^ self ]. (self groupsManager = anAnnouncement holder) ifTrue: [ self selectedGroup = anAnnouncement group ifTrue: [ self selectedGroup: nil ]. self updateGroupView. self update ]! ! !AbstractNautilusUI methodsFor: 'group announcements'! aGroupHasBeenRenamed: anAnnouncement "(NautilusUI methodDict at: #aGroupHasBeenRegistered:) getSource" | group | window ifNil: [ ^ self ]. window isDisplayed ifFalse: [^ self ]. self showGroups ifFalse: [ ^ self ]. group := anAnnouncement group. (self groupsManager includes: group) ifTrue: [ self updateGroupView ]! ! !AbstractNautilusUI methodsFor: 'group announcements'! aGroupHasBeenUnregistered: anAnnouncement | group | window ifNil: [ ^ self ]. window isDisplayed ifFalse: [^ self ]. self showGroups ifFalse: [ ^ self ]. group := anAnnouncement group. (self groupsManager includes: group) ifTrue: [ self updateGroupView ]! ! !AbstractNautilusUI methodsFor: 'icon' stamp: 'BenjaminVanRyseghem 2/16/2013 00:29'! 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 := self iconClass iconNamed: #testNotRun. aClass hasPassedTest ifTrue: [ icon := self iconClass iconNamed: #testGreen ]. aClass hasFailedTest ifTrue: [ icon := self iconClass iconNamed: #testYellow ]. aClass hasErrorTest ifTrue: [ icon := self iconClass iconNamed: #testRed ]. 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: (self iconClass iconNamed: #uncommentedClass) ; 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 nautilusIcon)! ! !AbstractNautilusUI methodsFor: 'icon' stamp: 'CamilloBruni 10/7/2012 22:04'! 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: (self iconClass iconNamed: #groupIcon); color: Color transparent; extent: 15 @ 16; helpText: 'Browse restricted environment'; borderWidth: 0. GroupsIconsCache at: aGroup put: (IconicButtonStateHolder forNautilus: icon). ^ icon! ! !AbstractNautilusUI methodsFor: 'icon'! iconClass ^ self class iconClass! ! !AbstractNautilusUI methodsFor: 'icon' stamp: 'BenjaminVanRyseghem 3/23/2012 19:17'! listIcon2: anItem ^ self classIconFor: anItem " ^ self ifPackages: [ self classIconFor: anItem ] ifClasses: [ self packageIconFor: anItem ]"! ! !AbstractNautilusUI methodsFor: 'icon' stamp: 'BenjaminVanRyseghem 3/23/2012 19:16'! listIcon: anItem " I return the icon corresponding to anItem in the leftmost list " ^ self showGroups ifTrue: [ self groupIconFor: anItem ] ifFalse: [ " if I do not show groups, I have to know if I show packages or classes " self packageIconFor: anItem" self ifPackages: [ self packageIconFor: anItem ] ifClasses: [ self classIconFor: anItem ]"]! ! !AbstractNautilusUI methodsFor: 'icon' stamp: 'BenjaminVanRyseghem 2/8/2013 16:43'! packageIconFor: aPackage | mcpackage | PackagesIconsCache at: aPackage ifPresent: [:icon | icon class == IconicButtonStateHolder ifFalse: [ ^ icon ]. ^ icon asIconTargetting: self ]. aPackage classes isEmpty ifTrue: [^ PackagesIconsCache at: aPackage put: (self iconClass iconNamed: #emptyPackageIcon) ]. mcpackage := (NautilusMCBindings default mcPackageFor: aPackage). (mcpackage notNil and: [ mcpackage isDirty ]) ifTrue: [ | icon | icon := IconicButton new target: self; actionSelector: #saveDirtyPackages:; arguments: {{ aPackage }}; labelGraphic: (aPackage definedClasses ifEmpty: [ (self iconClass iconNamed: #dirtyMonticelloPackageIcon) ] ifNotEmpty: [ (self iconClass 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: (self iconClass iconNamed: #monticelloPackage) ]. ^ PackagesIconsCache at: aPackage put: (self iconClass iconNamed: #packageIcon)! ! !AbstractNautilusUI methodsFor: 'icon'! rebuildIconicButtonFrom: icon ^ IconicButton new target: self; actionSelector: icon actionSelector; arguments: icon arguments; labelGraphic: icon labelGraphic; color: icon color; helpText: icon helpText; extent: icon extent; borderWidth: icon borderWidth! ! !AbstractNautilusUI methodsFor: 'icon caches'! methodsIconsCache ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'icon caches'! removeClassFromMethodsIconsCache: aClass self methodsIconsCache keys do: [:method | " for overrides " method methodClass = aClass ifTrue: [ self removeFromClassesIconsCache: aClass. self methodsIconsCache removeKey: method ifAbsent: [ ]]].! ! !AbstractNautilusUI methodsFor: 'icon caches'! removeFromClassesIconsCache: aClass " not used since the class's icons are always the same " ClassesIconsCache removeKey: aClass ifAbsent: []. self updateClassView.! ! !AbstractNautilusUI methodsFor: 'icon caches'! removeFromGroupsIconsCache: aClass " not used since the groups's icons are always the same " GroupsIconsCache removeKey: aClass ifAbsent: [].! ! !AbstractNautilusUI methodsFor: 'icon caches'! 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: 'icon caches'! removeFromPackagesIconsCache: aPackage PackagesIconsCache removeKey: aPackage ifAbsent: [].! ! !AbstractNautilusUI methodsFor: 'icons behavior'! arrowDown: aMethod | methods methodsNames index | methods := aMethod methodClass allSubclasses gather: [:each | each methodDict values ]. 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: 'icons behavior'! arrowUp: aMethod | newMethod | newMethod := aMethod methodClass superclass lookupSelector: aMethod selector. self model class openOnMethod: newMethod! ! !AbstractNautilusUI methodsFor: 'icons behavior'! openCommentEditor: aClass | newComment | newComment :=UITheme current 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: 'icons behavior'! runClassTests self runClassTests: self selectedClasses notifying: true! ! !AbstractNautilusUI methodsFor: 'icons behavior'! runTestForAMethod: aMethod notifying: anObject ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'icons behavior'! saveDirtyPackages: aCollection aCollection isEmptyOrNil ifTrue: [ ^ self ]. aCollection do: [:package || workCopy browser wrap index | 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: 'items creation'! buildBrowseClassVarsButton ^ ( PluggableThreePhaseButtonMorph on: self ) actionSelector: #browseClassVars; stateSelector: #isAClassSelected ; onImage: (self iconClass iconNamed: #classVarsSelectedIcon); offImage: (self iconClass iconNamed: #classVarsUnselectedIcon); pressedImage: (self iconClass iconNamed: #classVarsPressedIcon); extent: 24@24; helpText: 'Show class variables'; yourself.! ! !AbstractNautilusUI methodsFor: 'items creation'! buildBrowseInstVarsButton ^ ( PluggableThreePhaseButtonMorph on: self ) actionSelector: #browseInstVars; stateSelector: #isAClassSelected ; onImage: (self iconClass iconNamed: #instVarsSelectedIcon); offImage: (self iconClass iconNamed: #instVarsUnselectedIcon); pressedImage: (self iconClass iconNamed: #instVarsPressedIcon); extent: 24@24; helpText: 'Show instance variables'; yourself.! ! !AbstractNautilusUI methodsFor: 'items 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: 'items 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: 'items 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: 'items creation' stamp: 'EstebanLorenzano 1/30/2013 14:43'! buildGroupsButton | button | button := (PluggableButtonMorph on: self getState: #groupsButtonState action: #groupsButtonAction label: #groupsButtonLabel) hResizing: #spaceFill; vResizing: #shrinkWrap. self setShortcuts: #NautilusGroupShortcuts to: button. ^ button! ! !AbstractNautilusUI methodsFor: 'items creation' stamp: 'BenjaminVanRyseghem 12/20/2012 12:27'! buildInstanceButton ^ (CheckboxMorph on: self selected: #instanceButtonState changeSelected: #instanceButtonAction) getLabelSelector: #instanceButtonLabel; labelClickable: true; hResizing: #spaceFill; vResizing: #shrinkWrap; yourself "^ (PluggableButtonMorph on: self getState: #instanceButtonState action: #instanceButtonAction label: #instanceButtonLabel) hResizing: #spaceFill; vResizing: #shrinkWrap"! ! !AbstractNautilusUI methodsFor: 'items 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: 'items 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: 'items creation'! buildSeparator ^ Morph new height: 2; width: 0; color: Color transparent. " ^ ImageMorph new newForm: (self iconClass iconNamed: #separatorIcon) "! ! !AbstractNautilusUI methodsFor: 'items creation'! buildSwitchToByteCodeButton ^ ( PluggableThreePhaseButtonMorph on: self ) actionSelector: # switchToByteCodeButton; stateSelector: #showByteCode ; onImage: (self iconClass iconNamed: #byteCodeSelectedIcon); offImage: (self iconClass iconNamed: #byteCodeUnselectedIcon); pressedImage: (self iconClass iconNamed: #byteCodePressedIcon); extent: 24@24; helpText: 'Show byteCode'; yourself.! ! !AbstractNautilusUI methodsFor: 'items creation'! buildSwitchToDecompileButton ^ ( PluggableThreePhaseButtonMorph on: self ) actionSelector: # switchToDecompileButton; stateSelector: #showDecompile ; onImage: (self iconClass iconNamed: #decompileSelectedIcon); offImage: (self iconClass iconNamed: #decompileUnselectedIcon); pressedImage: (self iconClass iconNamed: #decompilePressedIcon); extent: 24@24; helpText: 'Show decompiled method'; yourself.! ! !AbstractNautilusUI methodsFor: 'items creation'! buildSwitchToSourceCodeButton ^ ( PluggableThreePhaseButtonMorph on: self ) actionSelector: # switchToSourceCodeButton; stateSelector: #showSource ; onImage: (self iconClass iconNamed: #sourceSelectedIcon); offImage: (self iconClass iconNamed: #sourceUnselectedIcon); pressedImage: (self iconClass iconNamed: #sourcePressedIcon); extent: 24@24; state: #on; helpText: 'Show source code'; yourself.! ! !AbstractNautilusUI methodsFor: 'items 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: 'list selections' stamp: 'BenjaminVanRyseghem 3/23/2012 19:57'! listSelection ^ self showGroups ifTrue: [ groupsSelection ] ifFalse: [ packagesSelection ]! ! !AbstractNautilusUI methodsFor: 'list selections' stamp: 'BenjaminVanRyseghem 3/23/2012 19:57'! listSelection2 ^ classesSelection! ! !AbstractNautilusUI methodsFor: 'list selections'! listSelection2At: anIndex | elt | elt := self getList2 at: anIndex ifAbsent: [ ^false ]. ^ self listSelection2 at: elt ifAbsent: [ false ]! ! !AbstractNautilusUI methodsFor: 'list selections'! listSelection2At: anIndex put: aBoolean | elt | aBoolean ifNil: [ ^ self ]. elt := self getList2 at: anIndex ifAbsent: [ ^ self ]. self listSelection2 at: elt put: aBoolean. self changed: #hasSelectedSelections! ! !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: 'list selections'! listSelectionAt: anIndex put: aBoolean | elt | elt := self getList at: anIndex ifAbsent: [ ^ self ]. self listSelection at: elt put: aBoolean. self changed: #hasSelectedSelections! ! !AbstractNautilusUI methodsFor: 'menu builder'! categoryMenuBuilder ^ PragmaMenuBuilder withAllPragmaKeywords: {self commonPragma. self categoryPragma} model: self! ! !AbstractNautilusUI methodsFor: 'menu builder'! classMenuBuilder ^ PragmaMenuBuilder withAllPragmaKeywords: {self classFixPragma. self classPragma} model: self! ! !AbstractNautilusUI methodsFor: 'menu builder' stamp: 'EstebanLorenzano 1/31/2013 19:24'! classesMenu: aMenu shifted: aBoolean ^ aMenu addAllFrom: self classMenuBuilder menu.! ! !AbstractNautilusUI methodsFor: 'menu builder'! groupMenuBuilder ^ PragmaMenuBuilder withAllPragmaKeywords: {self groupFixPragma. self groupPragma} model: self! ! !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: 'menu builder'! methodMenuBuilder ^ PragmaMenuBuilder withAllPragmaKeywords: {self commonPragma. self methodPragma} model: self! ! !AbstractNautilusUI methodsFor: 'menu builder'! packageMenuBuilder ^ PragmaMenuBuilder withAllPragmaKeywords: {self packageFixPragma. self packagePragma} model: self! ! !AbstractNautilusUI methodsFor: 'menu builder' stamp: 'EstebanLorenzano 1/31/2013 19:24'! packagesMenu: aMenu shifted: aBoolean ^ aMenu addAllFrom: (self packageMenuBuilder menu)! ! !AbstractNautilusUI methodsFor: 'menu builder' stamp: 'EstebanLorenzano 1/31/2013 19:24'! sourceCodeMenu: aMenu shifted: shifted " 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 sourceCodeMenuBuilder menu)! ! !AbstractNautilusUI methodsFor: 'menu builder'! sourceCodeMenuBuilder ^ PragmaMenuBuilder pragmaKeyword: self sourceCodePragma model: self! ! !AbstractNautilusUI methodsFor: 'menu pragmas' stamp: 'EstebanLorenzano 1/30/2013 17:30'! categoryPragma ^'nautilusGlobalProtocolMenu'! ! !AbstractNautilusUI methodsFor: 'menu pragmas' stamp: 'EstebanLorenzano 1/30/2013 17:30'! classFixPragma ^'nautilusGlobalClassFixMenu'! ! !AbstractNautilusUI methodsFor: 'menu pragmas' stamp: 'EstebanLorenzano 1/30/2013 17:30'! classPragma ^'nautilusGlobalClassMenu'! ! !AbstractNautilusUI methodsFor: 'menu pragmas' stamp: 'EstebanLorenzano 1/30/2013 17:30'! commonPragma ^'nautilusGlobalCommonMenu'! ! !AbstractNautilusUI methodsFor: 'menu pragmas' stamp: 'EstebanLorenzano 1/30/2013 17:30'! groupFixPragma ^'nautilusGlobalGroupFixMenu'! ! !AbstractNautilusUI methodsFor: 'menu pragmas' stamp: 'EstebanLorenzano 1/30/2013 17:30'! groupPragma ^'nautilusGlobalGroupMenu'! ! !AbstractNautilusUI methodsFor: 'menu pragmas' stamp: 'EstebanLorenzano 1/30/2013 17:30'! methodPragma ^'nautilusGlobalMethodMenu'! ! !AbstractNautilusUI methodsFor: 'menu pragmas' stamp: 'EstebanLorenzano 1/30/2013 17:23'! packageFixPragma ^ 'nautilusGlobalPackageFixMenu'! ! !AbstractNautilusUI methodsFor: 'menu pragmas' stamp: 'EstebanLorenzano 1/30/2013 17:24'! packagePragma ^ 'nautilusGlobalPackageMenu'! ! !AbstractNautilusUI methodsFor: 'menu pragmas' stamp: 'EstebanLorenzano 1/30/2013 17:30'! sourceCodePragma ^ 'nautilusGlobalSourceCodeMenu'! ! !AbstractNautilusUI methodsFor: 'menus' stamp: 'BenjaminVanRyseghem 4/6/2012 17:32'! addModelItemsToWindowMenu: aMenu "Add model-related items to the window menu" "super addModelItemsToWindowMenu: aMenu." SystemBrowser addRegistryMenuItemsTo: aMenu inAccountOf: self model. aMenu addLine; add: 'Nautilus Plugins Manager' target: NautilusPluginManager new action: #openInWorld. aMenu add: 'Shortcuts description' target: self action: #openShortcutDescription.! ! !AbstractNautilusUI methodsFor: 'menus' stamp: 'BenjaminVanRyseghem 3/23/2012 19:58'! menu2: aMenu shifted: aBoolean self classesMenu: aMenu shifted: aBoolean. ^ aMenu! ! !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: 'menus behavior'! addCategory ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'BenjaminVanRyseghem 4/14/2012 12:05'! addClass self selectedPackage ifNotNil: [:package | self addClassIn: package ]! ! !AbstractNautilusUI methodsFor: 'menus behavior'! addPackage | package | package := self addPackageBasedOn: self selectedPackage. package ifNotNil: [ self selectedPackage: package. self updatePackageViewAndMove ]! ! !AbstractNautilusUI methodsFor: 'menus behavior'! addTrait self selectedPackage ifNotNil: [:package | self addTraitIn: package ] " No need of update, announcements will do the job "! ! !AbstractNautilusUI methodsFor: 'menus behavior'! browseClassRefs self browseClassRefsOf: self selectedClass.! ! !AbstractNautilusUI methodsFor: 'menus behavior'! browseClassVarRefs self browseClassVarRefsOf: self selectedClass! ! !AbstractNautilusUI methodsFor: 'menus behavior'! browseInstVarDefs self browseInstVarDefsOf: self selectedClass! ! !AbstractNautilusUI methodsFor: 'menus behavior'! browseInstVarRefs self browseInstVarRefsOf: self selectedClass! ! !AbstractNautilusUI methodsFor: 'menus behavior'! browseMessages self browseMessagesFrom: self selectedMethod selector! ! !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: 'menus behavior'! browseUnusedMethods self browseUnusedMethodsOf: self selectedClass! ! !AbstractNautilusUI methodsFor: 'menus behavior'! browseVersions "Create and schedule a Versions Browser, showing all versions of the currently selected message. Answer the browser or nil." self browseVersionsFrom: self selectedMethod! ! !AbstractNautilusUI methodsFor: 'menus behavior'! buildInitializeCodeFor: aClass ^ String streamContents: [:str | str << 'initialize';cr. str tab << '"Initialization code for '<> selector ]. MethodClassifier classifyAll: methods ]! ! !AbstractNautilusUI methodsFor: 'menus behavior'! categorizeMethod ^ self subclassResponsibility! ! !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: 'menus behavior'! 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: 'menus behavior'! createInstVarAccessors self createInstVarAccessorsOf: self selectedClass! ! !AbstractNautilusUI methodsFor: 'menus behavior'! enableSingleClassSelection ^ self selectedClasses size <= 1! ! !AbstractNautilusUI methodsFor: 'menus behavior'! enableSingleMenuItems ^ self selectedItems size <= 1! ! !AbstractNautilusUI methodsFor: 'menus behavior'! fileOutClass "Print a description of the selected class onto a file whose name is the category name followed by .st." self fileOutClasses: self selectedClasses! ! !AbstractNautilusUI methodsFor: 'menus behavior'! fileOutMethods ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'menus behavior'! fileOutPackage self fileOutPackages: self selectedPackages! ! !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: 'menus behavior' stamp: 'CamilloBruni 9/14/2012 01:35'! findClass: aSearchInstance "select the class returned by the search block" | aClass recentList | self okToChange ifFalse: [^ self flashPackage ]. aClass := aSearchInstance chooseFromOwner: self window. aClass ifNil: [^ self flashPackage]. self showGroups: false. self selectedPackage: aClass package. self selectedClass: aClass. self updateBothView! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'CamilloBruni 9/14/2012 01:49'! findClassInHierarchy "Search for a subclass of the selected class from a pattern or from the recent list" self selectedClass ifNotNil: [ :class| self findClass: (SearchFacade hierarchySearchFor: class theNonMetaClass)].! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'BenjaminVanRyseghem 6/27/2012 00:30'! findPackage "Search for a package from a pattern or from the recent list" | foundPackage packagesList | 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: '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: '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: 'menus behavior'! 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: 'menus behavior'! fullBrowse ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'MarcusDenker 9/17/2012 15:37'! generateInitialize self selectedClass ifNotNil: [:class || code index category | category := 'initialize'. (class isMeta not and: [class inheritsFrom: TestCase]) ifTrue: [ index := 34. (class includesSelector: #setUp) ifFalse: [ code := self buildSetUpCodeFor: class. class compile: code classified: category ]. (class includesSelector: #tearDown) ifFalse: [ code := self buildTearDownCodeFor: class. class compile: code classified: category ]. self selectedMethod: (class>>#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: 'menus behavior'! mergeGroups | group | group := self mergeGroups: self selectedGroups. group ifNotNil: [ self groupsManager addAGroup: group. self selectedGroup: group. self updateBothView] ! ! !AbstractNautilusUI methodsFor: 'menus behavior'! methodHierarchy "Create and schedule a method browser on the hierarchy of implementors." self methodHierarchyFrom: self selectedMethod! ! !AbstractNautilusUI methodsFor: 'menus behavior'! 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: 'menus behavior'! moveMethodToPackage ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'menus behavior'! removeClassFromGroup self selectedClasses do: [:class | [ self groupsManager removeClass: class theNonMetaClass from: self selectedGroup. self updateClassView ] fork ]. self selectedClass: nil; updateClassView.! ! !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: 'menus behavior'! removeEmptyCategories self okToChange ifFalse: [^ self]. (self methodsForCategory: self selectedCategory) ifEmpty: [ self selectedCategory: nil ]. self removeEmptyCategoriesFrom: self selectedClass. 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: 'menus behavior' stamp: 'BenjaminVanRyseghem 6/22/2012 14:07'! 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 size > 0 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: 'menus behavior'! renameCategory ^ self subclassResponsibility! ! !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: 'menus behavior'! renameGroup | group newName | group := self selectedGroup. group ifNil: [ ^ self ]. self groupsManager renameAGroup: group. self updateBothView! ! !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: '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: 'MarcusDenker 1/17/2013 11:04'! restrictedBrowseClass self selectedClass ifNil: [ ^ self ] ifNotNil: [ :class | self restrictedBrowseClasses: {class} ]! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'CamilloBruni 10/7/2012 22:02'! restrictedBrowseClasses: classes | newEnvironment | newEnvironment := self browsedEnvironment forClasses: classes. self model class openOnClass:self selectedClass inEnvironment: newEnvironment ! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'CamilloBruni 10/7/2012 22:04'! restrictedBrowseGroup self restrictedBrowseGroups: self selectedGroups! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'CamilloBruni 10/7/2012 22:03'! restrictedBrowseGroups: aCollection aCollection ifNotEmpty: [:groups || elements newEnvironment | elements := groups gather: [:group | group elements]. newEnvironment := self browsedEnvironment forClasses: (elements collect: #theNonMetaClass). self model class openOnGroup: groups first inEnvironment: newEnvironment ]! ! !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: 'menus behavior' stamp: 'CamilloBruni 10/7/2012 22:00'! restrictedBrowsePackage self selectedPackages ifEmpty: [ ^ self ] ifNotEmpty: [:packages | ^ self restrictedBrowsePackages: packages ]! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'CamilloBruni 10/7/2012 22:30'! restrictedBrowsePackageRegex | regex | regex := self selectedPackages ifEmpty: [ '' ] ifNotEmpty: [ :packages | '^',(packages first name splitOn: $-) first , '-.*$']. regex := UIManager default request: 'Browse restricted on Packages matching:' regex: regex . regex ifNil: [ ^ self ]. self restrictedBrowsePackages: (self browsedEnvironment packages select: [ :package| regex matches: package name ] )! ! !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: 'menus behavior' stamp: 'CamilloBruni 10/7/2012 22:02'! restrictedBrowseSubclasses self selectedClass ifNil: [ ^ self ] ifNotNil: [ :class | self restrictedBrowseClasses: class withAllSubclasses]! ! !AbstractNautilusUI methodsFor: 'menus behavior' stamp: 'CamilloBruni 10/7/2012 22:02'! restrictedBrowseSuperclasses self selectedClass ifNil: [ ^ self ] ifNotNil: [ :class | self restrictedBrowseClasses: class withAllSuperclasses ]! ! !AbstractNautilusUI methodsFor: 'menus behavior'! 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: 'menus behavior'! 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: 'menus behavior'! 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" self showUnreferencedInstVarsOf: self selectedClass! ! !AbstractNautilusUI methodsFor: 'monticello announcements'! mcPackageModified: anAnnouncement " handled when a package become dirty " | rpackages | window ifNil: [^ self ]. window isDisplayed ifFalse: [ ^ self ]. rpackages := (NautilusMCBindings default rPackagesFor: anAnnouncement package). (self model packages includesAnyOf: rpackages ) ifTrue: [ rpackages do: [:rpackage | PackagesIconsCache removeKey: rpackage ifAbsent: []]. self updatePackageView ]! ! !AbstractNautilusUI methodsFor: 'monticello announcements' stamp: 'MarcusDenker 7/6/2012 23:11'! mcWorkingCopyCreated: anAnnouncement | package rpackage mcPackage | 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: 'monticello announcements' stamp: 'EstebanLorenzano 5/21/2012 17:10'! mcWorkingCopyDeleted: anAnnouncement | package rpackages | window ifNil: [^ self ]. window isDisplayed ifFalse: [ ^ self ]. package := anAnnouncement package. package ifNil: [ ^ self ]. rpackages := NautilusMCBindings default rPackagesFor: package. rpackages ifNil: [ ^ self ]. rpackages do: [:rpackage | PackagesIconsCache removeKey: rpackage ifAbsent: []]. self updatePackageView! ! !AbstractNautilusUI methodsFor: 'monticello announcements'! 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: 'plugins announcements'! aKeyHasBeenPressed: aKey self announcer announce: (NautilusKeyPressed key: aKey )! ! !AbstractNautilusUI methodsFor: 'plugins announcements' stamp: 'CamilloBruni 1/11/2013 13:36'! browseClass: aClass self showGroups: false. self selectedPackage: aClass package. self selectedClass: aClass. self updateBothView! ! !AbstractNautilusUI methodsFor: 'plugins announcements' stamp: 'CamilloBruni 1/11/2013 13:35'! browseSuperclass self selectedClass ifNil: [ ^ self ] ifNotNil: [ :class | self browseSuperclassOf: class ]! ! !AbstractNautilusUI methodsFor: 'plugins announcements' stamp: 'CamilloBruni 1/11/2013 13:35'! browseSuperclassOf: class ^ self browseClass: class superclass! ! !AbstractNautilusUI methodsFor: 'plugins announcements' stamp: 'CamilloBruni 1/16/2013 00:24'! openClass self openClass: self selectedClass! ! !AbstractNautilusUI methodsFor: 'plugins announcements' stamp: 'CamilloBruni 1/11/2013 14:12'! openClass: aClass aClass ifNil: [ ^ self ]. self open browseClass: aClass! ! !AbstractNautilusUI methodsFor: 'plugins announcements' stamp: 'CamilloBruni 1/11/2013 14:13'! openSubclass "Search for a superclass of the selected class from a pattern or from the recent list" self selectedClass ifNotNil: [ :class| | search | search := SearchFacade subclassSearchFor: class theNonMetaClass. self openClass: (search chooseFromOwner: self window) ].! ! !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: 'plugins display'! buildBottomPlugins ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'plugins display'! buildLeftPlugins | left | left := self model plugins select: [:each | each position = #left ].! ! !AbstractNautilusUI methodsFor: 'plugins display'! buildRightPlugins | right | right := self model plugins select: [:each | each position = #right ].! ! !AbstractNautilusUI methodsFor: 'plugins display'! buildTopPlugins ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'protocol'! forceSelection: anObject! ! !AbstractNautilusUI methodsFor: 'protocol'! resetSelections! ! !AbstractNautilusUI methodsFor: 'protocol'! title: aString shouldUpdateTitle := false. window title: aString! ! !AbstractNautilusUI methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/18/2012 18:57'! update self subclassResponsibility ! ! !AbstractNautilusUI methodsFor: 'shortcuts' stamp: 'BenjaminVanRyseghem 6/28/2012 15:18'! openShortcutDescription KMDescription new categories: #(NautilusGlobalShortcuts "NautilusClassShortcuts NautilusSourceCodeShortcuts NautilusPackageShortcuts NautilusProtocolShortcuts NautilusMethodShortcuts") sort; openWithSpec! ! !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: 'shortcuts'! setClassShorcutsTo: aList aList attachKeymapCategory: #NautilusClassShortcuts targetting: self! ! !AbstractNautilusUI methodsFor: 'shortcuts' stamp: 'BenjaminVanRyseghem 8/1/2012 19:13'! setCommentShorcutsTo: aList aList attachKeymapCategory: #NautilusCommentShortcuts targetting: self! ! !AbstractNautilusUI methodsFor: 'shortcuts' stamp: 'EstebanLorenzano 2/6/2013 14:00'! setGroupShorcutsTo: aList aList attachKeymapCategory: #NautilusGroupShortcuts targetting: self! ! !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: 'shortcuts' stamp: 'EstebanLorenzano 1/30/2013 14:37'! setSourceCodeShorcutsTo: aList aList attachKeymapCategory: #NautilusSourceCodeShortcuts targetting: self! ! !AbstractNautilusUI methodsFor: 'source code area'! 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 ]! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'BenjaminVanRyseghem 2/8/2013 16:23'! buildNewSourceTextArea sourceTextArea := self textMorphClass on: self text: #sourceCodeFrom: accept: #compileSource:notifying: readSelection: #contentsSelectionFrom: menu: #sourceCodeMenu:shifted:. sourceTextArea askBeforeDiscardingEdits: true; color: Color white; lockSelector: #lockTextArea:from:; canLockChangeSelector: #canChangeLockFor:; vResizing: #spaceFill; hResizing: #spaceFill; font: StandardFonts codeFont; spaceFillWeight: 3; on: #keyStroke send: #keyStroke:fromSourceCodeMorph: to: self; warningLimit: self warningLimit. self setSourceCodeShorcutsTo: sourceTextArea. sourceTextAreaLimit := sourceTextArea warningLimit. sourceTextArea warningLimit: -1. sourceTextAreas addFirst: (sourceTextArea -> nil). ^ sourceTextArea ! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'BenjaminVanRyseghem 8/6/2012 01:23'! canChangeLockFor: source ^ source locked or: [ self selectedMethod isNil not ]! ! !AbstractNautilusUI methodsFor: 'source code area'! clearUserEditFlag self changed: #clearUserEdits! ! !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: 'source code area' stamp: 'BenjaminVanRyseghem 8/1/2012 19:10'! commentTextArea ^ commentTextArea! ! !AbstractNautilusUI methodsFor: 'source code area'! compileAClassFrom: aString notifying: aController sourceTextArea update: #clearUserEdits. ( self compileANewClassFrom: aString notifying: aController startingFrom: self selectedClass ) ifNil: [^ sourceTextArea hasUnacceptedEdits: true. ] ifNotNil: [:class | self selectedPackage: class package. self selectedClass: class. self showHierarchy ifTrue: [ self hierarchyClass: class ]. self showGroups ifTrue: [ self updateClassView ] ifFalse: [ self updateBothView ]]! ! !AbstractNautilusUI methodsFor: 'source code area'! compileAMethodFromCategory: aCategory withSource: aString notifying: aController ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'source code area'! compileSource: aText notifying: aController ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'BenjaminVanRyseghem 2/8/2013 16:22'! contentSelectionFor: aTextMorph aTextMorph ifLocked: [ ^ (1 to: 0) ]. self selectedClass isNil ifFalse:[ self selectedMethod isNil ifTrue: [ self selectedCategory notNil ifTrue: [^ (1 to: self defaultMethodSource size) ]]]. ^ (1 to: 0) ! ! !AbstractNautilusUI methodsFor: 'source code area'! defaultClassDescriptor | string | string := 'Object subclass: #NameOfSubclass instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: '''. ^ self selectedPackage ifNil: [string, '''' ] ifNotNil: [:package | string, package name, '''' ]! ! !AbstractNautilusUI methodsFor: 'source code area'! defaultMethodSource ^ 'message selector and argument names "comment stating purpose of message" | temporary variable names | statements'! ! !AbstractNautilusUI methodsFor: 'source code area'! doItContext ^ nil! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'CamilloBruni 10/4/2012 10:45'! doItReceiver ^ self selectedClass ifNotNil: [:class | class theNonMetaClass ]! ! !AbstractNautilusUI methodsFor: 'source code area'! getComments ^ self selectedClass ifNil: [ self selectedPackage ifNil: [ '' ] ifNotNil: [:package | '' "package comment" ]] ifNotNil: [:class | class comment ]! ! !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: '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: 'BenjaminVanRyseghem 8/6/2012 01:31'! lockTextArea self selectedMethod isNil ifTrue: [ ^ self ]. sourceTextArea lockFrom: self selectedMethod. self buildNewSourceTextArea. multipleMethodsEditor addEditor: sourceTextArea. self changed: #sourceCodeFrom:.! ! !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: 'source code area' stamp: 'BenjaminVanRyseghem 4/17/2012 17:24'! okToChange sourceTextArea text asString trimBoth = sourceTextArea getText asString trimBoth ifTrue: [ ^ true ]. sourceTextArea canDiscardEdits ifTrue: [^ true]. sourceTextArea update: #wantToChange. "Solicit cancel from view" ^ sourceTextArea canDiscardEdits ! ! !AbstractNautilusUI methodsFor: 'source code area'! okToChangeBoth self canDiscardEdits ifTrue: [^ true]. self changed: #wantToChange. "Solicit cancel from view" ^ self canDiscardEdits ! ! !AbstractNautilusUI methodsFor: 'source code area'! okToChangeComment commentTextArea canDiscardEdits ifTrue: [^ true]. commentTextArea update: #wantToChange. "Solicit cancel from view" ^ commentTextArea canDiscardEdits ! ! !AbstractNautilusUI methodsFor: 'source code area'! putSourceTextAreaLimit sourceTextArea ifNotNil: [ sourceTextArea warningLimit: sourceTextAreaLimit ]! ! !AbstractNautilusUI methodsFor: 'source code area'! removeSourceTextAreaLimit sourceTextArea ifNotNil: [ sourceTextArea warningLimit: -1 ]! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'BenjaminVanRyseghem 8/3/2012 18:16'! removeTextArea: anArea self shouldBeImplemented! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'BenjaminVanRyseghem 2/8/2013 16:22'! resetContentsSelectionFrom: aTextMorph contentSelection at: aTextMorph put: (self contentSelectionFor: aTextMorph)! ! !AbstractNautilusUI methodsFor: 'source code area'! selectedClassComments ^ self selectedClass ifNil: [''] ifNotNil: [:class| class comment]! ! !AbstractNautilusUI methodsFor: 'source code area'! selectedClassDescription ^ self selectedClass definition! ! !AbstractNautilusUI methodsFor: 'source code area'! selectedMethodComments ^ self selectedMethod comment! ! !AbstractNautilusUI methodsFor: 'source code area'! selectedMethodSource self selectedMethod ifNil: [ ^ '' ] ifNotNil: [:method | self showSource ifTrue: [ ^ method sourceCode ]. self showByteCode ifTrue: [ ^ method symbolic asText]. self showDecompile ifTrue: [ ^ method decompileWithTemps decompileString asText makeSelectorBoldIn: method methodClass ]. ^ 'error'] ! ! !AbstractNautilusUI methodsFor: 'source code area'! setStylerClass: aClass sourceTextArea ifNotNil: [ sourceTextArea classOrMetaClass: aClass ]! ! !AbstractNautilusUI methodsFor: 'source code area'! sourceCode self removeSourceTextAreaLimit. ^self selectedClass isNil ifTrue: [ self defaultClassDescriptor] ifFalse:[ self selectedMethod isNil ifTrue: [ self selectedCategory notNil ifTrue: [ self putSourceTextAreaLimit. self defaultMethodSource] ifFalse: [ self selectedClassDescription]] ifFalse: [ self putSourceTextAreaLimit. self selectedMethodSource]]. ! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'BenjaminVanRyseghem 8/4/2012 01:07'! sourceCodeFrom: aTextMorph aTextMorph ifLocked: [ ^ aTextMorph textMorph text ]. ^ self sourceCode! ! !AbstractNautilusUI methodsFor: 'source code area' stamp: 'BenjaminVanRyseghem 8/6/2012 00:53'! unlockTextArea: source multipleMethodsEditor removeEditor: source! ! !AbstractNautilusUI methodsFor: 'source text events'! keyStroke: anEvent fromSourceCodeMorph: aMorph ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'system announcements' stamp: 'GuillermoPolito 8/3/2012 13:21'! 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 = class package]) ifTrue: [ self updateClassView. self removeFromPackagesIconsCache: class package ]! ! !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: 'system announcements' stamp: 'BenjaminVanRyseghem 8/6/2012 19:55'! classDefinitionModified: anAnnouncement | class | window ifNil: [^ self ]. window isDisplayed ifFalse: [ ^ self ]. class := anAnnouncement newClassDefinition. ((self showGroups and: [ self selectedGroup notNil and: [ self selectedGroup elements includes: class ]]) or: [ self getList2 includes: class ]) ifTrue: [ self updateClassView. self removeFromPackagesIconsCache: class package. sourceTextArea hasUnacceptedEdits ifFalse: [ self changed: #sourceCodeFrom: ]].! ! !AbstractNautilusUI methodsFor: 'system announcements' stamp: 'EstebanLorenzano 1/15/2013 16:32'! classRecategorized: anAnnouncement window ifNil: [ ^ self ]. window isDisplayed ifFalse: [ ^ self ]. self selectedClass = anAnnouncement classRecategorized ifTrue: [ self updateBothView ]! ! !AbstractNautilusUI methodsFor: 'system announcements' stamp: 'BenjaminVanRyseghem 2/16/2013 15:18'! classRemoved: anAnnouncement | class oldPackage | window ifNil: [ ^ self ]. window isDisplayed ifFalse: [ ^ self ]. class := anAnnouncement classRemoved. ((self showGroups and: [ self selectedGroup ifNil: [ ^self ] ifNotNil: [:gp | gp elements includes: class ]]) or: [ self getList2 includes: class ]) ifTrue: [ self selectedClass = class ifTrue: [ self selectedClass: nil ]. window isDisplayed ifFalse: [ ^ self ]. oldPackage := RPackageOrganizer default packageNamed: (anAnnouncement categoryName). self removeFromPackagesIconsCache: oldPackage. self updateBothView ]. ! ! !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: 'system announcements' stamp: 'GuillermoPolito 8/3/2012 13:22'! classReorganized: anAnnouncement window ifNil: [ ^ self ]. window isDisplayed ifFalse: [ ^ self ]. anAnnouncement classReorganized = self selectedClass ifTrue: [ self update ].! ! !AbstractNautilusUI methodsFor: 'system announcements'! methodAdded: anAnnouncement ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'system announcements'! methodModified: anAnnouncement ^ self subclassResponsibility ! ! !AbstractNautilusUI methodsFor: 'system announcements'! methodRecategorized: anAnnouncement ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'system announcements'! methodRemoved: anAnnouncement ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'system announcements'! packageChanged: anAnnouncement window isDisplayed ifFalse: [ ^ self ]. self showGroups not ifTrue: [ self updatePackageView ]! ! !AbstractNautilusUI methodsFor: 'system announcements' stamp: 'BenjaminVanRyseghem 12/20/2012 15:06'! packageCreated: anAnnouncement window ifNil: [ ^ self ]. window isDisplayed ifFalse: [ ^ self ]. self showGroups not ifTrue: [ self updatePackageView ]! ! !AbstractNautilusUI methodsFor: 'system announcements'! packageRenamed: anAnnouncement window isDisplayed ifFalse: [ ^ self ]. self showGroups not ifTrue: [ self updatePackageView ]! ! !AbstractNautilusUI methodsFor: 'system announcements'! packageUnregistred: anAnnouncement self showGroups not ifTrue: [ | package | package := anAnnouncement package. self selectedPackage = package ifTrue: [ self selectedPackage: nil ]. packagesSelection at: package put: false. window isDisplayed ifFalse: [ ^ self ]. self updatePackageView ]! ! !AbstractNautilusUI methodsFor: 'system announcements' stamp: 'BenjaminVanRyseghem 5/14/2012 12:17'! testCaseStarted: anAnnouncement | class selector | window ifNil: [ ^ self ]. window isDisplayed ifFalse: [ ^ self ]. class := anAnnouncement testCase class. selector := anAnnouncement testSelector. self selectedClass = class ifTrue: [| method correspondingClass icon | icon := self iconClass iconNamed: #testNotRun. method := class methodNamed: selector. correspondingClass := class correspondingClass. self methodWidget setIcon: icon for: method; updateList ]! ! !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: 'test creation'! buildTestClassDefinitionFrom: aClass ^ 'TestCase subclass: ', (self buildTestClassNameFrom: aClass) printString, ' instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: ''',(self buildTestPackageNameFrom:aClass),''''! ! !AbstractNautilusUI methodsFor: 'test creation'! buildTestClassNameFrom: aClass ^ (aClass name asString,'Test') asSymbol! ! !AbstractNautilusUI methodsFor: 'test creation'! buildTestPackageNameFrom:aClass ^ aClass package name asString, '-Tests' ! ! !AbstractNautilusUI methodsFor: 'test creation'! 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: testClass package. self selectedClass: testClass. self updateBothView. ^ testClass! ! !AbstractNautilusUI methodsFor: 'test creation'! createTestForSelectedClass self createTestForClass: self selectedClass! ! !AbstractNautilusUI methodsFor: 'test creation'! 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: 'widget - class'! classWidget ^ list2! ! !AbstractNautilusUI methodsFor: 'widget needed methods'! forceSelectedMethod: aMethod ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'widget needed methods'! selectedCategory ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'widget needed methods'! selectedCategory: anObject ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'widget needed methods'! selectedMethod ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'widget needed methods'! selectedMethod: aMethod ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'private'! 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'! addSubclassesOf: aClass in: result withIndex: index fromRestrictedCollection: aCollection | classes intersection | classes := aClass subclasses" intersection: self shownClasses". classes := classes intersection: aCollection. (classes sort: [:a :b| a name <= b name]) do: [:each | result at: each put: index. self addSubclassesOf: each in: result withIndex: index + 1 fromRestrictedCollection: aCollection ]! ! !AbstractNautilusUI methodsFor: 'private'! asYetUnclassifiedString ^ ClassOrganizer default! ! !AbstractNautilusUI methodsFor: 'private'! 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: 'private'! browseInstVars | cls | cls := self selectedClass. (cls notNil and: [cls isTrait not]) ifTrue: [ self systemNavigation browseInstVarRefs: cls ]. self changed: #isAClassSelected! ! !AbstractNautilusUI methodsFor: 'private'! browsedEnvironment ^ self model browsedEnvironment! ! !AbstractNautilusUI methodsFor: 'private'! buildGetterFor: aString ^ aString withFirstCharacterDownshifted,' ^ ', aString! ! !AbstractNautilusUI methodsFor: 'private'! buildGroupHierarchyFor: aGroup | coll1 | aGroup ifNil: [ ^ IdentityDictionary new ]. self browsedEnvironment isSystem ifTrue: [ coll1 := aGroup classes ] ifFalse:[ coll1 := aGroup classes intersection: self model classes ]. ^ self buildHierarchyForClasses: coll1! ! !AbstractNautilusUI methodsFor: 'private'! buildHierarchyFor: aClass ^ self buildHierarchyForClasses: aClass withAllSuperclasses, aClass allSubclasses! ! !AbstractNautilusUI methodsFor: 'private'! buildHierarchyForClasses: aCollection | result classes | result := IdentityDictionary new. classes := (aCollection collect: #theNonMetaClass) asSet. classes do: [:class || level | level := OrderedCollection with: class. class allSuperclassesDo: [:superClass | (classes includes: superClass) ifTrue: [ level add: superClass beforeIndex: 1 ]]. level addFirst: 'whatever you want here'. result at: class put: level ]. ^ result! ! !AbstractNautilusUI methodsFor: 'private'! buildHierarchyForClasses: aCollection fromPackage: aPackage | result classes | result := IdentityDictionary new. classes := aCollection asSet. classes do: [:class || level | level := OrderedCollection with: class. class allSuperclassesDo: [:superClass | (classes includes: superClass) ifTrue: [ level add: superClass beforeIndex: 1 ]]. (aPackage definedClasses includes: class) ifTrue: [ level addFirst: ' '] ifFalse: [ level addFirst: '']. result at: class put: level ]. ^ result! ! !AbstractNautilusUI methodsFor: 'private'! 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: 'private'! buildPackageHierarchyFor: aPackage | classes | classes := aPackage classes collect: #theNonMetaClass. self browsedEnvironment isSystem ifFalse: [ classes := classes intersection: self browsedEnvironment classes ]. ^ self buildHierarchyForClasses: classes fromPackage: aPackage! ! !AbstractNautilusUI methodsFor: 'private'! buildSetterFor: aString ^ aString withFirstCharacterDownshifted, ': anObject ', aString, ' := anObject'! ! !AbstractNautilusUI methodsFor: 'private'! buildTabbedNameOf: anElement | tab result size | tab := ' '. size := cachedHierarchy at: anElement ifPresent: [:p | p size - 2 ] ifAbsent: [ 0 ]. result := String new: (size * (tab size)) streamContents: [ :s| 1 to: size do: [:i | s nextPutAll: tab ]]. ^ self selectedPackage ifNil: [result, anElement name] ifNotNil: [:package | ( anElement package = package) ifTrue: [ (result, anElement name) asStringMorph ] ifFalse: [ (result , anElement name",' (', anElement package name,')'")asStringMorph color: self extensionColor;yourself]]! ! !AbstractNautilusUI methodsFor: 'private'! byteCodeSymbol ^ #ByteCode! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 6/13/2012 21:36'! changed: aSymbol super changed: aSymbol. self announce: (NautilusChanged symbol: aSymbol)! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/23/2012 18:57'! changedLabels "firstColumn label: self labelText." "secondColumn label: self labelText2."! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 1/6/2013 16:02'! classLabel ^'Class' asText allBold asMorph lock! ! !AbstractNautilusUI methodsFor: 'private'! commentLabel ^ 'Comments'! ! !AbstractNautilusUI methodsFor: 'private'! copyCategory: anObject toTheClass: aClass | originClass methods | originClass := self selectedClass. methods := originClass methodsInProtocol: anObject. methods do: [:meth | self copyMethod: meth toTheClass: aClass ].! ! !AbstractNautilusUI methodsFor: 'private'! copyMethod: aMethod toTheClass: aClass | newMethod shouldBeInstall | aMethod realClass = aClass ifTrue: [ ^ self ]. shouldBeInstall := aClass methodDict at: aMethod selector ifPresent: [:sel | " here I have to fork to release the drag & drop " [ (self openDialogWouldYouInstall: sel into: aClass) ifTrue: [ newMethod := aClass compile: aMethod sourceCode classified: aMethod category ]] fork. ] ifAbsent: [ newMethod := aClass compile: aMethod sourceCode classified: aMethod category]! ! !AbstractNautilusUI methodsFor: 'private'! decompileSymbol ^ #Decompile! ! !AbstractNautilusUI methodsFor: 'private'! extensionColor ^ Color gray darker! ! !AbstractNautilusUI methodsFor: 'private'! flashPackage ^ nil! ! !AbstractNautilusUI methodsFor: 'private'! getClassHierarchy self hierarchyClass ifNil: [^self getClassesList]. ^ cachedHierarchy keys sort: [:a :b | self sortClassesInCachedHierarchy: a b: b].! ! !AbstractNautilusUI methodsFor: 'private'! getClassHierarchy2 ^ self selectedPackage ifNil: [{}] ifNotNil:[:package | cachedHierarchy := self buildPackageHierarchyFor: package. cachedHierarchy keys sort: [:a :b | self sortClassesInCachedHierarchy: a b: b]]! ! !AbstractNautilusUI methodsFor: 'private'! getClassesList ^ self model classes! ! !AbstractNautilusUI methodsFor: 'private'! getClassesList2 ^ self model packagesUsedByTheSelectedClass! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'CamilloBruni 10/4/2012 10:46'! getGroupHierarchy ^ self selectedGroup ifNil: [ {} ] ifNotNil: [:group | cachedHierarchy := self buildGroupHierarchyFor: group. cachedHierarchy keys sort: [:a :b | self sortClassesInCachedHierarchy: a b: b]]! ! !AbstractNautilusUI methodsFor: 'private'! getGroupsKeyList | env | env := self browsedEnvironment. ^ env isSystem ifTrue: [ self groupsManager groups ] ifFalse: [ self groupsManager groups select: [:g | (g classes intersection: self model classes) isEmpty not ]]! ! !AbstractNautilusUI methodsFor: 'private'! getGroupsValuesList ^ self selectedGroup ifNil: [{}] ifNotNil: [:group | group classes ]! ! !AbstractNautilusUI methodsFor: 'private'! getList ^ listElements ifNil: [ listElements := self loadList ].! ! !AbstractNautilusUI methodsFor: 'private'! getList2 ^ list2Elements ifNil: [ list2Elements := self loadList2 ].! ! !AbstractNautilusUI methodsFor: 'private'! getPackagesList ^ self model packages sort: [:a :b | a name <= b name ]! ! !AbstractNautilusUI methodsFor: 'private'! getPackagesList2 ^ self model classesInTheSelectedPackage! ! !AbstractNautilusUI methodsFor: 'private'! giveFocusTo: aMorph self hasFocus ifTrue: [aMorph takeKeyboardFocus]! ! !AbstractNautilusUI methodsFor: 'private'! groupsLabel ^ 'Groups'! ! !AbstractNautilusUI methodsFor: 'private'! ifGroups: aBlock ifNot: anotherBlock ^self showGroups ifTrue: aBlock ifFalse: anotherBlock! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 2/8/2013 16:30'! initialize super initialize. cachedHierarchy := IdentityDictionary new. groupsSelection := Dictionary new. packagesSelection := Dictionary new. classesSelection := Dictionary new. shouldUpdateTitle := true. testSemaphore := Semaphore new. sourceTextAreas := OrderedCollection new. contentSelection := nil.! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/25/2012 18:00'! instanceLabel ^'Instance' asMorph! ! !AbstractNautilusUI methodsFor: 'private'! isAClassSelected ^ self selectedClass notNil! ! !AbstractNautilusUI methodsFor: 'private'! listElement2: anIndex ^ self getList2 at: anIndex! ! !AbstractNautilusUI methodsFor: 'private'! listElement: anIndex ^ self getList at: anIndex! ! !AbstractNautilusUI methodsFor: 'private'! listSize ^ self getList size.! ! !AbstractNautilusUI methodsFor: 'private'! listSize2 ^ self getList2 size.! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/23/2012 19:57'! listWrapper2: anElement "anElement is a Class" ^ self showHierarchy ifTrue: [ self buildTabbedNameOf: anElement ] ifFalse: [ self selectedPackage ifNil: [anElement name] ifNotNil: [:package | ( anElement package = package) ifTrue: [ anElement name asStringMorph ] ifFalse: [ anElement name asStringMorph color: self extensionColor;yourself]]]! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/23/2012 19:23'! loadList ^ self ifGroups: [ self getGroupsKeyList ] ifNot:[ self getPackagesList ]! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/23/2012 19:23'! 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 keys sort: [:a :b | self sortClassesInCachedHierarchy: a b: b ]]]]! ! !AbstractNautilusUI methodsFor: 'private'! methodsForCategories: aCollection ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'private'! methodsForCategory: aCategory ^ self subclassResponsibility! ! !AbstractNautilusUI methodsFor: 'private'! 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 removeCategory: anObject. self selectedCategory: nil ].! ! !AbstractNautilusUI methodsFor: 'private'! moveMethod: aMethod toTheClass: aClass autoRemove: autoRemove | newMethod shouldBeInstall | aMethod realClass = aClass ifTrue: [ ^ self ]. shouldBeInstall := 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. newMethod := aClass compile: aMethod sourceCode classified: oldCategory. self selectedMethod: nil. originClass removeSelector: aMethod selector. autoRemove ifTrue: [ ( originClass methodsInProtocol:oldCategory ) ifEmpty: [ originClass removeCategory: oldCategory ]]]] fork] ifAbsent: [ | originClass oldCategory | oldCategory := aMethod category. originClass := aMethod realClass. newMethod := aClass compile: aMethod sourceCode classified: oldCategory. self selectedMethod: nil. originClass removeSelector: aMethod selector. autoRemove ifTrue: [ ( originClass methodsInProtocol: oldCategory ) ifEmpty: [ originClass removeCategory: oldCategory ]]]! ! !AbstractNautilusUI methodsFor: 'private'! noMethodsString ^ ClassOrganizer nullCategory! ! !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'! packageLabel ^'Packages'! ! !AbstractNautilusUI methodsFor: 'private'! popUpTestsResult: aClass! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'SeanDeNigris 2/5/2013 10:51'! renamePackage: anRPackage | isCurrent | isCurrent := anRPackage = self selectedPackage. super renamePackage: anRPackage. isCurrent ifTrue: [ self selectedPackage: anRPackage ]. packagesSelection at: anRPackage put: true.! ! !AbstractNautilusUI methodsFor: 'private'! resetListSelection self listSelection removeAll.! ! !AbstractNautilusUI methodsFor: 'private'! resetListSelection2 self listSelection2 removeAll.! ! !AbstractNautilusUI methodsFor: 'private'! rootsOf: aPackage | tmpList | tmpList := aPackage definedClasses. self browsedEnvironment isSystem ifFalse: [ tmpList := self model classes intersection: tmpList ]. ^ tmpList select: [:each | (tmpList includes: (each superclass)) not]! ! !AbstractNautilusUI methodsFor: 'private'! rootsOfGroup: aGroup | classes | self browsedEnvironment isSystem ifTrue: [ classes := aGroup elements ] ifFalse: [ classes := aGroup elements intersection: self model classes ]. ^ classes select: [:each | (classes includes: each superclass) not]! ! !AbstractNautilusUI methodsFor: 'private'! 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: 'private' stamp: 'BenjaminVanRyseghem 4/20/2012 00:31'! 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: '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: 'private' stamp: 'BenjaminVanRyseghem 2/16/2013 14:36'! runTestsOfClass: aClass notifying: aBoolean | methods blockToEvaluate | methods := aClass methodDict values select: [ :method | method isTestMethod ] thenCollect: [:e | e selector ]. blockToEvaluate := [ |result | 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: 'private'! selectedClasses | associations | associations := classesSelection associations select: [:assoc | assoc value ]. associations := associations collect: [:assoc | assoc key ]. ^ associations select: [:each | each notNil ]! ! !AbstractNautilusUI methodsFor: 'private'! selectedGroups | associations | associations := groupsSelection associations select: [:assoc | assoc value ]. associations := associations collect: [:assoc | assoc key ]. ^ associations select: [:each | each notNil ]! ! !AbstractNautilusUI methodsFor: 'private'! selectedItems | associations | associations := self listSelection associations select: [:assoc | assoc value ]. ^ associations collect: [:assoc | assoc key ].! ! !AbstractNautilusUI methodsFor: 'private'! selectedPackages | associations | associations := packagesSelection associations select: [:assoc | assoc value ]. associations := associations collect: [:assoc | assoc key ]. ^ associations select: [:each | each notNil ]! ! !AbstractNautilusUI methodsFor: 'private'! setCachedHierarchyClass: aClass cachedHierarchy := self buildHierarchyFor: aClass.! ! !AbstractNautilusUI methodsFor: 'private'! showByteCode ^ self currentDisplayChoice = self byteCodeSymbol! ! !AbstractNautilusUI methodsFor: 'private'! showSource ^ self currentDisplayChoice = self sourceCodeSymbol! ! !AbstractNautilusUI methodsFor: 'private'! 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! ! !AbstractNautilusUI methodsFor: 'private'! sourceCodeSymbol ^ #SourceCode! ! !AbstractNautilusUI methodsFor: 'private'! systemNavigation ^ SystemNavigation new browsedEnvironment: self browsedEnvironment; yourself! ! !AbstractNautilusUI methodsFor: 'private'! textMorphClass ^ PluggableTextMorphWithLimits! ! !AbstractNautilusUI methodsFor: 'private'! title ^'Nautilus'! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/7/2012 15:06'! updateBothView listElements := nil. list2Elements := nil. self changed: #listElement:. self changed: #listElement2:! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/7/2012 15:06'! updateClassView list2Elements := nil. self changed: #listElement2: ! ! !AbstractNautilusUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/7/2012 15:06'! updateGroupView listElements := nil. self changed: #listElement:! ! !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: 'private' stamp: 'BenjaminVanRyseghem 5/7/2012 15:06'! updatePackageViewAndMove listElements := nil. self changed: #listElement:! ! !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: 'private'! warningLimit ^ self model ifNil: [ 350 ] ifNotNil: [:mod | model warningLimit ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbstractNautilusUI class instanceVariableNames: ''! !AbstractNautilusUI class methodsFor: 'accessing'! classesIconsCache: anObject ClassesIconsCache := anObject! ! !AbstractNautilusUI class methodsFor: 'accessing'! groupsIconsCache ^ GroupsIconsCache! ! !AbstractNautilusUI class methodsFor: 'accessing'! groupsIconsCache: anObject GroupsIconsCache := anObject! ! !AbstractNautilusUI class methodsFor: 'accessing'! icon ^ Icon! ! !AbstractNautilusUI class methodsFor: 'accessing'! icon: anObject Icon := anObject! ! !AbstractNautilusUI class methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/24/2012 17:55'! nextFocusKey ^ NextFocusKey! ! !AbstractNautilusUI class methodsFor: 'accessing'! packagesIconsCache ^ PackagesIconsCache! ! !AbstractNautilusUI class methodsFor: 'accessing'! packagesIconsCache: anObject PackagesIconsCache := anObject! ! !AbstractNautilusUI class methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/25/2012 11:08'! previousFocusKey ^ PreviousFocusKey! ! !AbstractNautilusUI class methodsFor: 'icon'! buildIcon | bitmap | bitmap := (Bitmap new: 256) copyFromByteArray: #[0 0 0 0 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 255 249 235 15 254 248 233 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 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 183 102 33 13 162 147 126 14 199 176 153 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 143 187 142 101 94 197 140 89 0 0 0 0 208 181 135 93 108 190 134 85 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 144 159 121 84 174 168 127 90 119 181 140 104 194 182 128 81 24 207 148 99 4 252 255 255 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 159 170 119 70 255 200 124 58 253 189 122 63 60 148 118 91 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 199 157 91 59 255 222 129 64 255 201 118 48 178 152 100 49 73 138 112 54 106 168 135 62 167 206 169 100 193 191 158 105 115 172 143 97 0 0 0 0 5 155 136 98 55 204 190 157 10 236 223 187 0 0 0 0 21 105 87 68 91 162 123 78 240 187 126 60 255 212 131 43 253 227 148 48 255 218 157 63 255 233 175 78 255 235 176 64 255 224 167 68 255 232 171 81 255 216 168 74 109 181 145 85 21 154 136 98 245 194 174 137 33 211 209 190 81 172 145 107 241 194 152 81 255 207 158 80 255 243 176 64 254 246 176 67 254 208 141 49 255 221 156 81 255 200 123 54 255 209 137 56 255 187 124 56 254 204 128 48 255 248 183 62 230 171 125 65 0 0 0 0 198 196 161 122 135 198 161 130 238 191 139 90 255 227 158 63 254 234 165 51 254 244 172 65 255 227 160 65 254 170 105 26 255 209 144 65 254 185 117 40 253 213 143 55 252 221 143 58 248 238 144 58 255 223 134 39 250 163 97 51 20 231 255 255 185 186 137 106 255 181 122 80 255 162 85 36 255 221 124 53 255 234 154 50 255 234 170 61 255 232 168 69 255 220 149 53 255 238 159 56 255 241 163 59 255 231 158 59 255 226 151 64 255 198 120 54 215 166 91 43 57 133 68 38 13 210 220 210 83 199 158 129 209 203 160 125 129 184 139 102 235 161 83 47 255 190 102 41 255 203 112 40 255 208 117 47 253 213 121 50 251 208 122 55 222 185 106 44 175 159 100 50 139 141 103 65 53 156 105 65 9 99 69 79 0 0 0 0 0 0 0 0 0 0 0 0 143 155 129 114 0 0 0 0 10 138 135 170 65 108 49 22 87 138 77 48 93 129 70 41 45 93 34 6 26 68 32 26 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 197 179 174 0 0 0 0 93 197 180 176 4 202 182 170 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 180 88 18 2 146 92 49 1 128 100 73 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0]. ^ Form extent: 16@16 depth: 32 bits: bitmap! ! !AbstractNautilusUI class methodsFor: 'icon'! iconClass ^ NautilusIcons! ! !AbstractNautilusUI class methodsFor: 'icon' stamp: 'EstebanLorenzano 2/4/2013 17:54'! resetClassesIconsCache ClassesIconsCache removeAll. ! ! !AbstractNautilusUI class methodsFor: 'icon'! resetIcon Icon := nil! ! !AbstractNautilusUI class methodsFor: 'icon'! resetIconCaches ClassesIconsCache removeAll. GroupsIconsCache removeAll. PackagesIconsCache removeAll.! ! !AbstractNautilusUI class methodsFor: 'instance creation'! on: aNautilus ^ self new model: aNautilus! ! !AbstractNautilusUI class methodsFor: 'menu' stamp: 'EstebanLorenzano 2/6/2013 16:33'! buildAnalyzeSubMenu: aBuilder | target | target := aBuilder model. target selectedClass ifNil: [^target]. (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. (aBuilder item: #'Browse comment versions...') action: [ target browseCommentVersionsOf: target selectedClass theNonMetaClass ]; parent: #Analyze; order: 600; withSeparatorAfter. (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.! ! !AbstractNautilusUI class methodsFor: 'menu' stamp: 'EstebanLorenzano 2/6/2013 15: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 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: 'menu' stamp: 'EstebanLorenzano 2/6/2013 16:31'! 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'. (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: (target iconClass 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: 'menu' stamp: 'EstebanLorenzano 1/31/2013 18:46'! debugMenu: aBuilder | target | target := aBuilder model. (aBuilder item: #DebugMenu) order: 9999; label: 'DEBUG'; help: 'Open a browser on a restricted view'. (aBuilder item: #'Reset icons caches') order: 0; action: [ AbstractNautilusUI resetIconCaches. AbstractMethodWidget resetMethodsIconsCache ]; parent: #DebugMenu; help: 'Open a browser on a restricted view'. (aBuilder item: #'Inspect me') order: 100; action: [ target inspect ]; parent: #DebugMenu; help: 'Open a browser on a restricted view'. (aBuilder item: #'Inspect my model ') order: 200; action: [ target model inspect]; parent: #DebugMenu; help: 'Open a browser on a restricted view'.! ! !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: 'menu' stamp: 'EstebanLorenzano 2/6/2013 14:53'! 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 isNil ifFalse: [ 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: (target iconClass iconNamed: #removeIcon); action: [target removeGroups]; order: 1400 ] ]! ! !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: 'menu' stamp: 'EstebanLorenzano 2/6/2013 16:20'! 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: (target iconClass 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: #'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: '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: '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: '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: '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: '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 16:41'! 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 cancel ]. (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: '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: '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: '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: 'shortcuts' stamp: 'EstebanLorenzano 1/30/2013 14:22'! 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: #addInGroupMethod) category: #NautilusGlobalShortcuts default: $n command , $e command, $m command do: [ :target | target addMethodsInGroup ] description: 'Add the selected methods 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: '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: 'shortcuts' stamp: 'EstebanLorenzano 1/30/2013 14:23'! 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: '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: '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 8/1/2012 19:13'! 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 cancel ]. (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/24/2012 19:10'! 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 cancel ]. (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 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: '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: '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: '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: '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: '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: 'BenjaminVanRyseghem 6/28/2012 14:53'! 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: '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: 'private' stamp: 'BenjaminVanRyseghem 4/25/2012 11:07'! initialize " self initialize " ClassesIconsCache := WeakIdentityKeyDictionary new. GroupsIconsCache := WeakIdentityKeyDictionary new. PackagesIconsCache := WeakIdentityKeyDictionary new. Icon := self buildIcon. NextFocusKey := Character arrowRight. PreviousFocusKey := Character arrowLeft.! ! TestCase subclass: #AbstractNautilusUITest instanceVariableNames: 'model' classVariableNames: '' poolDictionaries: '' category: 'Nautilus-Tests'! !AbstractNautilusUITest commentStamp: '' prior: 0! An AbstractNautilusUITest is a test class for testing the behavior of AbstractNautilusUI! !AbstractNautilusUITest methodsFor: 'initialization'! setUp "Setting up code for AbstractNautilusUITest" model := AbstractNautilusUI new.! ! !AbstractNautilusUITest methodsFor: 'initialization'! tearDown "Tearing down code for AbstractNautilusUITest" ! ! !AbstractNautilusUITest methodsFor: 'tests'! testSortClassesInCachedHierarchyB! ! Object subclass: #AbstractObjectsAsMethod instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-ObjectsAsMethods'! !AbstractObjectsAsMethod methodsFor: 'compatibility' stamp: 'md 3/1/2006 14:25'! flushCache! ! !AbstractObjectsAsMethod methodsFor: 'compatibility' stamp: 'md 3/1/2006 14:23'! methodClass: aMethodClass! ! !AbstractObjectsAsMethod methodsFor: 'compatibility' stamp: 'MarcusDenker 2/11/2013 16:06'! origin ^self class! ! !AbstractObjectsAsMethod methodsFor: 'compatibility' stamp: 'MarcusDenker 2/11/2013 15:34'! pragmas ^#()! ! !AbstractObjectsAsMethod methodsFor: 'compatibility' stamp: 'md 3/1/2006 14:23'! selector: aSymbol! ! AbstractNautilusPlugin subclass: #AbstractPackageSelectedPlugin instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Plugin'! !AbstractPackageSelectedPlugin commentStamp: '' prior: 0! AbstractKeyPressedPlugin is an abstraction of plugin which react when a package is selected! !AbstractPackageSelectedPlugin methodsFor: 'announcement' stamp: 'BenjaminVanRyseghem 5/10/2011 14:39'! packageSelected: anAnnouncement ^ self subclassResponsibility! ! !AbstractPackageSelectedPlugin methodsFor: 'registration' stamp: 'BenjaminVanRyseghem 5/10/2011 12:35'! registerTo: aModel aModel announcer on: NautilusPackageSelected send: #packageSelected: to: self! ! AbstractWidget subclass: #AbstractPackageWidget instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Nautilus-Widgets'! !AbstractPackageWidget commentStamp: '' prior: 0! AbstractPackageWidget is an abstraction describing a widget used to manage packages! Morph subclass: #AbstractResizerMorph instanceVariableNames: 'dotColor handleColor lastMouse' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Windows'! !AbstractResizerMorph commentStamp: 'jmv 1/29/2006 17:15' prior: 0! 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/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: 'jrp 7/5/2005 21:37'! handlesMouseOver: anEvent ^ true ! ! !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: '*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: '*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: '*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: 'actions' stamp: 'jrp 7/5/2005 21:36'! dotColor ^ dotColor ifNil: [self setDefaultColors. dotColor]! ! !AbstractResizerMorph methodsFor: 'actions' stamp: 'jrp 7/5/2005 21:35'! handleColor ^ handleColor ifNil: [self setDefaultColors. handleColor]! ! !AbstractResizerMorph methodsFor: 'actions' stamp: 'jrp 7/5/2005 21:37'! resizeCursor self subclassResponsibility! ! !AbstractResizerMorph methodsFor: 'actions' stamp: 'jrp 7/29/2005 13:25'! setDefaultColors handleColor := Color lightGray lighter lighter. dotColor := Color gray lighter! ! !AbstractResizerMorph methodsFor: 'actions' stamp: 'jrp 7/30/2005 21:30'! setInverseColors handleColor := Color lightGray. dotColor := Color white! ! !AbstractResizerMorph methodsFor: 'event handling' stamp: 'jrp 7/5/2005 21:37'! handlesMouseDown: anEvent ^ true! ! !AbstractResizerMorph methodsFor: 'event handling' stamp: 'jrp 7/5/2005 21:42'! mouseDown: anEvent lastMouse := anEvent cursorPoint! ! !AbstractResizerMorph methodsFor: 'initialize' stamp: 'md 2/24/2006 23:01'! initialize super initialize. self color: Color transparent! ! !AbstractResizerMorph methodsFor: 'testing' stamp: 'jrp 7/5/2005 21:40'! isCursorOverHandle ^ true! ! Object subclass: #AbstractSoundSystem instanceVariableNames: '' classVariableNames: 'SoundEnabled SoundQuickStart' poolDictionaries: '' category: 'System-Sound'! !AbstractSoundSystem commentStamp: 'AlainPlantec 1/7/2010 21:36' prior: 0! This is the abstract base class for a sound system. A sound system offers a small protocol for playing sounds and making beeps and works like a facade towards the rest of Squeak. A sound system is registered in the application registry SoundService and can be accessed by "SoundService default" like for example: SoundService default playSoundNamed: 'croak' The idea is that as much sound playing as possible should go through this facade. This way we decouple the sound system from the rest of Squeak and make it pluggable. It also is a perfect spot to check for the SoundSettings class>>soundEnabled Two basic subclasses exist at the time of this writing, the BaseSoundSystem which represents the standard Squeak sound system, and the DummySoundSystem which is a dummy implementation that can be used when there is no sound card available, or when the base sound system isn't in the image, or when you simply don't want to use the available sound card.! !AbstractSoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:52'! randomBitsFromSoundInput: bitCount self subclassResponsibility! ! !AbstractSoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:52'! sampledSoundChoices self subclassResponsibility! ! !AbstractSoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:53'! shutDown "Default is to do nothing."! ! !AbstractSoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:56'! soundNamed: soundName self subclassResponsibility! ! !AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/24/2004 23:27'! beep "Make a primitive beep." self subclassResponsibility! ! !AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:47'! playSampledSound: samples rate: rate self subclassResponsibility! ! !AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:50'! playSoundNamed: soundName self subclassResponsibility! ! !AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:51'! playSoundNamed: soundName ifAbsentReadFrom: aifFileName self subclassResponsibility! ! !AbstractSoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:51'! playSoundNamedOrBeep: soundName self subclassResponsibility! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbstractSoundSystem class instanceVariableNames: ''! !AbstractSoundSystem class methodsFor: 'preference access' stamp: 'StephaneDucasse 1/30/2011 21:31'! soundEnabled ^ SoundEnabled ifNil: [SoundEnabled := false]! ! !AbstractSoundSystem class methodsFor: 'preference access' stamp: 'StephaneDucasse 1/30/2011 21:31'! soundEnabled: aBoolean SoundEnabled := aBoolean! ! !AbstractSoundSystem class methodsFor: 'preference access' stamp: 'StephaneDucasse 1/30/2011 21:31'! soundQuickStart ^ SoundQuickStart ifNil: [SoundQuickStart := false]! ! !AbstractSoundSystem class methodsFor: 'preference access' stamp: 'StephaneDucasse 1/30/2011 21:31'! soundQuickStart: aBoolean SoundQuickStart := aBoolean! ! Object subclass: #AbstractSpec instanceVariableNames: 'instance bindings' classVariableNames: '' poolDictionaries: '' category: 'Spec-Core-Specs'! !AbstractSpec commentStamp: '' prior: 0! An AbstractSpec is a basic wrapper which describe a spec. For now it can seems useless, but structural info will be stored thanks to those wrappers! !AbstractSpec methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/24/2012 00:51'! bindings ^ bindings! ! !AbstractSpec methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/24/2012 00:51'! bindings: anObject bindings := anObject! ! !AbstractSpec methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/24/2012 01:19'! instance ^ instance ifNil: [ instance := self initializeInstance. ]! ! !AbstractSpec methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/24/2012 02:24'! instance: anObject instance := anObject! ! !AbstractSpec methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 4/24/2012 10:47'! initialize "Initialization code for AbstractSpec" super initialize. bindings := BindingsHolder new.! ! !AbstractSpec methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/6/2012 18:39'! addAsSubSpecTo: anotherSpec anotherSpec addSubSpec: self.! ! !AbstractSpec methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 03:14'! model: aModel "nothing by default"! ! !AbstractSpec methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2012 11:18'! removeSubWidgets ^ SpecInterpreter interpretASpec: #(model removeSubWidgets) model: self instance! ! !AbstractSpec methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/6/2012 20:42'! subSpecs ^ #()! ! !AbstractSpec methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/24/2012 01:22'! classSymbol self subclassResponsibility! ! !AbstractSpec methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/24/2012 10:47'! defaultReceiver ^ Smalltalk at: (self bindings retrieveClassSymbolFor: (self classSymbol))! ! !AbstractSpec methodsFor: 'private' stamp: 'BenjaminVanRyseghem 12/12/2012 15:19'! initializeInstance ^ SpecInterpreter private_interpretASpec: { self classSymbol. #color:. #(Color class white)} model: DummyComposableModel new! ! Object subclass: #AbstractSpecLayoutAction instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Spec-Layout'! !AbstractSpecLayoutAction commentStamp: '' prior: 0! AbstractSpecLayoutAction is an abstract class representing a spec layout action.! !AbstractSpecLayoutAction methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/18/2012 04:47'! asSpecElements self subclassResponsibility ! ! !AbstractSpecLayoutAction methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/31/2012 15:10'! generateArguments ! ! AbstractNautilusPlugin subclass: #AbstractTextChangedPlugin instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Plugin'! !AbstractTextChangedPlugin commentStamp: '' prior: 0! 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! ! Model subclass: #AbstractTool instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tools-Base'! !AbstractTool commentStamp: '' prior: 0! I'm an abstract class grouping generic methods for managing packages/classes/groups/methods from a browser! !AbstractTool methodsFor: '*necompletion-extensions' stamp: 'EstebanLorenzano 4/23/2012 13:48'! guessTypeForName: aString ^nil! ! !AbstractTool methodsFor: '*necompletion-extensions' stamp: 'EstebanLorenzano 4/12/2012 13:20'! isCodeCompletionAllowed ^true! ! !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 8/21/2011 17:50'! removeCategory: aCategory inClass: aClass aCategory ifNil: [ ^ self ]. self okToChange ifFalse: [ ^ self ]. (aClass organization listAtCategoryNamed: aCategory) isEmpty ifTrue: [ aClass removeCategory: aCategory. ^ true ]. (self confirm: 'Are you sure you want to remove the protocol ', aCategory,' and all its methods?') ifTrue: [ aClass removeCategory: aCategory. ^ true ]. ^ false! ! !AbstractTool methodsFor: 'category' stamp: 'BenjaminVanRyseghem 4/13/2011 13:10'! removeEmptyCategoriesFrom: aClass aClass organization removeEmptyCategories.! ! !AbstractTool methodsFor: 'category' stamp: 'BenjaminVanRyseghem 2/20/2012 17:15'! 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" | oldIndex oldName newName | aClass ifNil: [^ nil]. aCategory ifNil: [^ nil]. oldName := aCategory. newName := UIManager default request: 'Please type new category name' initialAnswer: oldName. newName isEmptyOrNil ifTrue: [^ nil ] ifFalse: [newName := newName asSymbol]. newName = oldName ifTrue: [^ nil ]. aClass organization renameCategory: oldName toBe: newName. ^ newName! ! !AbstractTool methodsFor: 'class' stamp: 'BenjaminVanRyseghem 4/13/2011 12:12'! addCategoryIn: aClass self addCategoryIn: aClass before: nil! ! !AbstractTool methodsFor: 'class' stamp: 'BenjaminVanRyseghem 5/5/2011 14:48'! 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" | labels reject lines oldIndex newName | labels := OrderedCollection new. reject := Set new. reject addAll: aClass organization categories; add: ClassOrganizer nullCategory; add: ClassOrganizer default. lines := OrderedCollection new. aClass 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 asSortedCollection. reject addAll: cats ]]]. newName := UIManager default chooseOrRequestFrom: labels lines: lines title: 'Add Category'. newName ifNil: [ ^ nil ]. newName := newName asSymbol. aClass organization addCategory: newName before: aCategory. self selectedCategory: newName. ^ newName! ! !AbstractTool methodsFor: 'class' stamp: 'StephaneDucasse 9/7/2011 21:22'! 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 ifNil: [ 'Unknown' ]. classDefinition := 'Object subclass: #' , classSymbol , ' instanceVariableNames: '''' classVariableNames: '''' poolDictionaries: '''' category: ''' , systemCategory name , ''''. classDefinition := UIManager default multiLineRequest: 'Define class definition:' initialAnswer: classDefinition answerHeight: 250. (classDefinition isNil or: [ classDefinition isEmpty ]) ifTrue: [ ^ self ]. self class evaluatorClass evaluate: classDefinition.! ! !AbstractTool methodsFor: 'class' stamp: 'StephaneDucasse 9/7/2011 21:22'! addTraitIn: 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 ifNil: [ 'Unknown' ]. classDefinition := 'Trait named: #TSortable uses: {} category: ''' , systemCategory name , ''''. classDefinition := UIManager default multiLineRequest: 'Define class definition:' initialAnswer: classDefinition answerHeight: 250. (classDefinition isNil or: [ classDefinition isEmpty ]) ifTrue: [ ^ self ]. self class evaluatorClass evaluate: classDefinition.! ! !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: '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: 'VeronicaUquillas 9/3/2011 20:46'! browseCommentVersionsOf: aRGCommentDefinition ClassCommentVersionsBrowser browseCommentOf: aRGCommentDefinition realClass! ! !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: 'BenjaminVanRyseghem 4/13/2011 12:29'! browseInstVarRefsOf: aClass (aClass notNil and: [aClass isTrait not]) ifTrue: [self systemNavigation browseInstVarRefs: aClass]! ! !AbstractTool methodsFor: 'class' stamp: 'BenjaminVanRyseghem 9/28/2011 18:37'! 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 methodDict at: sel) methodReference) ]]. self systemNavigation browseMessageList: messageList name: 'Unsent Methods in ' , aClass name! ! !AbstractTool methodsFor: 'class' stamp: 'BenjaminVanRyseghem 10/7/2011 14:00'! 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 evaluate: aString notifying: aController logged: true. ^ (class isKindOf: Behavior) ifTrue: [ class ] ifFalse: [ nil ]! ! !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: '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: '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: 'jeanbaptistearnaud 2/8/2013 13:38'! 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 evaluatorClass evaluate: defString notifying: aController logged: true. ^ trait! ! !AbstractTool methodsFor: 'class' stamp: 'BenjaminVanRyseghem 5/3/2011 11:27'! fileOutClasses: aCollection "Print a description of the selected class onto a file whose name is the category name followed by .st." Cursor write showWhile: [ aCollection ifNotEmpty: [ aCollection do: [:class | class theNonMetaClass fileOut ]]]! ! !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: 'class' stamp: 'BenjaminVanRyseghem 4/13/2011 16:15'! 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 | classToRemove := aClass ifNil: [Beeper beep. ^ 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: 'class' stamp: 'BenjaminVanRyseghem 2/26/2012 23:55'! 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 | aCollection isEmptyOrNil ifTrue: [ Beeper beep. ^ 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: '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: '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: '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: 'group' stamp: 'BenjaminVanRyseghem 1/24/2013 15:17'! alertGroupExisting: name UIManager default alert: 'The group named ', name, ' already exists' title: 'Already exists'! ! !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: '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: 'method' stamp: 'BenjaminVanRyseghem 2/7/2012 09:20'! 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: #browseAllCallsOn: to: self systemNavigation with: {} selector: aSelector! ! !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: 'method' stamp: 'StephaneDucasse 5/28/2011 13:19'! 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 reject lines oldIndex newName | aCollection ifEmpty: [^ self]. aClass ifNil: [^self]. labels := OrderedCollection new. labels addAll: aClass organization categories copy sort; add: ClassOrganizer default. 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: '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: '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: 'method' stamp: 'BenjaminVanRyseghem 4/13/2011 12:52'! fileOutMethods: aCollection Cursor write showWhile:[ aCollection ifNotEmpty: [:methods | methods do: [:method | method methodClass fileOutMethod: method selector ]]]! ! !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: '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: '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: '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: '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: 'method' stamp: 'BenjaminVanRyseghem 2/24/2012 02:50'! 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 browseAllCallsOn: messageName]. ^ true! ! !AbstractTool methodsFor: 'method' stamp: 'BenjaminVanRyseghem 2/24/2012 21:21'! 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 browseAllCallsOn: messageName ]]]. ^ true! ! !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: 'method'! 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: '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: 'method' stamp: 'BenjaminVanRyseghem 3/25/2012 20:58'! 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: #browseAllCallsOn: to: self systemNavigation with: {} selector: aSelector! ! !AbstractTool methodsFor: 'method'! 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: '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: '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: 'package' stamp: 'BenjaminVanRyseghem 2/27/2012 23:44'! addPackagesAsGroup: aCollection aCollection ifNotEmpty: [| packages list blocks name | packages := aCollection sort: [:a :b | a name <= b name ]. blocks := OrderedCollection new. packages do: [:package | blocks add: [ package orderedClasses]]. name := ( packages collect: [:package | package name]) joinUsing: ' + '. ^ (self groupsManager addADynamicClassGroupNamed: name blocks: blocks)]! ! !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: 'package' stamp: 'BenjaminVanRyseghem 1/24/2013 18:22'! 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: [ (GroupsAlreadyExists groupName: name) signal ]. ^ firstGroup ]. ^ 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: 'package' stamp: 'BenjaminVanRyseghem 4/13/2011 12:52'! fileOutPackages: aCollection Cursor write showWhile:[ aCollection ifNotEmpty: [ aCollection do: [:package | package fileOut ]]]! ! !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: 'package' stamp: 'BenjaminVanRyseghem 2/5/2013 14:04'! isValidPackageName: name ^ (name isNil or: [ name isEmpty or: [ name first = $* ]]) not! ! !AbstractTool methodsFor: 'package' stamp: 'SeanDeNigris 2/5/2013 10:54'! renamePackages: aCollection | name | aCollection ifNotEmpty: [ :packages | packages do: [ :selectedPackage | self renamePackage: selectedPackage ] ].! ! !AbstractTool methodsFor: 'private' stamp: 'SeanDeNigris 2/5/2013 10:56'! 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 class instanceVariableNames: ''! !AbstractTool class methodsFor: 'world menu' stamp: 'EstebanLorenzano 4/26/2012 14:03'! menuCommandOn: aBuilder (aBuilder item: #Tools) order: 1.0; target: self; icon: (self theme iconNamed: #toolsIcon). ! ! !AbstractTool class methodsFor: 'world menu' stamp: 'MarcusDenker 8/15/2011 16:34'! theme ^ UITheme current! ! Model subclass: #AbstractWidget instanceVariableNames: 'model iconClass' classVariableNames: '' poolDictionaries: '' category: 'Nautilus-Widgets'! !AbstractWidget commentStamp: '' prior: 0! AbstractWidget is an abstraction for the different widget which could be used to compose the Nautilus UI! !AbstractWidget methodsFor: 'accessing'! iconClass ^ self model iconClass! ! !AbstractWidget methodsFor: 'accessing'! iconClass: anObject iconClass := anObject! ! !AbstractWidget methodsFor: 'accessing'! model ^ model! ! !AbstractWidget methodsFor: 'accessing'! 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 methodsFor: 'update'! update: aSymbol self changed: aSymbol! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AbstractWidget class instanceVariableNames: ''! !AbstractWidget class methodsFor: 'instance creation'! model: model ^ self new model: model; yourself! ! AbstractDescription subclass: #AddClassDescription instanceVariableNames: 'category name' classVariableNames: '' poolDictionaries: '' category: 'Spec-Builder'! !AddClassDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 07:12'! category ^ category! ! !AddClassDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 07:12'! category: anObject category := anObject! ! !AddClassDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 07:13'! newClassName ^ name! ! !AddClassDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 07:13'! newClassName: anObject name := anObject! ! !AddClassDescription methodsFor: 'processing' stamp: 'BenjaminVanRyseghem 2/27/2012 07:45'! generateSpec ^ { #subclass:category:. self newClassName asSymbol. self category} ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AddClassDescription class instanceVariableNames: ''! !AddClassDescription class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 2/27/2012 07:38'! category: ctgr name: newClassName ^ self new category: ctgr; newClassName: newClassName; yourself! ! AbstractDescription subclass: #AddInstVarDescription instanceVariableNames: 'name type' classVariableNames: '' poolDictionaries: '' category: 'Spec-Builder'! !AddInstVarDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 06:41'! name ^ name! ! !AddInstVarDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 06:40'! name: anObject name := anObject! ! !AddInstVarDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/28/2012 13:55'! type ^ type! ! !AddInstVarDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/28/2012 13:55'! type: anObject type := anObject! ! !AddInstVarDescription methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 2/27/2012 06:48'! initialize "Initialization code for AddInstVarDescription" super initialize. name := ''.! ! !AddInstVarDescription methodsFor: 'processing' stamp: 'BenjaminVanRyseghem 3/5/2012 05:51'! generateSpec ^ { #addInstVarNamed:type:. self name. self type }! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AddInstVarDescription class instanceVariableNames: ''! !AddInstVarDescription class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 2/28/2012 13:56'! name: newName ^ self name: newName type: Object! ! !AddInstVarDescription class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 2/28/2012 13:56'! name: newName type: type ^ self new name: newName; type: type; yourself! ! AbstractDescription subclass: #AddIntoMethodDescription instanceVariableNames: 'code order selector' classVariableNames: '' poolDictionaries: '' category: 'Spec-Builder'! !AddIntoMethodDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 07:09'! code ^ code! ! !AddIntoMethodDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 07:09'! code: anObject code := anObject! ! !AddIntoMethodDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 07:09'! order ^ order! ! !AddIntoMethodDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 07:09'! order: anObject order := anObject! ! !AddIntoMethodDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 07:09'! selector ^ selector! ! !AddIntoMethodDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 07:09'! selector: anObject selector := anObject! ! !AddIntoMethodDescription methodsFor: 'processing' stamp: 'BenjaminVanRyseghem 2/27/2012 08:00'! generateSpec ^ { #addSourceCode:into:. self code. self selector }! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AddIntoMethodDescription class instanceVariableNames: ''! !AddIntoMethodDescription class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 2/27/2012 07:09'! code: code order: order selector: selector ^ self new code: code; order: order; selector: selector; yourself! ! AbstractDescription subclass: #AddMethodDescription instanceVariableNames: 'category selector source' classVariableNames: '' poolDictionaries: '' category: 'Spec-Builder'! !AddMethodDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 06:47'! category ^ category! ! !AddMethodDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 06:47'! category: anObject category := anObject! ! !AddMethodDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 06:41'! selector ^ selector! ! !AddMethodDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 06:41'! selector: anObject selector := anObject! ! !AddMethodDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 06:41'! source ^ source! ! !AddMethodDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 06:41'! source: anObject source := anObject! ! !AddMethodDescription methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 2/27/2012 07:07'! initialize "Initialization code for AddMethodDescription" super initialize. category := ''. selector := ''. source := ''.! ! !AddMethodDescription methodsFor: 'processing' stamp: 'BenjaminVanRyseghem 2/27/2012 07:50'! generateSpec ^ { #compileWithoutReturn:classified:. self source. self category.}! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AddMethodDescription class instanceVariableNames: ''! !AddMethodDescription class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 2/27/2012 07:00'! category: category source: source ^ self new category: category; source: source; yourself! ! Object variableSubclass: #AdditionalMethodState instanceVariableNames: 'method selector' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Methods'! !AdditionalMethodState commentStamp: '' prior: 0! 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: '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: '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: '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: '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: '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: '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: 'accessing' stamp: 'GabrielBarbuto 11/30/2010 11:30'! method ^method.! ! !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 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: '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: 'md 2/16/2006 17:50'! selector ^selector! ! !AdditionalMethodState methodsFor: 'accessing' stamp: 'md 2/16/2006 17:50'! selector: aSymbol selector := aSymbol! ! !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: '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: '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: '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: 'decompiling' stamp: 'eem 6/11/2009 17:06'! method: aMethodNodeOrNil "For decompilation" method := aMethodNodeOrNil! ! !AdditionalMethodState methodsFor: 'printing' stamp: 'eem 9/14/2011 17:18'! printOn: aStream super printOn: aStream. aStream space; nextPut: $(; print: self identityHash; nextPut: $)! ! !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: '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: '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: '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: '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: 'MarcusDenker 3/11/2010 20:08'! analogousCodeTo: aMethodProperties | bs | (bs := self basicSize) ~= aMethodProperties basicSize ifTrue: [^false]. 1 to: bs do: [:i| ((self basicAt: i) analogousCodeTo: (aMethodProperties basicAt: i)) ifFalse: [^false]]. ^true! ! !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: '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 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: '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 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: 'testing' stamp: 'eem 11/29/2008 13:47'! isEmpty ^self basicSize = 0! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'md 2/19/2006 11:24'! isMethodProperties ^true! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'eem 12/1/2008 16:49'! notEmpty ^self basicSize > 0! ! !AdditionalMethodState methodsFor: 'testing' stamp: 'JohanBrichau 10/7/2009 20:07'! refersToLiteral: aLiteral ^ self pragmas anySatisfy: [ :pragma | pragma hasLiteral: aLiteral ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AdditionalMethodState class instanceVariableNames: ''! !AdditionalMethodState class methodsFor: 'instance creation' stamp: 'eem 9/16/2011 11:25'! forMethod: aMethod selector: aSelector ^(self new: 0) selector: aSelector; setMethod: aMethod; yourself! ! !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! ! TestCase subclass: #AdditionalMethodStateTest instanceVariableNames: 'atState' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Methods'! !AdditionalMethodStateTest methodsFor: 'running' stamp: 'GabrielBarbuto 11/30/2010 11:29'! setUp | pragma | pragma := (Object methodDict at: #at:) penultimateLiteral at: #primitive:. atState := AdditionalMethodState selector: #at: with: pragma copy. ! ! !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)].! ! Object subclass: #AdvancedHelpBrowserDummy instanceVariableNames: 'rootTopic isOpen' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Tests-Core-UI'! !AdvancedHelpBrowserDummy commentStamp: 'tbn 5/3/2010 19:30' prior: 0! This is a dummy for a custom Help browser that can be registered as a replacement for the HelpBrowser class. Instance Variables rootTopic: rootTopic - The root help topic ! !AdvancedHelpBrowserDummy methodsFor: 'initialize-release' stamp: 'tbn 5/3/2010 19:34'! initialize isOpen := false! ! !AdvancedHelpBrowserDummy methodsFor: 'mocking' stamp: 'tbn 5/3/2010 19:32'! open isOpen := true! ! !AdvancedHelpBrowserDummy methodsFor: 'mocking' stamp: 'tbn 5/3/2010 19:33'! rootTopic ^rootTopic! ! !AdvancedHelpBrowserDummy methodsFor: 'mocking' stamp: 'tbn 5/3/2010 19:33'! rootTopic: aTopic rootTopic := aTopic! ! !AdvancedHelpBrowserDummy methodsFor: 'testing' stamp: 'tbn 5/3/2010 19:32'! isOpen ^isOpen! ! MessageDialogWindow subclass: #AlertDialogWindow instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Windows'! !AlertDialogWindow commentStamp: 'gvc 5/18/2007 13:52' prior: 0! Message dialog with a warning icon.! !AlertDialogWindow methodsFor: 'visual properties' stamp: 'gvc 5/18/2007 10:27'! icon "Answer an icon for the receiver." ^self theme warningIcon! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AlertDialogWindow class instanceVariableNames: ''! !AlertDialogWindow class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'gvc 5/22/2007 11:50'! taskbarIcon "Answer the icon for the receiver in a task bar." ^self theme smallWarningIcon! ! AbstractNautilusPlugin subclass: #AlexPlugin instanceVariableNames: 'text container textMorph' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Plugin'! !AlexPlugin commentStamp: '' prior: 0! An AlexPlugin is a plugin which show the setUp when a test method is selected! !AlexPlugin methodsFor: 'display' stamp: 'BenjaminVanRyseghem 8/21/2011 11:52'! display ^ container! ! !AlexPlugin methodsFor: 'registration' stamp: 'BenjaminVanRyseghem 8/21/2011 11:49'! registerTo: aModel aModel announcer on: NautilusMethodSelected send: #methodSelected: to: self.! ! !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:54'! buildTextMorph textMorph := PluggableTextMorph on: self text: #getText accept: nil! ! !AlexPlugin methodsFor: 'private' stamp: 'BenjaminVanRyseghem 8/21/2011 11:43'! getText ^ text! ! !AlexPlugin methodsFor: 'private' 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 class instanceVariableNames: ''! !AlexPlugin class methodsFor: 'information' stamp: 'BenjaminVanRyseghem 2/17/2012 16:42'! description ^ 'Display the setUp of test methods'! ! !AlexPlugin class methodsFor: 'position' stamp: 'BenjaminVanRyseghem 8/25/2011 10:02'! defaultPosition ^ #middle! ! RectangleMorph subclass: #AlignmentMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Basic'! !AlignmentMorph commentStamp: 'kfr 10/27/2003 10:25' prior: 0! 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'! addAColumn: aCollectionOfMorphs | col | col := self inAColumn: aCollectionOfMorphs. self addMorphBack: col. ^col! ! !AlignmentMorph methodsFor: 'adding' stamp: 'stephane.ducasse 1/15/2009 15:52'! addARow: aCollectionOfMorphs | row | row := self inARow: aCollectionOfMorphs. self addMorphBack: row. ^row! ! !AlignmentMorph methodsFor: 'adding' stamp: 'stephane.ducasse 1/15/2009 15:52'! addARowCentered: aCollectionOfMorphs ^(self addARow: aCollectionOfMorphs) hResizing: #shrinkWrap; wrapCentering: #center; cellPositioning: #leftCenter! ! !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: 'classification' stamp: 'di 5/7/1998 01:20'! isAlignmentMorph ^ true ! ! !AlignmentMorph methodsFor: 'event handling' stamp: 'sw 5/6/1998 15:58'! wantsKeyboardFocusFor: aSubmorph aSubmorph wouldAcceptKeyboardFocus ifTrue: [^ true]. ^ super wantsKeyboardFocusFor: aSubmorph! ! !AlignmentMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:36'! defaultBorderWidth "answer the default border width for the receiver" ^ 0! ! !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: '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: 'initialization' stamp: 'ar 11/9/2000 20:34'! openInWindowLabeled: aString inWorld: aWorld self layoutInset: 0. ^super openInWindowLabeled: aString inWorld: aWorld.! ! !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: '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: '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 class instanceVariableNames: ''! !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! ! !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: '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: '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: '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: '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"! ! Protocol subclass: #AllProtocol instanceVariableNames: 'protocolOrganizer' classVariableNames: '' poolDictionaries: '' category: 'NewClassOrganizer'! !AllProtocol commentStamp: '' prior: 0! An AllProtocol is a special protocol to hanlde the "all" case! !AllProtocol methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/12/2012 14:15'! methods ^ self protocolOrganizer allMethods! ! !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 methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/12/2012 14:15'! protocolOrganizer: anObject protocolOrganizer := anObject.! ! !AllProtocol methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/12/2012 16:05'! canBeRemoved ^ false! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AllProtocol class instanceVariableNames: ''! !AllProtocol class methodsFor: 'data' stamp: 'BenjaminVanRyseghem 4/12/2012 15:49'! defaultName ^ '~~~ all ~~~'! ! !AllProtocol class methodsFor: 'data' stamp: 'BenjaminVanRyseghem 4/12/2012 14:42'! nullCategory ^ 'no method'! ! !AllProtocol class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 4/12/2012 14:14'! protocolOrganizer: protocolOrganizer ^ self new protocolOrganizer: protocolOrganizer; yourself! ! TestCase subclass: #AllocationTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Exception'! !AllocationTest commentStamp: 'StephaneDucasse 12/18/2009 12:03' prior: 0! Test originally from Andreas Raab! !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: '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: '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. ! ! ColorMappingCanvas subclass: #AlphaBlendingCanvas instanceVariableNames: 'alpha' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Support'! !AlphaBlendingCanvas commentStamp: 'LaurentLaffont 2/23/2011 20:17' prior: 0! see ColorMappingCanvas comment.! !AlphaBlendingCanvas methodsFor: 'accessing' stamp: 'ar 8/8/2001 14:24'! alpha ^alpha! ! !AlphaBlendingCanvas methodsFor: 'accessing' stamp: 'ar 8/8/2001 14:24'! alpha: newAlpha alpha := newAlpha.! ! !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)! ! ImageMorph subclass: #AlphaImageMorph instanceVariableNames: 'alpha cachedForm layout scale enabled autoSize getImageSelector model' classVariableNames: 'DefaultImage' poolDictionaries: '' category: 'Polymorph-Widgets'! !AlphaImageMorph commentStamp: 'gvc 5/18/2007 13:52' prior: 0! Displays an image with the specified alpha value (translucency) and optional scale and layout (scaled, top-right etc.).! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 9/26/2006 09:40'! alpha "Answer the value of alpha" ^ alpha! ! !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 2/3/2010 17:46'! autoSize "Answer the value of autoSize" ^ autoSize! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 2/3/2010 17:46'! autoSize: anObject "Set the value of autoSize" autoSize := 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 9/27/2006 15:02'! cachedForm: anObject "Set the value of cachedForm" cachedForm := anObject! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 1/13/2009 17:56'! enabled "Answer the value of enabled" ^enabled! ! !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: 'GaryChambers 8/30/2011 15:22'! getImageSelector ^ getImageSelector! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'GaryChambers 8/30/2011 15:22'! getImageSelector: anObject getImageSelector := anObject! ! !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 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: 'accessing' stamp: 'gvc 6/30/2009 16:02'! imageExtent "Answer the extent of the original form." ^self image extent! ! !AlphaImageMorph methodsFor: 'accessing' stamp: 'gvc 10/11/2006 12:00'! layout "Answer the value of layout" ^ layout! ! !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: '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: 'GaryChambers 8/30/2011 15:32'! model ^ model! ! !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 methodsFor: 'accessing' stamp: 'gvc 10/11/2006 12:43'! scale "Answer the value of scale" ^ scale! ! !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: 'accessing' stamp: 'GaryChambers 10/5/2011 16:05'! scaledImage "Answer the image scaled as required." |i| i := self image. 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: '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: '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: '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: '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: '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: 'geometry' stamp: 'GaryChambers 10/26/2011 11:57'! 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 image width / db width) rounded]. self layout == #scaled ifTrue: [ ^((aRectangle translateBy: self layoutPosition negated) scaleBy: (self image width / db width) @ (self image 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: '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: 'geometry' stamp: 'gvc 10/22/2007 11:51'! optimalExtent "Answer the optimal extent for the receiver." ^self image extent * self scale + (self borderWidth * 2)! ! !AlphaImageMorph methodsFor: 'initialization' stamp: 'gvc 9/26/2006 12:40'! defaultColor "Answer the default color for the receiver." ^Color transparent! ! !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: '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 class instanceVariableNames: ''! !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! ! InfiniteForm subclass: #AlphaInfiniteForm instanceVariableNames: 'origin extent' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Display Objects'! !AlphaInfiniteForm commentStamp: 'gvc 5/18/2007 13:49' prior: 0! Alpha aware InfiniteForm.! !AlphaInfiniteForm methodsFor: 'accessing' stamp: 'gvc 12/3/2008 17:09'! direction: aPoint "Ignore" ! ! !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 10/3/2008 12:42'! origin: aPoint "Set the origin." origin := aPoint! ! !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. ! ! ParserNotification subclass: #AmbiguousSelector instanceVariableNames: 'interval' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Exceptions'! !AmbiguousSelector commentStamp: 'nice 2/23/2010 15:40' prior: 0! 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: '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 methodsFor: 'private' stamp: 'nice 2/23/2010 16:51'! setName: aString range: anInterval name := aString. interval := anInterval! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AmbiguousSelector class instanceVariableNames: ''! !AmbiguousSelector class methodsFor: 'instance creation' stamp: 'nice 2/23/2010 16:52'! signalName: aString inRange: anInterval ^ (self new setName: aString range: anInterval) signal! ! Object subclass: #AndreasSystemProfiler instanceVariableNames: 'semaphore ticks profilerProcess tallyRoot vmStats totalTally totalTime startTime ticksPerMSec totalTicks' classVariableNames: '' poolDictionaries: '' category: 'AndreasProfiler'! !AndreasSystemProfiler commentStamp: '' prior: 0! 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'! 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: '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: '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: '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: '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: '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: 'AlexandreBergel 1/29/2013 11:46'! report: strm cutoff: threshold tallyRoot isNil ifTrue: [ strm nextPutAll: 'The profiler has not been run'. ^ self ]. tallyRoot tally = 0 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: '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 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 class instanceVariableNames: ''! !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.'! ! !AndreasSystemProfiler class methodsFor: 'spying' stamp: 'RJT 1/23/2013 15:28'! default ^self new! ! !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'! 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 ]].! ! TestCase subclass: #AndreasSystemProfilerTest instanceVariableNames: 'tally' classVariableNames: '' poolDictionaries: '' category: 'AndreasProfiler'! !AndreasSystemProfilerTest methodsFor: 'tests profiler' stamp: 'AlexandreBergel 1/29/2013 10:14'! testSimple self shouldnt: [ AndreasSystemProfiler new spyOn: [ 200 timesRepeat: [ 1.23 printString ] ] ] raise: Error.! ! !AndreasSystemProfilerTest methodsFor: 'tests profiler' stamp: 'AlexandreBergel 1/29/2013 11:45'! testSimpleReport self shouldnt: [ AndreasSystemProfiler new report ] raise: Error.! ! !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 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 10:48'! testPrintingTally self assert: tally printString = 'AndreasSystemProfilerTest>>#testPrintingTally -- 0'! ! !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: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 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 '! ! GIFReadWriter subclass: #AnimatedGIFReadWriter instanceVariableNames: 'forms delays comments' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Files'! !AnimatedGIFReadWriter commentStamp: 'LaurentLaffont 5/4/2011 21:27' prior: 0! 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: '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: 'accessing' stamp: 'mir 11/19/2003 14:16'! delays ^ delays! ! !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: 'private-decoding' stamp: 'mir 11/19/2003 12:21'! readBitData | form | form := super readBitData. form offset: offset. ^form! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AnimatedGIFReadWriter class instanceVariableNames: ''! !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: '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: 'nk 6/12/2004 13:12'! typicalFileExtensions "Answer a collection of file extensions (lowercase) which files that I can read might commonly have" ^#('gif')! ! !AnimatedGIFReadWriter class methodsFor: 'image reading/writing' stamp: 'asm 12/11/2003 21:29'! wantsToHandleGIFs ^true! ! Model subclass: #AnimationSettings instanceVariableNames: 'useAnimation animateClosing delay numberOfSteps' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Themes'! !AnimationSettings methodsFor: 'accessing' stamp: 'AlainPlantec 12/15/2009 10:21'! animateClosing ^ animateClosing ifNil: [animateClosing := false]! ! !AnimationSettings methodsFor: 'accessing' stamp: 'AlainPlantec 12/15/2009 10:21'! animateClosing: aBoolean animateClosing := aBoolean! ! !AnimationSettings methodsFor: 'accessing' stamp: 'AlainPlantec 12/15/2009 10:24'! delay ^ delay ifNil: [delay := 8]! ! !AnimationSettings methodsFor: 'accessing' stamp: 'AlainPlantec 12/15/2009 10:22'! delay: anInteger delay := 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:23'! numberOfSteps: anInteger numberOfSteps := anInteger! ! !AnimationSettings methodsFor: 'accessing' stamp: 'AlainPlantec 12/15/2009 10:20'! useAnimation ^ useAnimation ifNil: [useAnimation := false]! ! !AnimationSettings methodsFor: 'accessing' stamp: 'AlainPlantec 12/15/2009 10:21'! useAnimation: aBoolean useAnimation := aBoolean! ! Object subclass: #Annotation instanceVariableNames: '' classVariableNames: 'AnnotationRequests' poolDictionaries: '' category: 'System-Tools'! !Annotation commentStamp: '' prior: 0! An Annotation is a simple class describing the kinds of annotations for code browser. ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Annotation class instanceVariableNames: ''! !Annotation class methodsFor: 'annotations' stamp: 'StephaneDucasse 12/30/2012 17:51'! 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]! ! !Annotation class methodsFor: 'annotations' stamp: 'StephaneDucasse 12/30/2012 17:51'! annotationRequests: aList "see annotationRequests comment" AnnotationRequests := aList! ! !Annotation class methodsFor: 'annotations' stamp: 'StephaneDucasse 12/30/2012 17:51'! defaultAnnotationInfo "see annotationRequests comment" ^ #(timeStamp messageCategory sendersCount implementorsCount allChangeSets)! ! URLPlugin subclass: #AnnotationPanePlugin instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Plugin'! !AnnotationPanePlugin commentStamp: '' prior: 0! An IgorsPlugin is a plugin which displays info about the current selection! !AnnotationPanePlugin methodsFor: 'as yet unclassified' 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 instanceVariableNames: ''! !AnnotationPanePlugin class methodsFor: 'as yet unclassified' stamp: 'BenjaminVanRyseghem 2/17/2012 16:39'! description ^ 'Display the information of the selected class/method'! ! Object subclass: #AnnotationRequest instanceVariableNames: 'selector class separator' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Plugin'! !AnnotationRequest methodsFor: 'accessing' stamp: 'dc 6/18/2007 18:55'! method ^ class compiledMethodAt: selector ifAbsent: [nil]! ! !AnnotationRequest methodsFor: 'accessing' stamp: 'dc 5/2/2007 18:14'! separator: aString separator := aString! ! !AnnotationRequest methodsFor: 'actions' stamp: 'MarianoMartinezPeck 4/24/2012 23:38'! annotationRequests ^ CodeHolder annotationRequests copyWithout: #sendersCount ! ! !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: '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: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: '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:10'! firstComment "The first comment in the method, if any." ^ class firstCommentAt: selector! ! !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:11'! masterComment "The comment at the beginning of the supermost implementor of the method if any." ^ class supermostPrecodeCommentFor: selector! ! !AnnotationRequest methodsFor: 'requests' stamp: 'lr 8/15/2010 17:15'! messageCategory "Which method category the method lies in." ^ class organization categoryOfElement: selector! ! !AnnotationRequest methodsFor: 'requests' stamp: 'lr 8/15/2010 17:15'! priorTimeStamp "The time stamp of the penultimate submission of the method, if any." | stamp | ^ (stamp := VersionsBrowser timeStampFor: selector class: class reverseOrdinal: 2) isNil ifFalse: [ 'prior time stamp: ' , stamp ]! ! !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:13'! recentChangeSet "The most recent change set bearing the method." ^ ChangeSet mostRecentChangeSetWithChangeForClass: class selector: selector! ! !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: 'lr 8/15/2010 17:10'! timeStamp "The time stamp of the last submission of the method." ^ self method isNil ifFalse: [ self method timeStamp ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AnnotationRequest class instanceVariableNames: ''! !AnnotationRequest class methodsFor: 'instance-creation' stamp: 'PDC 6/25/2007 22:01'! onClass: aClass selector: aSelector ^ self new onClass: aClass selector: aSelector; yourself! ! Object subclass: #Announcement instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Announcements-Core'! !Announcement commentStamp: 'Tbn 11/12/2010 10:57' prior: 0! 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: '*Announcements-View' stamp: 'lr 9/3/2006 16:17'! open self inspect! ! !Announcement methodsFor: 'converting' stamp: 'lr 10/3/2006 14:32'! asAnnouncement ^ self! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Announcement class instanceVariableNames: ''! !Announcement class methodsFor: '*Nautilus' stamp: 'BenjaminVanRyseghem 1/2/2013 12:06'! nautilusIcon ^ self nautilusIconClass iconNamed: #announcement! ! !Announcement class methodsFor: 'converting' stamp: 'lr 10/3/2006 14:31'! asAnnouncement ^ self new! ! !Announcement class methodsFor: 'public' stamp: 'lr 9/20/2006 08:18'! , anAnnouncementClass ^ AnnouncementSet with: self with: anAnnouncementClass! ! !Announcement class methodsFor: 'testing' stamp: 'IgorStasenko 3/12/2011 17:05'! handles: anAnnouncementClass ^ anAnnouncementClass == self or: [ anAnnouncementClass inheritsFrom: self ]! ! Object subclass: #AnnouncementLogger instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Announcements'! !AnnouncementLogger commentStamp: 'StephaneDucasse 5/9/2011 17:17' prior: 0! 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:11'! logAnnouncement: ann Transcript show: ann printString ; cr! ! !AnnouncementLogger methodsFor: 'as yet unclassified' stamp: 'StephaneDucasse 5/9/2011 17:15'! subscribeTo: anAnnouncer anAnnouncer "weak" on: Announcement send: #logAnnouncement: to: self! ! Announcement subclass: #AnnouncementMockA instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Announcements-Tests-Core'! !AnnouncementMockA commentStamp: 'Tbn 11/12/2010 10:54' prior: 0! This is a simple test mock.! Announcement subclass: #AnnouncementMockB instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Announcements-Tests-Core'! !AnnouncementMockB commentStamp: 'Tbn 11/12/2010 10:54' prior: 0! This is a simple test mock! AnnouncementMockB subclass: #AnnouncementMockC instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Announcements-Tests-Core'! !AnnouncementMockC commentStamp: 'Tbn 11/12/2010 10:54' prior: 0! This is a simple test mock! Set subclass: #AnnouncementSet instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Announcements-Core'! !AnnouncementSet commentStamp: '' prior: 0! 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: 'lr 10/3/2006 14:31'! handles: anAnnouncementClass ^ self anySatisfy: [ :each | each handles: anAnnouncementClass ]! ! TestCase subclass: #AnnouncementSetTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Announcements-Tests-Core'! !AnnouncementSetTest methodsFor: 'testing' stamp: 'Tbn 11/12/2010 11:07'! testIncludeOnlyOnce |set| set := AnnouncementMockA, AnnouncementMockB, AnnouncementMockA. self assert: set size = 2! ! !AnnouncementSetTest methodsFor: 'testing' stamp: 'Sd 11/26/2010 17:31'! testInstanceCreation |set| set := AnnouncementMockA, AnnouncementMockB. self assert: set size = 2 ! ! Object subclass: #AnnouncementSpy instanceVariableNames: 'announcer announcements index' classVariableNames: '' poolDictionaries: '' category: 'Announcements-View'! !AnnouncementSpy commentStamp: '' prior: 0! 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: 'accessing' stamp: 'lr 9/3/2006 14:08'! announcements: aCollection announcements := aCollection. self changed: #announcements! ! !AnnouncementSpy methodsFor: 'accessing' stamp: 'lr 6/14/2006 17:04'! announcer ^ announcer! ! !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: 'accessing' stamp: 'lr 6/14/2006 17:02'! index ^ index ! ! !AnnouncementSpy methodsFor: 'accessing' stamp: 'lr 6/14/2006 17:20'! index: anInteger index := anInteger. self changed: #index! ! !AnnouncementSpy methodsFor: 'accessing-dynamic' stamp: 'lr 9/3/2006 14:08'! extent ^ 250 @ 400! ! !AnnouncementSpy methodsFor: 'accessing-dynamic' stamp: 'StephaneDucasse 5/1/2011 14:27'! initialExtent ^ 300 @ 400! ! !AnnouncementSpy methodsFor: 'accessing-dynamic' stamp: 'StephaneDucasse 5/1/2011 14:22'! label ^ 'Spy: ', (self announcer ifNil: ['no announcer'] ifNotNil: [ self announcer printString ]) ! ! !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: 'actions' stamp: 'lr 9/25/2006 09:25'! open (self announcements at: self index ifAbsent: [ ^ self ]) open! ! !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: '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: 'building' stamp: 'lr 9/3/2006 16:21'! buildMenu: aMenuMorph ^ aMenuMorph defaultTarget: self; add: 'open' action: #open; add: 'clear' action: #clear; yourself! ! !AnnouncementSpy methodsFor: 'initialization' stamp: 'lr 6/14/2006 17:03'! initialize super initialize. self announcements: OrderedCollection new. self index: 0! ! !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: 'private' stamp: 'lr 6/14/2006 17:19'! changed: aSymbol WorldState addDeferredUIMessage: [ super changed: aSymbol ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AnnouncementSpy class instanceVariableNames: ''! !AnnouncementSpy class methodsFor: 'instance-creation' stamp: 'lr 6/14/2006 17:05'! on: anAnnouncer ^ self new announcer: anAnnouncer; yourself! ! !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 ! ! Object subclass: #AnnouncementSubscription instanceVariableNames: 'announcer announcementClass subscriber action' classVariableNames: '' poolDictionaries: '' category: 'Announcements-Core'! !AnnouncementSubscription commentStamp: 'IgorStasenko 3/12/2011 20:23' prior: 0! 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'! action ^ action! ! !AnnouncementSubscription methodsFor: 'accessing' stamp: 'IgorStasenko 3/12/2011 15:15'! action: anObject action := anObject! ! !AnnouncementSubscription methodsFor: 'accessing' stamp: 'IgorStasenko 3/12/2011 15:18'! announcementClass ^ announcementClass! ! !AnnouncementSubscription methodsFor: 'accessing' stamp: 'IgorStasenko 3/12/2011 15:18'! announcementClass: anObject announcementClass := anObject! ! !AnnouncementSubscription methodsFor: 'accessing' stamp: 'IgorStasenko 3/12/2011 15:15'! announcer ^ announcer! ! !AnnouncementSubscription methodsFor: 'accessing' stamp: 'IgorStasenko 3/12/2011 15:13'! announcer: anAnnouncer announcer := anAnnouncer! ! !AnnouncementSubscription methodsFor: 'accessing' stamp: 'IgorStasenko 3/12/2011 15:14'! subscriber ^ subscriber! ! !AnnouncementSubscription methodsFor: 'accessing' stamp: 'IgorStasenko 3/12/2011 15:14'! subscriber: aSubscriber subscriber := aSubscriber! ! !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: 'announcing' stamp: 'IgorStasenko 7/17/2011 17:09'! deliver: anAnnouncement " deliver an announcement to receiver. In case of failure, it will be handled in separate process" ^ (self handles: anAnnouncement class ) ifTrue: [ [action cull: anAnnouncement cull: announcer] on: UnhandledError fork: [:ex | ex pass ]]! ! !AnnouncementSubscription methodsFor: 'converting' stamp: 'IgorStasenko 3/12/2011 17:37'! makeStrong " i am already strong. Do nothing "! ! !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: 'testing' stamp: 'IgorStasenko 3/12/2011 15:29'! handles: anAnnouncementClass ^ announcementClass handles: anAnnouncementClass! ! AnnouncementsHelp subclass: #AnnouncementsAPIDocumentation instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Announcements-Help'! !AnnouncementsAPIDocumentation commentStamp: 'Tbn 11/12/2010 11:17' prior: 0! This is a custom help book providing the API documentation for the announcements framework. ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AnnouncementsAPIDocumentation class instanceVariableNames: ''! !AnnouncementsAPIDocumentation class methodsFor: 'accessing' stamp: 'Tbn 11/12/2010 10:41'! bookName ^'API Documentation'! ! !AnnouncementsAPIDocumentation class methodsFor: 'accessing' stamp: 'Tbn 11/12/2010 10:42'! packages ^#('Announcements-Core' 'Announcements-View' 'Announcements-Tests-Core')! ! !AnnouncementsAPIDocumentation class methodsFor: 'defaults' stamp: 'Tbn 11/12/2010 10:41'! builder ^PackageAPIHelpBuilder! ! CustomHelp subclass: #AnnouncementsHelp instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Announcements-Help'! !AnnouncementsHelp commentStamp: 'Tbn 11/12/2010 11:17' prior: 0! This is a custom help book for the announcements framework. ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AnnouncementsHelp class instanceVariableNames: ''! !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.!!' ! ! !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 subclass: #AnnouncementsTutorial instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Announcements-Help'! !AnnouncementsTutorial commentStamp: 'Tbn 11/12/2010 11:17' prior: 0! This is a custom help book providing a tutorial for the announcements framework. ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AnnouncementsTutorial class instanceVariableNames: ''! !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 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: '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 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! ! Object subclass: #Announcer instanceVariableNames: 'registry' classVariableNames: '' poolDictionaries: '' category: 'Announcements-Core'! !Announcer commentStamp: 'IgorStasenko 3/12/2011 18:45' prior: 0! 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: '*RPackage-core' stamp: 'EstebanLorenzano 8/3/2012 15:01'! hasSubscriber: anObject registry subscriptionsOf: anObject do: [:each | ^ true]. ^ false! ! !Announcer methodsFor: '*RPackage-core' stamp: 'StephaneDucasse 4/23/2011 12:43'! subscriptions ^ registry! ! !Announcer methodsFor: '*announcements-view' stamp: 'lr 9/20/2006 08:18'! open AnnouncementSpy openOn: self! ! !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 4/24/2011 12:15'! on: anAnnouncementClass do: aValuable "Declare that when anAnnouncementClass is raised, aValuable is executed." ^ self subscribe: anAnnouncementClass do: aValuable! ! !Announcer methodsFor: 'convenience' stamp: 'StephaneDucasse 4/24/2011 12:08'! on: anAnnouncementClass send: aSelector to: anObject "Declare that when anAnnouncementClass is raised, anObject should receive the message aSelector." ^ self subscribe: anAnnouncementClass send: aSelector to: anObject! ! !Announcer methodsFor: 'convenience' stamp: 'StephaneDucasse 4/24/2011 12:15'! when: anAnnouncementClass do: aValuable "Declare that when anAnnouncementClass is raised, aValuable is executed." ^ self subscribe: anAnnouncementClass do: aValuable! ! !Announcer methodsFor: 'initialize-release' stamp: 'IgorStasenko 3/12/2011 16:50'! initialize super initialize. registry := SubscriptionRegistry new.! ! !Announcer methodsFor: 'statistics' stamp: 'IgorStasenko 3/12/2011 21:02'! numberOfSubscriptions ^ registry numberOfSubscriptions ! ! !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: '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: 'subscription' stamp: 'StephaneDucasse 4/24/2011 12:15'! unsubscribe: anObject "Unsubscribe all subscriptions of anObject from the receiver" registry removeSubscriber: anObject! ! !Announcer methodsFor: 'weak' stamp: 'IgorStasenko 3/12/2011 20:26'! weak "announcer weak subscribe: foo" ^ WeakSubscriptionBuilder on: self! ! !Announcer methodsFor: 'private' stamp: 'IgorStasenko 3/12/2011 20:30'! basicSubscribe: subscription ^ registry add: subscription! ! !Announcer methodsFor: 'private' stamp: 'IgorStasenko 3/22/2011 15:27'! replace: subscription with: newOne ^ registry replace: subscription with: newOne ! ! TestCase subclass: #AnnouncerTest instanceVariableNames: 'announcer' classVariableNames: '' poolDictionaries: '' category: 'Announcements-Tests-Core'! !AnnouncerTest commentStamp: 'Tbn 11/12/2010 10:55' prior: 0! 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: 'running' stamp: 'lr 2/26/2011 11:34'! setUp super setUp. announcer := self newAnnouncer! ! !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: '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: 'IgorStasenko 3/12/2011 21:47'! testNoArgBlock "we are supposed to accept zero-argument blocks as actions " | announcement counter | counter := nil. self shouldnt: [ announcer subscribe: AnnouncementMockA do: [ counter:= 1 ] ] raise: Exception. self shouldnt: [announcer announce: AnnouncementMockA new] raise: Exception. self assert: counter =1! ! !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 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: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 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: 'testing' stamp: 'IgorStasenko 3/12/2011 21:46'! testTwoArgBlock "we are supposed to accept two-argument blocks as actions " | announcement flag | self shouldnt: [ announcer subscribe: AnnouncementMockA do: [:ann :announcer2 | flag := announcer2 == announcer ] ] raise: Exception. self shouldnt: [announcer announce: AnnouncementMockA new] raise: Exception. self assert: flag! ! !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: '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: '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: 'private' stamp: 'lr 2/26/2011 11:34'! newAnnouncer ^ Announcer new! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! AnnouncerTest class instanceVariableNames: ''! !AnnouncerTest class methodsFor: 'testing' stamp: 'lr 2/26/2011 11:35'! shouldInheritSelectors ^ true! ! Object subclass: #AppRegistry instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Applications'! !AppRegistry commentStamp: 'ads 4/2/2003 15:30' prior: 0! 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 instanceVariableNames: 'registeredClasses default'! !AppRegistry class methodsFor: '*UIManager' 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: 'cleanup' stamp: 'StephaneDucasse 3/9/2010 16:16'! cleanUp "AppRegistry cleanUp" self removeObsolete.! ! !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: 'cleanup' stamp: 'StephaneDucasse 1/30/2011 21:38'! reset "AppRegistry reset" registeredClasses := nil.! ! !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: '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:01'! registeredClasses ^ registeredClasses ifNil: [registeredClasses := OrderedCollection new]! ! !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: '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: 'singleton' stamp: 'ads 3/29/2003 13:11'! default ^ default ifNil: [self askForDefault]! ! !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: 'singleton' stamp: 'nk 3/9/2004 12:35'! defaultOrNil ^ default! ! !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]! ! Object subclass: #Archive instanceVariableNames: 'members' classVariableNames: '' poolDictionaries: '' category: 'Compression-Archives'! !Archive commentStamp: '' prior: 0! 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: 'nk 2/22/2001 19:09'! addDirectory: aFileName ^self addDirectory: aFileName as: aFileName ! ! !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: 'nk 2/21/2001 18:29'! addFile: aFileName ^self addFile: aFileName as: aFileName! ! !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! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/22/2001 19:09'! addMember: aMember ^members addLast: aMember! ! !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: '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: '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: '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/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/22/2001 07:57'! contentsOf: aMemberOrName | member | member := self member: aMemberOrName. member ifNil: [ ^nil ]. ^member contents! ! !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/22/2001 07:57'! extractMember: aMemberOrName toFileNamed: aFileName | member | member := self member: aMemberOrName. member ifNil: [ ^nil ]. member extractToFileNamed: aFileName! ! !Archive methodsFor: 'archive operations' stamp: 'CamilloBruni 5/4/2012 21:18'! extractMemberWithoutPath: aMemberOrName self extractMemberWithoutPath: aMemberOrName inDirectory: FileSystem workingDirectory.! ! !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 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/21/2001 18:00'! memberNames ^members collect: [ :ea | ea fileName ]! ! !Archive methodsFor: 'archive operations' stamp: 'nk 2/21/2001 17:58'! members ^members! ! !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: 'nk 2/21/2001 17:59'! numberOfMembers ^members size! ! !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: '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/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: 'nk 2/21/2001 20:58'! writeTo: aStream self subclassResponsibility! ! !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: 'initialization' stamp: 'alain.plantec 5/28/2009 09:39'! initialize super initialize. members := OrderedCollection new.! ! !Archive methodsFor: 'private' stamp: 'nk 2/22/2001 07:56'! member: aMemberOrName ^(members includes: aMemberOrName) ifTrue: [ aMemberOrName ] ifFalse: [ self memberNamed: aMemberOrName ].! ! !Archive methodsFor: 'private' stamp: 'nk 2/21/2001 18:14'! memberClass self subclassResponsibility! ! Object subclass: #ArchiveMember instanceVariableNames: 'fileName isCorrupt' classVariableNames: '' poolDictionaries: '' category: 'Compression-Archives'! !ArchiveMember commentStamp: '' prior: 0! This is the abstract superclass for archive members, which are files or directories stored in archives.! !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: 'accessing' stamp: 'nk 3/7/2004 16:16'! isCorrupt ^isCorrupt ifNil: [ isCorrupt := false ]! ! !ArchiveMember methodsFor: 'accessing' stamp: 'nk 3/7/2004 16:06'! isCorrupt: aBoolean "Mark this member as being corrupt." isCorrupt := aBoolean! ! !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: 'initialization' stamp: 'alain.plantec 5/28/2009 09:39'! initialize super initialize. fileName := ''. isCorrupt := false.! ! !ArchiveMember methodsFor: 'printing' stamp: 'nk 12/20/2002 15:11'! printOn: aStream super printOn: aStream. aStream nextPut: $(; nextPutAll: self fileName; nextPut: $)! ! !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 instanceVariableNames: ''! !ArchiveMember class methodsFor: 'as yet unclassified' stamp: 'nk 2/21/2001 18:33'! newDirectoryNamed: aString self subclassResponsibility! ! !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! ! Error subclass: #ArithmeticError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Exceptions'! !ArithmeticError commentStamp: 'SvenVanCaekenberghe 4/21/2011 12:40' prior: 0! I am ArithmeticError, the superclass of all exceptions related to arithmentic.! ArrayedCollection variableSubclass: #Array instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Sequenceable'! !Array commentStamp: '' prior: 0! I present an ArrayedCollection whose elements are objects.! !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: '*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: '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: '*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: '*Morphic' stamp: 'StephaneDucasse 12/21/2012 13:53'! asLayoutFrame ^ LayoutFrame new fromArray: self! ! !Array methodsFor: '*Spec-Core' stamp: 'BenjaminVanRyseghem 1/15/2013 11:34'! generateSpec | str spec | str := self readStream. spec := OrderedCollection with: #FrameLayout. #( 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: '*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: '*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: '*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: '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: '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: '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: 'converting' stamp: 'sma 5/12/2000 17:32'! asArray "Answer with the receiver itself." ^ self! ! !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: '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: 'converting' stamp: 'brp 9/26/2003 08:09'! 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. 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: 'converting' stamp: 'CamilloBruni 10/20/2012 18:10'! sorted: aSortBlock "Return a new sequenceable collection which contains the same elements as self but its elements are sorted by aSortBlock. The block should take two arguments and return true if the first element should preceed the second one." ^self copy sort: aSortBlock! ! !Array methodsFor: 'copying' stamp: 'ar 2/11/2001 01:55'! copyWithDependent: newElement self size = 0 ifTrue:[^DependentsArray with: newElement]. ^self copyWith: newElement! ! !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: '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: '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: 'self evaluating' stamp: 'sd 7/31/2005 21:44'! isSelfEvaluating ^ (self allSatisfy: [:each | each isSelfEvaluating]) and: [self class == Array]! ! !Array methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 21:44'! printAsLiteralFormOn: aStream aStream nextPut: $#. self printElementsOn: aStream ! ! !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: 'testing' stamp: 'eem 5/8/2008 11:13'! isArray ^true! ! !Array methodsFor: 'testing' stamp: 'nice 11/2/2009 19:06'! isLiteral ^self class == Array and: [self allSatisfy: [:each | each isLiteral]]! ! !Array methodsFor: 'testing' stamp: 'ul 11/23/2010 13:28'! shouldBePrintedAsLiteral ^self class == Array and: [ self allSatisfy: [ :each | each shouldBePrintedAsLiteral ] ]! ! !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: '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 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: 'private'! 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 class instanceVariableNames: ''! !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: '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: '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! ! !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: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'! braceWithNone "This method is used in compilation of brace constructs. It MUST NOT be deleted or altered." ^ self new: 0! ! !Array class methodsFor: 'instance creation' stamp: 'StephaneDucasse 2/13/2010 12:18'! empty "A canonicalized empty Array instance." ^ #()! ! !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:" ! ! TestCase subclass: #ArrayLiteralTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CompilerTests'! !ArrayLiteralTest methodsFor: 'initialization' stamp: 'avi 2/16/2004 21:09'! tearDown self class removeSelector: #array! ! !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: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: '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: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: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: '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: '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: 'tests' stamp: 'avi 2/16/2004 21:08'! testReservedIdentifiers self class compile: 'array ^ #(nil true false)'. self assert: self array = {nil. true. false}.! ! !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}.! ! CollectionRootTest subclass: #ArrayTest uses: TEmptySequenceableTest + TSequencedElementAccessTest + TCloneTest + TIncludesWithIdentityCheckTest + TCopyTest + TCreationWithTest + TPutBasicTest + TConvertTest - {} + TOccurrencesForMultiplinessTest + TIterateSequencedReadableTest + TSequencedConcatenationTest + TReplacementSequencedTest + TAsStringCommaAndDelimiterSequenceableTest + TBeginsEndsWith + TPrintOnSequencedTest + TIndexAccess + TSubCollectionAccess + TConvertAsSetForMultiplinessIdentityTest + TCopyPartOfSequenceable + TCopySequenceableSameContents + TCopySequenceableWithOrWithoutSpecificElements + TCopySequenceableWithReplacement + TIndexAccessForMultipliness + TCopyPartOfSequenceableForMultipliness + TConvertAsSortedTest + TPutTest + TSequencedStructuralEqualityTest + TSortTest + TSetArithmetic instanceVariableNames: 'example1 literalArray selfEvaluatingArray otherArray nonSEArray1 nonSEarray2 example2 empty collectResult withoutEqualElements withEqualElements withCharacters unsortedCollection sortedInAscendingOrderCollection sizeCollection collectionNotIncluded removedCollection elementInForCopy elementNotInForCopy firstIndex secondIndex replacementCollection indexArray valueArray nonEmptyMoreThan1Element subCollectionNotIn replacementCollectionSameSize oldSubCollection nonEmpty1Element collectionOfCollection collectionOfFloatWithEqualElements floatCollectionWithSameBeginingAnEnd collectionWithoutNil duplicateElement collection5Elements collectionWith4Elements' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Arrayed'! !ArrayTest commentStamp: '' prior: 0! 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: '*Collections-arithmetic-testing' stamp: 'stephane.ducasse 10/6/2008 16:53'! testPremultiply self assert: example1 +* #(2 ) = #(2 4 6 8 10 ) ! ! !ArrayTest methodsFor: 'as yet unclassified'! 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: 'as yet unclassified'! testStreamContentsProtocol | result index | result:= self collectionClass << [ :s| s nextPutAll: self firstCollection; nextPutAll: self secondCollection ]. self assert: result equals: self firstCollection, self secondCollection.! ! !ArrayTest methodsFor: 'as yet unclassified'! 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: 'helpers' stamp: 'stephane.ducasse 1/12/2009 17:12'! aValue ^ 33! ! !ArrayTest methodsFor: 'helpers' stamp: 'stephane.ducasse 1/12/2009 17:13'! anIndex ^ 2! ! !ArrayTest methodsFor: 'helpers' stamp: 'stephane.ducasse 1/12/2009 17:19'! anotherValue ^ 66! ! !ArrayTest methodsFor: 'initialization' stamp: 'cyrille.delaunay 12/18/2009 12:59'! collection ^ collectionWith4Elements ! ! !ArrayTest methodsFor: 'initialization' stamp: 'stephane.ducasse 10/5/2008 15:06'! empty ^ empty! ! !ArrayTest methodsFor: 'initialization' stamp: 'stephane.ducasse 10/5/2008 15:06'! nonEmpty ^ example1! ! !ArrayTest methodsFor: 'initialization' stamp: 'cyrille.delaunay 12/18/2009 11:59'! result ^ collectResult! ! !ArrayTest methodsFor: 'initialization' stamp: 'StephaneDucasse 3/13/2010 16:58'! 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). 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: 'parameters'! accessValuePutIn "return access the element put in the non-empty collection" ^ self perform: self selectorToAccessValuePutIn! ! !ArrayTest methodsFor: 'parameters'! accessValuePutInOn: s "return access the element put in the non-empty collection" ^ s perform: self selectorToAccessValuePutIn! ! !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: 'parameters' stamp: 'stephane.ducasse 10/9/2008 18:49'! valuePutIn "the value that we will put in the non empty collection" ^ 2! ! !ArrayTest methodsFor: 'requirements' stamp: 'stephane.ducasse 10/30/2008 19:02'! accessCollection ^ example1! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 14:45'! anotherElementNotIn ^ elementNotInForCopy ! ! !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: '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/9/2009 11:11'! collectionInForIncluding ^ self nonEmpty copyWithoutFirst.! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 15:16'! collectionMoreThan1NoDuplicates " return a collection of size 5 without equal elements" ^ withoutEqualElements ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 14:01'! collectionMoreThan5Elements " return a collection including at least 5 elements" ^ collection5Elements ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/30/2009 10:51'! collectionNotIncluded ^ collectionNotIncluded.! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 14:07'! collectionOfFloat ^ collectionOfCollection! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 10:28'! collectionWith1TimeSubcollection ^ (self oldSubCollection copyWithoutFirst),self oldSubCollection,(self oldSubCollection copyWithoutFirst). ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 10:29'! collectionWith2TimeSubcollection ^ (self oldSubCollection copyWithoutFirst),self oldSubCollection,(self oldSubCollection copyWithoutFirst),self oldSubCollection .! ! !ArrayTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 3/26/2009 09:58'! collectionWithCharacters ^ withCharacters.! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 13:49'! collectionWithCopy "return a collection of type 'self collectionWIithoutEqualsElements clas' 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: '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: 'requirements' stamp: 'delaunay 4/17/2009 15:24'! collectionWithElementsToRemove ^ removedCollection! ! !ArrayTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 3/26/2009 09:57'! collectionWithEqualElements ^ withEqualElements.! ! !ArrayTest methodsFor: 'requirements'! 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: '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: '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: 'requirements' stamp: 'delaunay 4/24/2009 10:27'! collectionWithSortableElements " return a collection elements that can be sorte ( understanding message ' < ' or ' > ')" ^ withoutEqualElements ! ! !ArrayTest methodsFor: 'requirements' stamp: 'CamilloBruni 9/9/2011 12:09'! collectionWithoutEqualElements ^ withoutEqualElements ! ! !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: 'requirements' stamp: 'damienpollet 1/30/2009 17:27'! element ^ 3! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 14:22'! elementInCollectionOfFloat ^ collectionOfCollection atRandom! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 10:28'! elementInForCopy ^ elementInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 14:39'! elementInForElementAccessing " return an element inculded in 'accessCollection '" ^ self accessCollection anyOne! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 13:55'! elementInForIncludesTest ^ elementInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/10/2009 14:49'! elementInForIndexAccess ^ elementInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 15:18'! elementInForIndexAccessing ^ withoutEqualElements anyOne! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/2/2009 11:54'! elementInForOccurrences ^ elementInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/6/2009 10:16'! elementInForReplacement ^ elementInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 14:45'! elementNotIn "return an element not included in 'nonEmpty' " ^ elementNotInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 10:29'! elementNotInForCopy ^ elementNotInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 14:39'! elementNotInForElementAccessing " return an element not included in 'accessCollection' " ^ elementNotInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/7/2009 11:18'! elementNotInForIndexAccessing ^elementNotInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 14:45'! elementNotInForOccurrences ^ elementNotInForCopy ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 16:13'! elementTwiceInForOccurrences " return an element included exactly two time in # collectionWithEqualElements" ^ duplicateElement ! ! !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: 'requirements' stamp: 'delaunay 4/2/2009 16:41'! firstCollection ^example1 ! ! !ArrayTest methodsFor: 'requirements' stamp: 'damiencassou 1/27/2009 10:35'! firstEven "Returns the first even number of #collection" ^ -2! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 10:29'! firstIndex ^ firstIndex ! ! !ArrayTest methodsFor: 'requirements' stamp: 'damiencassou 1/27/2009 10:35'! firstOdd "Returns the first odd number of #collection" ^ 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 3/31/2009 16:00'! indexArray ^ indexArray .! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/16/2009 15:59'! indexInForCollectionWithoutDuplicates ^ 2.! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/16/2009 16:56'! indexInNonEmpty ^ 2 ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/9/2009 15:53'! integerCollection ^example1 .! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 10:28'! integerCollectionWithoutEqualElements ^{1. 2. 6. 5.}! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:53'! moreThan3Elements " return a collection including atLeast 3 elements" ^ example1 ! ! !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 4/6/2009 10:16'! newElement ^999! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/8/2009 11:40'! nonEmpty1Element ^ nonEmpty1Element ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/2/2009 15:20'! nonEmptyMoreThan1Element ^nonEmptyMoreThan1Element .! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/6/2009 11:41'! oldSubCollection ^oldSubCollection ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 10:29'! replacementCollection ^replacementCollection .! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/6/2009 10:32'! replacementCollectionSameSize ^replacementCollectionSameSize ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/2/2009 16:41'! secondCollection ^example2 ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 10:29'! secondIndex ^ secondIndex ! ! !ArrayTest methodsFor: 'requirements' stamp: 'damienpollet 1/13/2009 16:59'! sizeCollection ^ self collection! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/31/2009 14:08'! smallerIndex ^ firstIndex -1! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/27/2009 15:20'! sortedInAscendingOrderCollection ^sortedInAscendingOrderCollection . ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 4/3/2009 11:35'! subCollectionNotIn ^subCollectionNotIn ! ! !ArrayTest methodsFor: 'requirements' stamp: 'delaunay 3/27/2009 15:20'! unsortedCollection ^unsortedCollection .! ! !ArrayTest methodsFor: 'requirements'! 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: 'requirements' stamp: 'delaunay 4/28/2009 14:11'! withEqualElements " return a collection of float including equal elements (classic equality)" ^ collectionOfFloatWithEqualElements! ! !ArrayTest methodsFor: 'test - copy' stamp: 'delaunay 4/17/2009 15:26'! elementToAdd ^ 55! ! !ArrayTest methodsFor: 'test - creation' stamp: 'stephane.ducasse 12/9/2008 22:00'! collectionClass ^ Array! ! !ArrayTest methodsFor: 'test - creation'! testOfSize "self debug: #testOfSize" | aCol | aCol := self collectionClass ofSize: 3. self assert: (aCol size = 3). ! ! !ArrayTest methodsFor: 'test - creation'! testWith "self debug: #testWith" | aCol anElement | anElement := self collectionMoreThan5Elements anyOne. aCol := self collectionClass with: anElement. self assert: (aCol includes: anElement).! ! !ArrayTest methodsFor: 'test - creation'! 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: 'test - creation'! 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: 'test - creation'! 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: 'test - creation'! 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: 'test - creation'! 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: 'test - equality'! testEqualSign "self debug: #testEqualSign" self deny: (self empty = self nonEmpty).! ! !ArrayTest methodsFor: 'test - equality'! 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: 'test - equality'! 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: 'test - equality'! testEqualSignOfIdenticalCollectionObjects "self debug: #testEqualSignOfIdenticalCollectionObjects" self assert: (self empty = self empty). self assert: (self nonEmpty = self nonEmpty). ! ! !ArrayTest methodsFor: 'test - iterate' stamp: 'luc.fabresse 11/29/2008 23:10'! expectedSizeAfterReject ^1! ! !ArrayTest methodsFor: 'test - iterate' stamp: 'stephane.ducasse 10/6/2008 17:39'! speciesClass ^ Array! ! !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: '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: '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: 'testing' stamp: 'StephaneDucasse 11/6/2011 22:45'! 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. self shouldnt: [restoredArray := self class evaluatorClass evaluate: complexArray printString] raise: Error. self assert: restoredArray = complexArray! ! !ArrayTest methodsFor: 'testing' stamp: 'zz 12/5/2005 17:12'! testIsArray self assert: example1 isArray! ! !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: '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: 'testing' stamp: 'StephaneDucasse 1/16/2010 10:07'! testLiteralEqual self deny: (example1 literalEqual: example1 asIntegerArray)! ! !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: 'testing' stamp: 'StephaneDucasse 11/6/2011 22:46'! testPrinting "self debug: #testPrinting" self assert: literalArray printString = '#(1 true 3 #four)'. self assert: (literalArray = (self class evaluatorClass evaluate: literalArray printString)). self assert: (selfEvaluatingArray = (self class evaluatorClass evaluate: selfEvaluatingArray printString)). self assert: nonSEArray1 printString = 'an Array(1 a Set(1))'. self assert: nonSEarray2 printString = '{#Array->Array}' ! ! !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 - as identity set'! 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: 'tests - as identity set'! 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 - as set tests'! 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 - as set tests'! testAsSetWithEqualsElements | result | result := self withEqualElements asSet. self withEqualElements do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. self assert: result class = Set! ! !ArrayTest methodsFor: 'tests - as sorted collection' stamp: 'hfm 4/2/2010 13:36'! 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 - as sorted collection'! 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 - as sorted collection'! 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 - at put'! testAtPut "self debug: #testAtPut" self nonEmpty at: self anIndex put: self aValue. self assert: (self nonEmpty at: self anIndex) = self aValue. ! ! !ArrayTest methodsFor: 'tests - at put'! testAtPutOutOfBounds "self debug: #testAtPutOutOfBounds" self should: [self empty at: self anIndex put: self aValue] raise: Error ! ! !ArrayTest methodsFor: 'tests - at put'! 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 - begins ends with'! 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: 'tests - begins ends with'! testsBeginsWithEmpty self deny: (self nonEmpty beginsWith:(self empty)). self deny: (self empty beginsWith:(self nonEmpty )). ! ! !ArrayTest methodsFor: 'tests - begins ends with'! 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 - begins ends with'! testsEndsWithEmpty self deny: (self nonEmpty endsWith: self empty). self deny: (self empty endsWith: self nonEmpty). ! ! !ArrayTest methodsFor: 'tests - comma and delimiter'! testAsCommaStringEmpty self assert: self empty asCommaString = ''. self assert: self empty asCommaStringAnd = ''. ! ! !ArrayTest methodsFor: 'tests - comma and delimiter'! 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 - comma and delimiter'! 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 - comma and delimiter'! testAsStringOnDelimiterEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim. self assert: emptyStream contents = ''. ! ! !ArrayTest methodsFor: 'tests - comma and delimiter'! testAsStringOnDelimiterLastEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim last:'and'. self assert: emptyStream contents = ''. ! ! !ArrayTest methodsFor: 'tests - comma and delimiter'! 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 - comma and delimiter'! 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 - comma and delimiter'! 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: 'tests - comma and delimiter'! 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 - concatenation'! 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 - concatenation'! 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 - converting'! 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 - converting'! 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 - 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 - converting' stamp: 'cyrille.delaunay 3/26/2009 14:55'! testAsArray "self debug: #testAsArray3" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Array! ! !ArrayTest methodsFor: 'tests - converting'! testAsBag self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! ! !ArrayTest methodsFor: 'tests - converting'! testAsByteArray | res | self shouldnt: [self integerCollectionWithoutEqualElements ] raise: Error. 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'! testAsIdentitySet "test with a collection without equal elements :" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: IdentitySet. ! ! !ArrayTest methodsFor: 'tests - converting'! testAsOrderedCollection self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! ! !ArrayTest methodsFor: 'tests - converting'! testAsSet | | "test with a collection without equal elements :" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Set. ! ! !ArrayTest methodsFor: 'tests - copy'! 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: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! 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 - copy' stamp: 'delaunay 4/17/2009 15:24'! 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 - copy'! 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: 'tests - copy'! 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 - copy'! 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: 'delaunay 4/17/2009 15:24'! 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: 'tests - copy' stamp: 'delaunay 3/30/2009 10:33'! testCopyNonEmptyWithoutAllNotIncluded ! ! !ArrayTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! 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 - copy'! 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 - copy'! 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: 'tests - copy - clone'! testCopyCreatesNewObject "self debug: #testCopyCreatesNewObject" | copy | copy := self nonEmpty copy. self deny: self nonEmpty == copy. ! ! !ArrayTest methodsFor: 'tests - copy - clone'! testCopyEmpty "self debug: #testCopyEmpty" | copy | copy := self empty copy. self assert: copy isEmpty.! ! !ArrayTest methodsFor: 'tests - copy - clone'! 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 - copying part of sequenceable'! 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 - copying part of sequenceable'! testCopyAfterEmpty | result | result := self empty copyAfter: self collectionWithoutEqualElements first. self assert: result isEmpty. ! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable'! 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 - copying part of sequenceable'! testCopyAfterLastEmpty | result | result := self empty copyAfterLast: self collectionWithoutEqualElements first. self assert: result isEmpty.! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable'! testCopyEmptyMethod | result | result := self collectionWithoutEqualElements copyEmpty . self assert: result isEmpty . self assert: result class= self nonEmpty class.! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable'! 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 - copying part of sequenceable'! 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: 'tests - copying part of sequenceable'! testCopyUpToEmpty | result | result := self empty copyUpTo: self collectionWithoutEqualElements first. self assert: result isEmpty. ! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable'! 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: 'tests - copying part of sequenceable'! testCopyUpToLastEmpty | result | result := self empty copyUpToLast: self collectionWithoutEqualElements first. self assert: result isEmpty.! ! !ArrayTest methodsFor: 'tests - copying part of sequenceable for multipliness'! 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 - copying part of sequenceable for multipliness'! 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 - copying part of sequenceable for multipliness'! 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: 'tests - copying part of sequenceable for multipliness'! 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: 'tests - copying same contents'! 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: 'tests - copying same contents'! 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 - copying same contents'! 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 - copying same contents'! testShallowCopyEmpty | result | result := self empty shallowCopy . self assert: result isEmpty .! ! !ArrayTest methodsFor: 'tests - copying same contents'! 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: 'tests - copying with or without'! 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: 'tests - copying with or without'! 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 - copying with or without'! 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 - copying with or without'! 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: 'tests - copying with or without'! 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: 'tests - copying with or without'! 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 - copying with replacement'! firstIndexesOf: subCollection 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: subCollection) ifTrue: [ result add: currentIndex. 1 to: subCollection size do: [:i | tmp := tmp copyWithoutFirst. currentIndex := currentIndex + 1] ] ifFalse: [ tmp := tmp copyWithoutFirst. currentIndex := currentIndex +1. ] ]. ^ result. ! ! !ArrayTest methodsFor: 'tests - copying with replacement'! 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 - copying with replacement'! 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 shouldnt: [self collectionWith2TimeSubcollection ]raise: Error. 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 " specific comportement for the begining of the collection :" ifTrue: [ 1 to: ((firstIndexesOfOccurrence at: i) - 1 ) do: [ :j | self assert: (result at: i) = (self collectionWith2TimeSubcollection at: i) ] ] " between parts till the end : " 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)) ] ] ]. "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: 'tests - copying with replacement'! 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: 'tests - copying with replacement'! 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 - element accessing'! 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 - element accessing'! 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 - element accessing' stamp: 'MarcusDenker 8/20/2011 13:42'! 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 - element accessing'! 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 - element accessing'! 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: 'tests - element accessing'! 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: 'tests - element accessing'! testAtLastError "self debug: #testAtLast" self should: [ self moreThan4Elements atLast: self moreThan4Elements size + 1 ] raise: Error! ! !ArrayTest methodsFor: 'tests - element accessing'! 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 - element accessing'! 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: 'tests - element accessing'! 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 - element accessing'! testAtRandom | result | result := self nonEmpty atRandom . self assert: (self nonEmpty includes: result).! ! !ArrayTest methodsFor: 'tests - element accessing'! 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 - element accessing'! 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 - element accessing'! 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 - element accessing'! 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 - element accessing'! testLast "self debug: #testLast" self assert: self moreThan4Elements last = (self moreThan4Elements at: self moreThan4Elements size)! ! !ArrayTest methodsFor: 'tests - element accessing'! testMiddle "self debug: #testMiddle" self assert: self moreThan4Elements middle = (self moreThan4Elements at: self moreThan4Elements size // 2 + 1)! ! !ArrayTest methodsFor: 'tests - equality'! 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 - equality'! 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: 'tests - equality'! 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: 'tests - equality'! testHasEqualElementsOfIdenticalCollectionObjects "self debug: #testHasEqualElementsOfIdenticalCollectionObjects" self assert: (self empty hasEqualElements: self empty). self assert: (self nonEmpty hasEqualElements: self nonEmpty). ! ! !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: '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 - fixture'! howMany: subCollection in: collection " return an integer representing how many time 'subCollection' appears in 'collection' " | tmp nTime | tmp:= collection. nTime:= 0. [tmp isEmpty ]whileFalse: [ (tmp beginsWith: subCollection) ifTrue: [ nTime := nTime + 1. 1 to: subCollection size do: [:i | tmp := tmp copyWithoutFirst.] ] ifFalse: [tmp := tmp copyWithoutFirst.] ]. ^ nTime. ! ! !ArrayTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/17/2009 15:26'! test0CopyTest self shouldnt: self empty raise: Error. self assert: self empty size = 0. self shouldnt: self nonEmpty raise: Error. self assert: (self nonEmpty size = 0) not. self shouldnt: self collectionWithElementsToRemove raise: Error. self assert: (self collectionWithElementsToRemove size = 0) not. self shouldnt: self elementToAdd raise: Error! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureAsSetForIdentityMultiplinessTest "a collection (of elements for which copy is not identical ) without equal elements:" | anElement res | self shouldnt: [ self elementsCopyNonIdenticalWithoutEqualElements ]raise: Error. 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'! test0FixtureAsStringCommaAndDelimiterTest self shouldnt: [self nonEmpty] raise:Error . self deny: self nonEmpty isEmpty. self shouldnt: [self empty] raise:Error . self assert: self empty isEmpty. self shouldnt: [self nonEmpty1Element ] raise:Error . self assert: self nonEmpty1Element size=1.! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureBeginsEndsWithTest self shouldnt: [self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self assert: self nonEmpty size>1. self shouldnt: [self empty ] raise: Error. self assert: self empty isEmpty.! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureCloneTest self shouldnt: [ self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self empty ] raise: Error. self assert: self empty isEmpty. ! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureConverAsSortedTest self shouldnt: [self collectionWithSortableElements ] raise: Error. self deny: self collectionWithSortableElements isEmpty .! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureCopyPartOfForMultipliness self shouldnt: [self collectionWithSameAtEndAndBegining ] raise: Error. 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 - fixture'! test0FixtureCopyPartOfSequenceableTest self shouldnt: [self collectionWithoutEqualElements ] raise: Error. self collectionWithoutEqualElements do: [:each | self assert: (self collectionWithoutEqualElements occurrencesOf: each)=1]. self shouldnt: [self indexInForCollectionWithoutDuplicates ] raise: Error. self assert: self indexInForCollectionWithoutDuplicates >0 & self indexInForCollectionWithoutDuplicates < self collectionWithoutEqualElements size. self shouldnt: [self empty] raise: Error. self assert: self empty isEmpty .! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureCopySameContentsTest self shouldnt: [self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [self empty ] raise: Error. self assert: self empty isEmpty. ! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureCopyWithOrWithoutSpecificElementsTest self shouldnt: [self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty . self shouldnt: [self indexInNonEmpty ] raise: Error. self assert: self indexInNonEmpty > 0. self assert: self indexInNonEmpty <= self nonEmpty size.! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureCopyWithReplacementTest self shouldnt: [self replacementCollection ]raise: Error. self shouldnt: [self oldSubCollection] raise: Error. self shouldnt: [self collectionWith1TimeSubcollection ]raise: Error. self assert: (self howMany: self oldSubCollection in: self collectionWith1TimeSubcollection ) = 1. ! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureCreationWithTest self shouldnt: [ self collectionMoreThan5Elements ] raise: Error. self assert: self collectionMoreThan5Elements size >= 5.! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureEmptySequenceableTest self shouldnt: [ self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty . self shouldnt: [ self empty ] raise: Error. self assert: self empty isEmpty.! ! !ArrayTest methodsFor: 'tests - fixture' stamp: 'CamilloBruni 11/2/2012 15:57'! test0FixtureIncludeTest | anElementIn | self shouldnt: [ self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self elementNotIn ] raise: Error. anElementIn := true. self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self shouldnt: [ self anotherElementNotIn ] raise: Error. anElementIn := true. self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self shouldnt: [ self collection ] raise: Error. self shouldnt: [ self empty ] raise: Error. self assert: self empty isEmpty. self shouldnt: [ self collectionOfFloat ] raise: Error. self collectionOfFloat do: [ :each | self assert: each class = Float ]. self shouldnt: [ self elementInForIncludesTest ] raise: Error. anElementIn := true. self nonEmpty detect: [ :each | each = self elementInForIncludesTest ] ifNone: [ anElementIn := false ]. self assert: anElementIn = true! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureIncludeWithIdentityTest | anElement | self shouldnt: [ self collectionWithCopyNonIdentical ]raise: Error. anElement := self collectionWithCopyNonIdentical anyOne. self deny: anElement == anElement copy.! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureIndexAccessFotMultipliness self shouldnt: [ self collectionWithSameAtEndAndBegining ] raise: Error. 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 - fixture'! test0FixtureIndexAccessTest | res collection element | self shouldnt: [ self collectionMoreThan1NoDuplicates ] raise: Error. 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 shouldnt: [ self elementInForIndexAccessing ] raise: Error. self assert: ( (collection := self collectionMoreThan1NoDuplicates )includes: (element:= self elementInForIndexAccessing)). self shouldnt: [ self elementNotInForIndexAccessing ] raise: Error. self deny: (self collectionMoreThan1NoDuplicates includes: self elementNotInForIndexAccessing)! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureIterateSequencedReadableTest | res | self shouldnt: self nonEmptyMoreThan1Element raise: Error. self assert: self nonEmptyMoreThan1Element size > 1. self shouldnt: self empty raise: Error. 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 - fixture'! test0FixtureOccurrencesForMultiplinessTest | cpt anElement collection | self shouldnt: [ self collectionWithEqualElements ] raise: Error. self shouldnt: [ self collectionWithEqualElements ] raise: Error. self shouldnt: [ self elementTwiceInForOccurrences ] raise: Error. 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 - fixture' stamp: 'delaunay 4/2/2009 11:53'! test0FixtureOccurrencesTest self shouldnt: self empty raise: Error. self assert: self empty isEmpty. self shouldnt: self nonEmpty raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: self elementInForOccurrences raise: Error. self assert: (self nonEmpty includes: self elementInForOccurrences). self shouldnt: self elementNotInForOccurrences raise: Error. self deny: (self nonEmpty includes: self elementNotInForOccurrences)! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixturePrintTest self shouldnt: [self nonEmpty ] raise: Error.! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixturePutOneOrMoreElementsTest self shouldnt: self aValue raise: Error. self shouldnt: self indexArray raise: Error. 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 shouldnt: self empty raise: Error. self assert: self empty isEmpty . self shouldnt: self nonEmpty raise: Error. self deny: self nonEmpty isEmpty.! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixturePutTest self shouldnt: self aValue raise: Error. self shouldnt: self anotherValue raise: Error. self shouldnt: self anIndex raise: Error. self nonEmpty isDictionary ifFalse:[self assert: (self anIndex >=1 & self anIndex <= self nonEmpty size).]. self shouldnt: self empty raise: Error. self assert: self empty isEmpty . self shouldnt: self nonEmpty raise: Error. self deny: self nonEmpty isEmpty.! ! !ArrayTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/14/2009 11:50'! test0FixtureSequencedConcatenationTest self shouldnt: self empty raise: Exception. self assert: self empty isEmpty. self shouldnt: self firstCollection raise: Exception. self shouldnt: self secondCollection raise: Exception! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureSequencedElementAccessTest self shouldnt: [ self moreThan4Elements ] raise: Error. self assert: self moreThan4Elements size >= 4. self shouldnt: [ self subCollectionNotIn ] raise: Error. self subCollectionNotIn detect: [ :each | (self moreThan4Elements includes: each) not ] ifNone: [ self assert: false ]. self shouldnt: [ self elementNotInForElementAccessing ] raise: Error. self deny: (self moreThan4Elements includes: self elementNotInForElementAccessing). self shouldnt: [ self elementInForElementAccessing ] raise: Error. self assert: (self moreThan4Elements includes: self elementInForElementAccessing)! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureSetAritmeticTest self shouldnt: [ self collection ] raise: Error. self deny: self collection isEmpty. self shouldnt: [ self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self anotherElementOrAssociationNotIn ] raise: Error. self collection isDictionary ifTrue: [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ] ifFalse: [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ]. self shouldnt: [ self collectionClass ] raise: Error! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureSubcollectionAccessTest self shouldnt: [ self moreThan3Elements ] raise: Error. self assert: self moreThan3Elements size > 2! ! !ArrayTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/28/2009 14:11'! test0FixtureTConvertAsSetForMultiplinessTest "a collection ofFloat with equal elements:" | res | self shouldnt: [ self withEqualElements ] raise: Error. self shouldnt: [ self withEqualElements do: [ :each | self assert: each class = Float ] ] raise: Error. 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 shouldnt: [ self elementsCopyNonIdenticalWithoutEqualElements ] raise: Error. self shouldnt: [ self elementsCopyNonIdenticalWithoutEqualElements do: [ :each | self assert: each class = Float ] ] raise: Error. res := true. self elementsCopyNonIdenticalWithoutEqualElements detect: [ :each | (self elementsCopyNonIdenticalWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false! ! !ArrayTest methodsFor: 'tests - fixture'! test0FixtureTConvertTest "a collection of number without equal elements:" | res | self shouldnt: [ self collectionWithoutEqualElements ]raise: Error. res := true. self collectionWithoutEqualElements detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false. ! ! !ArrayTest methodsFor: 'tests - fixture'! test0SortingArrayedTest | tmp sorted | " an unsorted collection of number " self shouldnt: [ self unsortedCollection ]raise: Error. 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 shouldnt: [ self sortedInAscendingOrderCollection ]raise: Error. self sortedInAscendingOrderCollection do:[:each | each isNumber]. tmp:= self sortedInAscendingOrderCollection at:1. self sortedInAscendingOrderCollection do: [: each | self assert: (each>= tmp). tmp:=each] ! ! !ArrayTest methodsFor: 'tests - fixture'! test0TSequencedStructuralEqualityTest self shouldnt: [self nonEmpty at: 1] raise: Error. "Ensures #nonEmpty is sequenceable"! ! !ArrayTest methodsFor: 'tests - fixture'! test0TStructuralEqualityTest self shouldnt: [self empty] raise: Error. self shouldnt: [self nonEmpty] raise: Error. self assert: self empty isEmpty. self deny: self nonEmpty isEmpty.! ! !ArrayTest methodsFor: 'tests - fixture'! testOFixtureReplacementSequencedTest self shouldnt: self nonEmpty raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: self elementInForReplacement raise: Error. self assert: (self nonEmpty includes: self elementInForReplacement ) . self shouldnt: self newElement raise: Error. self shouldnt: self firstIndex raise: Error. self assert: (self firstIndex >= 1 & self firstIndex <= self nonEmpty size). self shouldnt: self secondIndex raise: Error. self assert: (self secondIndex >= 1 & self secondIndex <= self nonEmpty size). self assert: self firstIndex <=self secondIndex . self shouldnt: self replacementCollection raise: Error. self shouldnt: self replacementCollectionSameSize raise: Error. self assert: (self secondIndex - self firstIndex +1)= self replacementCollectionSameSize size ! ! !ArrayTest methodsFor: 'tests - includes' stamp: 'delaunay 4/28/2009 10:22'! 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 shouldnt: [ self collectionWithCopyNonIdentical ] raise: Error. collection := self collectionWithCopyNonIdentical. element := collection anyOne copy. "self assert: (collection includes: element)." self deny: (collection identityIncludes: element)! ! !ArrayTest methodsFor: 'tests - includes'! 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: 'tests - includes'! testIncludesAllNoneThere "self debug: #testIncludesAllOfNoneThere'" self deny: (self empty includesAll: self nonEmpty ). self deny: (self nonEmpty includesAll: { self elementNotIn. self anotherElementNotIn })! ! !ArrayTest methodsFor: 'tests - includes'! 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: 'tests - includes'! testIncludesAnyNoneThere "self debug: #testIncludesAnyOfNoneThere'" self deny: (self nonEmpty includesAny: self empty). self deny: (self nonEmpty includesAny: { self elementNotIn. self anotherElementNotIn })! ! !ArrayTest methodsFor: 'tests - includes'! 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: 'tests - includes'! testIncludesElementIsThere "self debug: #testIncludesElementIsThere" self assert: (self nonEmpty includes: self nonEmpty anyOne).! ! !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: 'tests - index access' stamp: 'delaunay 4/15/2009 14:22'! testIdentityIndexOfIAbsent "self debug: #testIdentityIndexOfIfAbsent" | collection element | element := self elementInCollectionOfFloat copy. self deny: self elementInCollectionOfFloat == element. collection := self collectionOfFloat copyWith: element. self assert: (collection identityIndexOf: element ifAbsent: [ 0 ]) = collection size. self assert: (self collectionOfFloat identityIndexOf: element ifAbsent: [ 55 ]) = 55! ! !ArrayTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 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 - index access' stamp: 'delaunay 4/23/2009 15:14'! 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 - index access' stamp: 'delaunay 4/23/2009 15:14'! 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 - index access'! 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: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 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: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 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: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 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 - index access' stamp: 'delaunay 4/23/2009 15:14'! 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: 'delaunay 4/23/2009 15:14'! 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 - index accessing for multipliness'! testIdentityIndexOfDuplicate "self debug: #testIdentityIndexOf" | collection element | "testing fixture here as this method may not be used by some collections testClass" self shouldnt: [self collectionWithNonIdentitySameAtEndAndBegining ] raise: Error. 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: 'tests - index accessing for multipliness'! 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 - index accessing for multipliness'! 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 - index accessing for multipliness'! 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 - index accessing for multipliness'! 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 - index accessing for multipliness'! 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: 'tests - index accessing for multipliness'! 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 - index accessing for multipliness'! 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 - iterate on sequenced reable collections'! 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: 'tests - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! testFindFirst | element result | element := self nonEmptyMoreThan1Element at:1. result:=self nonEmptyMoreThan1Element findFirst: [:each | each =element]. self assert: result=1. ! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testFindFirstNotIn | result | result:=self empty findFirst: [:each | true]. self assert: result=0. ! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! testFindLastNotIn | result | result:=self empty findFirst: [:each | true]. self assert: result=0. ! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 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: 'tests - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! testKeysAndValuesDoEmpty | result | result:= OrderedCollection new. self empty keysAndValuesDo: [:i :value| result add: (value+i)]. self assert: result isEmpty .! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! 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: 'tests - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! testReverseDoEmpty | result | result:= OrderedCollection new. self empty reverseDo: [: each | result add: each]. self assert: result isEmpty .! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! testWithCollectError self should: [self nonEmptyMoreThan1Element with: self empty collect:[:a :b | ]] raise: Error.! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 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: 'tests - iterate on sequenced reable collections'! testWithDoError self should: [self nonEmptyMoreThan1Element with: self empty do:[:a :b | ]] raise: Error.! ! !ArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 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: 'tests - iterate on sequenced reable collections'! 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 - 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 - occurrencesOf' stamp: 'delaunay 4/2/2009 11:52'! testOccurrencesOfEmpty | result | result := self empty occurrencesOf: self elementInForOccurrences. self assert: result = 0! ! !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 - occurrencesOf for multipliness'! testOccurrencesOfForMultipliness | collection elem | collection := self collectionWithEqualElements . elem := self elementTwiceInForOccurrences . self assert: (collection occurrencesOf: elem ) = 2. ! ! !ArrayTest methodsFor: 'tests - printing'! 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 - printing'! 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 - printing'! 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 - printing'! 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: 'tests - printing'! 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 - printing'! 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 - puting with indexes'! testAtAllIndexesPut self nonEmpty atAllPut: self aValue. self nonEmpty do:[ :each| self assert: each = self aValue]. ! ! !ArrayTest methodsFor: 'tests - puting with indexes'! testAtAllPut | | self nonEmpty atAll: self indexArray put: self aValue.. self indexArray do: [:i | self assert: (self nonEmpty at: i)=self aValue ]. ! ! !ArrayTest methodsFor: 'tests - puting with indexes'! 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 - puting with indexes'! 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 - puting with indexes'! 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 - puting with indexes'! 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 - puting with indexes' stamp: 'Anonymous 5/24/2010 14:30'! 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 - replacing'! 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 - replacing'! 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: 'tests - replacing'! 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: 'tests - sequence isempty'! testSequenceAbleIfEmptyifNotEmptyDo "self debug: #testSequenceAbleIfEmptyifNotEmptyDo" self assert: (self nonEmpty ifEmpty: [false] ifNotEmptyDo: [:s | (self accessValuePutInOn: s) = self valuePutIn]).! ! !ArrayTest methodsFor: 'tests - sequence isempty'! testSequenceIfEmptyifNotEmptyDo "self debug #testSequenceIfEmptyifNotEmptyDo" self assert: (self nonEmpty ifEmpty: [false] ifNotEmptyDo: [:s | (self accessValuePutInOn: s) = self valuePutIn]).! ! !ArrayTest methodsFor: 'tests - sequence isempty'! testSequenceIfNotEmpty self assert: (self nonEmpty ifNotEmpty: [:s | self accessValuePutInOn: s]) = self valuePutIn! ! !ArrayTest methodsFor: 'tests - sequence isempty'! testSequenceIfNotEmptyDo self empty ifNotEmptyDo: [:s | self assert: false]. self assert: (self nonEmpty ifNotEmptyDo: [:s | self accessValuePutInOn: s]) = self valuePutIn ! ! !ArrayTest methodsFor: 'tests - sequence isempty'! testSequenceIfNotEmptyDoifNotEmpty self assert: (self nonEmpty ifNotEmptyDo: [:s | (self accessValuePutInOn: s) = self valuePutIn] ifEmpty: [false])! ! !ArrayTest methodsFor: 'tests - sequence isempty'! testSequenceIfNotEmptyifEmpty self assert: (self nonEmpty ifEmpty: [false] ifNotEmpty: [:s | (self accessValuePutInOn: s) = self valuePutIn])! ! !ArrayTest methodsFor: 'tests - set arithmetic'! 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 - set arithmetic'! numberOfSimilarElementsInIntersection ^ self collection occurrencesOf: self anotherElementOrAssociationIn! ! !ArrayTest methodsFor: 'tests - set arithmetic'! 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: 'tests - set arithmetic'! 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 - set arithmetic'! 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 = 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 = separateCol! ! !ArrayTest methodsFor: 'tests - set arithmetic'! 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'! 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 - set arithmetic'! 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: 'tests - set arithmetic'! 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: 'tests - set arithmetic'! 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 - set arithmetic'! testUnionOfEmpties "self debug: #testUnionOfEmpties" self assert: (self empty union: self empty) isEmpty. ! ! !ArrayTest methodsFor: 'tests - sorting'! testIsSorted self assert: self sortedInAscendingOrderCollection isSorted. self deny: self unsortedCollection isSorted! ! !ArrayTest methodsFor: 'tests - sorting'! testIsSortedBy self assert: (self sortedInAscendingOrderCollection isSortedBy: [:a :b | ab]). ! ! !ArrayTest methodsFor: 'tests - sorting'! testSort | result tmp | result := self unsortedCollection sort. tmp := result at: 1. result do: [:each | self assert: each>=tmp. tmp:= each. ].! ! !ArrayTest methodsFor: 'tests - sorting'! 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 - sorting'! testSorted | result tmp | result := self unsortedCollection sorted. tmp := result at: 1. result do: [:each | self assert: each>=tmp. tmp:= each. ].! ! !ArrayTest methodsFor: 'tests - sorting'! 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 - subcollections access'! 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 - subcollections access'! 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 - subcollections access'! 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: 'tests - subcollections access'! 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 - subcollections access'! 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: 'tests - subcollections access'! 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 class uses: TEmptySequenceableTest classTrait + TSequencedElementAccessTest classTrait + TCloneTest classTrait + TCopyTest classTrait + TSetArithmetic classTrait + TCreationWithTest classTrait + TPutBasicTest classTrait + TConvertTest classTrait + TSortTest classTrait + TIterateSequencedReadableTest classTrait + TSequencedConcatenationTest classTrait + TReplacementSequencedTest classTrait + TAsStringCommaAndDelimiterSequenceableTest classTrait + TBeginsEndsWith classTrait + TPrintOnSequencedTest classTrait + TIndexAccess classTrait + TSubCollectionAccess classTrait + TCopyPartOfSequenceable classTrait + TCopySequenceableSameContents classTrait + TCopySequenceableWithOrWithoutSpecificElements classTrait + TCopySequenceableWithReplacement classTrait + TIndexAccessForMultipliness classTrait + TCopyPartOfSequenceableForMultipliness classTrait + TConvertAsSortedTest classTrait + TPutTest classTrait + TIncludesWithIdentityCheckTest classTrait + TConvertAsSetForMultiplinessIdentityTest classTrait + TSequencedStructuralEqualityTest classTrait + TOccurrencesForMultiplinessTest classTrait instanceVariableNames: ''! SequenceableCollection subclass: #ArrayedCollection uses: TSortable instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Abstract'! !ArrayedCollection commentStamp: '' prior: 0! I am an abstract collection of elements with a fixed range of integers (from 1 to n>=0) as external keys.! !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: '*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: 'accessing' stamp: 'sma 5/12/2000 11:36'! size "Answer how many elements the receiver contains." ^ self basicSize! ! !ArrayedCollection methodsFor: 'adding' stamp: 'sma 5/12/2000 14:09'! add: newObject self shouldNotImplement! ! !ArrayedCollection methodsFor: 'objects from disk' stamp: 'nk 3/17/2004 15:22'! byteSize ^self basicSize * self bytesPerBasicElement ! ! !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'! 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: '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: '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: 'printing'! 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: 'removing' stamp: 'klub 9/14/2009 16:27'! removeAll self shouldNotImplement! ! !ArrayedCollection methodsFor: 'sorting'! 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! ! !ArrayedCollection methodsFor: 'sorting'! 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! ! !ArrayedCollection methodsFor: 'sorting'! 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]! ! !ArrayedCollection methodsFor: 'sorting'! 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! ! !ArrayedCollection methodsFor: 'sorting'! 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! ! !ArrayedCollection methodsFor: 'sorting'! sort "Sort this collection into ascending order using the '<=' operator." self sort: [:a :b | a <= b]! ! !ArrayedCollection methodsFor: 'sorting'! 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! ! !ArrayedCollection methodsFor: 'private'! defaultElement ^nil! ! !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'! 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 class uses: TSortable classTrait instanceVariableNames: ''! !ArrayedCollection class methodsFor: 'instance creation'! new "Answer a new instance of me, with size = 0." ^self new: 0! ! !ArrayedCollection class methodsFor: 'instance creation'! 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'! 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: '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'! 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'! 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! ! !ArrayedCollection class methodsFor: 'instance creation'! 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'! 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'! 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: '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: '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! ! Halt subclass: #AssertionFailure instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Exceptions'! !AssertionFailure commentStamp: 'gh 5/2/2002 20:29' prior: 0! AsssertionFailure is the exception signaled from Object>>assert: when the assertion block evaluates to false.! ParseNode subclass: #AssignmentNode instanceVariableNames: 'variable value' classVariableNames: '' poolDictionaries: '' category: 'Compiler-ParseNodes'! !AssignmentNode commentStamp: '' prior: 0! AssignmentNode comment: 'I represent a (var_expr) construct.'! !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 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: 'code generation' stamp: 'eem 5/20/2008 15:16'! sizeCodeForEffect: encoder ^(variable sizeCodeForLoad: encoder) + (value sizeCodeForValue: encoder) + (variable sizeCodeForStorePop: 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: '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: 'equation translation'! variable ^variable! ! !AssignmentNode methodsFor: 'initialize-release'! toDoIncrement: var var = variable ifFalse: [^ nil]. (value isMemberOf: MessageNode) ifTrue: [^ value toDoIncrement: var] ifFalse: [^ nil]! ! !AssignmentNode methodsFor: 'initialize-release'! value ^ value! ! !AssignmentNode methodsFor: 'initialize-release'! variable: aVariable value: expression variable := aVariable. value := expression! ! !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: '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! ! !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: 'printing' stamp: 'eem 6/2/2008 11:47'! printWithClosureAnalysisOn: aStream indent: level variable printWithClosureAnalysisOn: aStream indent: level. aStream nextPutAll: ' := '. value printWithClosureAnalysisOn: aStream indent: level + 2! ! !AssignmentNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! printWithClosureAnalysisOn: aStream indent: level precedence: p aStream nextPut: $(. self printWithClosureAnalysisOn: aStream indent: level. aStream nextPut: $)! ! !AssignmentNode methodsFor: 'testing' stamp: 'eem 6/16/2008 09:37'! isAssignmentNode ^true! ! !AssignmentNode methodsFor: 'visiting' stamp: 'eem 9/6/2009 12:33'! accept: aVisitor ^aVisitor visitAssignmentNode: self! ! LookupKey subclass: #Association instanceVariableNames: 'value' classVariableNames: '' poolDictionaries: '' category: 'Collections-Support'! !Association commentStamp: 'StephaneDucasse 2/13/2010 15:13' prior: 0! 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: '*System-Settings-Browser' stamp: 'alain.plantec 3/24/2009 23:20'! settingFixedDomainValueNodeFrom: aSettingNode ^ aSettingNode fixedDomainValueNodeForAssociation: self! ! !Association methodsFor: 'accessing'! key: aKey value: anObject "Store the arguments as the variables of the receiver." key := aKey. value := anObject! ! !Association methodsFor: 'accessing'! value "Answer the value of the receiver." ^value! ! !Association methodsFor: 'accessing'! value: anObject "Store the argument, anObject, as the value of the receiver." value := anObject! ! !Association methodsFor: 'comparing' stamp: 'md 1/27/2004 17:27'! = anAssociation ^ super = anAssociation and: [value = anAssociation value]! ! !Association methodsFor: 'printing'! printOn: aStream super printOn: aStream. aStream nextPutAll: '->'. value printOn: aStream! ! !Association methodsFor: 'printing'! storeOn: aStream "Store in the format (key->value)" aStream nextPut: $(. key storeOn: aStream. aStream nextPutAll: '->'. value storeOn: aStream. aStream nextPut: $)! ! !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: '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 class instanceVariableNames: ''! !Association class methodsFor: 'instance creation'! 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! ! ClassTestCase subclass: #AssociationTest instanceVariableNames: 'a b' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Support'! !AssociationTest methodsFor: 'setup' stamp: 'zz 12/5/2005 18:33'! setUp a := 1 -> 'one'. b := 1 -> 'een'.! ! !AssociationTest methodsFor: 'tests' stamp: 'ab 12/29/2008 07:59'! testComparison self assert: ((#a -> 'foo') < (#b -> 'zork'))! ! !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: 'al 10/13/2008 20:32'! testHash self assert: (a hash = a copy hash); assert: (a hash = b hash)! ! !AssociationTest methodsFor: 'tests' stamp: 'jb 7/1/2011 10:40'! testIsSelfEvaluating | anotherAssociation | self assert: (a isSelfEvaluating). self assert: (a printString = '1->''one'''). anotherAssociation := Object new -> Object new. anotherAssociation isSelfEvaluating ifTrue: [self assert: (self class evaluatorClass evaluate: anotherAssociation printString) = anotherAssociation description: 'a self evaluating should evaluate as self']. ! ! Object subclass: #AsyncFile instanceVariableNames: 'name writeable semaphore fileHandle' classVariableNames: 'Busy ErrorCode' poolDictionaries: '' category: 'Files-Kernel'! !AsyncFile commentStamp: 'HenrikSperreJohansen 2/16/2012 11:40' prior: 0! 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: 'stephaneducasse 2/4/2006 20:31'! close fileHandle ifNil: [^ self]. "already closed" self primClose: fileHandle. Smalltalk unregisterExternalObject: semaphore. semaphore := nil. fileHandle := nil. ! ! !AsyncFile methodsFor: 'as yet unclassified' stamp: 'di 7/6/1998 10:58'! fileHandle ^ fileHandle! ! !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 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: '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: 'as yet unclassified' stamp: 'di 7/6/1998 10:58'! waitForCompletion semaphore wait! ! !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'! primClose: fHandle "Close this file. Do nothing if primitive fails." ! ! !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: '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: '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'! 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 class instanceVariableNames: ''! !AsyncFile class methodsFor: 'initialization' stamp: 'bootstrap 5/31/2006 20:45'! initialize "AsyncFile initialize" "Possible abnormal I/O completion results." Busy := -1. ErrorCode := -2. ! ! Object subclass: #AtomicCollection instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Atomic'! !AtomicCollection commentStamp: 'Igor.Stasenko 10/16/2010 03:54' prior: 0! I am just a base abstract class, containing common behavior for various queue types! !AtomicCollection methodsFor: 'copying' stamp: 'Igor.Stasenko 10/16/2010 04:09'! copy ^ self errorDontCopy! ! !AtomicCollection methodsFor: 'copying' stamp: 'Igor.Stasenko 10/16/2010 04:09'! deepCopy ^ self errorDontCopy! ! !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: '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"! ! !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: '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: '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! ! Object subclass: #AtomicQueueItem instanceVariableNames: 'next object' classVariableNames: '' poolDictionaries: '' category: 'Collections-Atomic'! !AtomicQueueItem commentStamp: 'Igor.Stasenko 10/16/2010 02:29' prior: 0! 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 17:45'! isCircular ^ next == self! ! !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 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 16:52'! object "Answer the value of object" ^ object! ! !AtomicQueueItem methodsFor: 'accessing' stamp: 'Igor.Stasenko 10/15/2010 16:52'! object: anObject "Set the value of object" object := anObject! ! !AtomicQueueItem methodsFor: 'initialize-release' stamp: 'IgorStasenko 2/28/2011 16:00'! initialize "make circular" super initialize. next := self.! ! WaitfreeQueue subclass: #AtomicSharedQueue instanceVariableNames: 'availSema' classVariableNames: '' poolDictionaries: '' category: 'Collections-Atomic'! !AtomicSharedQueue commentStamp: 'IgorStasenko 2/28/2011 15:33' prior: 0! 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: 'initialize-release' stamp: 'Igor.Stasenko 10/15/2010 16:59'! initialize super initialize. availSema := Semaphore new. ! ! !AtomicSharedQueue methodsFor: 'signaling' stamp: 'Igor.Stasenko 10/15/2010 17:00'! signalAddedNewItem availSema signal! ! !AtomicSharedQueue methodsFor: 'signaling' stamp: 'Igor.Stasenko 10/16/2010 01:45'! signalNoMoreItems "queue is empty, reset sema signals" availSema initSignals ! ! !AtomicSharedQueue methodsFor: 'signaling' stamp: 'Igor.Stasenko 10/15/2010 17:00'! waitForNewItems availSema wait! ! ComposableModel subclass: #Authentifier instanceVariableNames: 'gmail passwordField passwordLabel result userField userLabel' classVariableNames: '' poolDictionaries: '' category: 'CI-Core-SliceSubmitter'! !Authentifier commentStamp: '' prior: 0! An Authentifier is a UI made for specifying username and password! !Authentifier methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/4/2012 14:57'! gmail ^ gmail! ! !Authentifier methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/4/2012 14:57'! passwordField ^ passwordField! ! !Authentifier methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/4/2012 14:57'! passwordLabel ^ passwordLabel! ! !Authentifier methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/4/2012 14:57'! userField ^ userField! ! !Authentifier methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/4/2012 14:57'! userLabel ^ userLabel! ! !Authentifier methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 2/10/2013 14:43'! initializeDialogWindow: aWindow aWindow okAction: [ | user password | user := userField getText. password := passwordField getText. (user isEmpty or: [ password isEmpty ]) ifFalse: [ result contents: (user -> password) ]]. aWindow toolbar okButton keyStrokeForNextFocus: Character tab asShortcut; keyStrokeForPreviousFocus: Character tab shift asShortcut. aWindow toolbar cancelButton keyStrokeForNextFocus: Character tab asShortcut; keyStrokeForPreviousFocus: Character tab shift asShortcut. self focusOrder add: userField; add: passwordField; add: aWindow toolbar.! ! !Authentifier methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 2/10/2013 14:43'! initializeWidgets self instantiateModels: #( userLabel LabelModel userField TextInputFieldModel gmail LabelModel passwordLabel LabelModel passwordField TextInputFieldModel ). userLabel text: 'Username:'. userField entryCompletion: nil; autoAccept: true; keyStrokeForNextFocus: Character tab asShortcut; keyStrokeForPreviousFocus: Character tab shift asShortcut; ghostText: 'username'. gmail text: '@gmail.com'. passwordLabel text: 'Password:'. passwordField autoAccept: true; acceptOnCR: true; ghostText: 'password'; entryCompletion: nil; keyStrokeForNextFocus: Character tab asShortcut; keyStrokeForPreviousFocus: Character tab shift asShortcut; beEncrypted.! ! !Authentifier methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 7/4/2012 15:05'! initialize "Initialization code for Authentifier" super initialize. result := nil asValueHolder.! ! !Authentifier methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/4/2012 15:00'! initialExtent ^ (400@180)! ! !Authentifier methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/4/2012 15:04'! result ^ result contents! ! !Authentifier methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/4/2012 15:51'! title ^ 'Enter username and password'! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Authentifier class instanceVariableNames: ''! !Authentifier class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 7/4/2012 14:57'! spec ^ SpecLayout composed add: #userLabel origin: 0@0 corner: 0@0 offsetOrigin: 0@0 offsetCorner: 200@25; add: #userField origin: 0@0 corner: 0@0 offsetOrigin: 0@25 offsetCorner: 300@50; add: #gmail origin: 0@0 corner: 0@0 offsetOrigin: 300@25 offsetCorner: 400@50; add: #passwordLabel origin: 0@0 corner: 0@0 offsetOrigin: 0@50 offsetCorner: 200@75; add: #passwordField origin: 0@0 corner: 0@0 offsetOrigin: 0@75 offsetCorner: 300@100; yourself! ! Object subclass: #Author instanceVariableNames: 'fullName' classVariableNames: '' poolDictionaries: '' category: 'System-Support'! !Author commentStamp: 'MiguelCoba 7/25/2009 01:09' prior: 0! I am responsible for the full name used to identify the current code author.! !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: 'accessing'! 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: 'accessing' stamp: 'PavelKrivanek 2/8/2013 12:05'! fullName: aString fullName := aString. Smalltalk globals at: #UsersManager ifPresent: [:usersManager | usersManager default currentUser setUserName: aString forGroup: #author].! ! !Author methodsFor: 'accessing' stamp: 'PavelKrivanek 2/8/2013 12:05'! fullNamePerSe "Answer the currently-prevailing author full name, such as it is, empty or not" ^ Smalltalk globals at: #UsersManager ifPresent: [:usersManager | usersManager default currentUser userNameFor: #author] ifAbsent: [ fullName ] ! ! !Author methodsFor: 'compatibility'! ifUnknownAuthorUse: aString during: aBlock "If no author is set use the name aString while executing aBlock." "for compatibility with 1.0" | previous | fullName isEmptyOrNil ifFalse: [ ^ aBlock value ]. fullName := aString. ^ aBlock ensure: [ self reset ]! ! !Author methodsFor: 'compatibility'! reset fullName := ''! ! !Author methodsFor: 'initialization'! initialize super initialize. fullName := ''.! ! !Author methodsFor: 'testing-support'! useAuthor: aString during: aBlock | previous | previous := fullName. fullName := aString. ^ aBlock ensure: [ fullName := previous ]! ! !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 class instanceVariableNames: 'uniqueInstance'! !Author class methodsFor: 'convenience'! fullName ^ Author uniqueInstance fullName! ! !Author class methodsFor: 'convenience'! fullName: aString ^ Author uniqueInstance checkAndSetFullNameWith: aString! ! !Author class methodsFor: 'convenience'! fullNamePerSe ^ Author uniqueInstance fullNamePerSe! ! !Author class methodsFor: 'convenience'! requestFullName ^ Author uniqueInstance requestFullName! ! !Author class methodsFor: 'instance creation'! new self error: 'Author is a singleton -- send uniqueInstance instead'! ! !Author class methodsFor: 'instance creation'! reset ^ uniqueInstance := nil! ! !Author class methodsFor: 'instance creation'! uniqueInstance ^ uniqueInstance ifNil: [ uniqueInstance := super new ]! ! !Author class methodsFor: 'instance creation'! uniqueInstance: anInstance "Needed by AuthorTest to restore saved instance" ^ uniqueInstance := anInstance! ! !Author class methodsFor: 'testing-support'! useAuthor: aString during: aBlock ^ self uniqueInstance useAuthor: aString during: aBlock! ! !Author class methodsFor: 'utilities'! 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: 'utilities'! 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: 'utilities'! fixStamp: changeStamp | parts | parts := changeStamp findTokens: ' '. (parts size > 0 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! ! Notification subclass: #AuthorNameRequest instanceVariableNames: 'initialAnswer' classVariableNames: '' poolDictionaries: '' category: 'System-Support'! !AuthorNameRequest commentStamp: '' prior: 0! I am used to request a new author name.! !AuthorNameRequest methodsFor: 'accessing' stamp: 'CamilloBruni 10/20/2012 21:03'! initialAnswer ^ initialAnswer! ! !AuthorNameRequest methodsFor: 'accessing' stamp: 'CamilloBruni 10/20/2012 21:03'! initialAnswer: anObject initialAnswer := anObject! ! !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 instanceVariableNames: ''! !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 '! ! TestCase subclass: #AuthorTest instanceVariableNames: 'author' classVariableNames: '' poolDictionaries: '' category: 'Tests-System'! !AuthorTest methodsFor: 'running' stamp: 'on 5/10/2008 13:31'! setUp author := Author uniqueInstance. Author reset.! ! !AuthorTest methodsFor: 'running' stamp: 'on 5/10/2008 13:21'! tearDown Author uniqueInstance: author! ! !AuthorTest methodsFor: 'running' stamp: 'on 5/10/2008 13:35'! testUniqueness self should: [ Author new ] raise: Error.! ! Object subclass: #Authorizer instanceVariableNames: 'users realm' classVariableNames: '' poolDictionaries: '' category: 'Network-Url'! !Authorizer commentStamp: '' prior: 0! The Authorizer does user authorization checking. Each instance of authorizer keeps track of the realm that it is authorizing for, and the table of authorized users. An authorizer can be asked to return the user name/symbol associated with a userID (which concatenates the username and password from the HTTP request) with the user: method. ! !Authorizer methodsFor: 'authentication' stamp: 'PeterHugossonMiller 9/3/2009 00:12'! encode: nameString password: pwdString "Encode per RFC1421 of the username:password combination." | clear code clearSize idx map | clear := (nameString, ':', pwdString) asByteArray. clearSize := clear size. [ clear size \\ 3 ~= 0 ] whileTrue: [ clear := clear, #(0) ]. idx := 1. map := 'ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/'. code := String new writeStream. [ idx < clear size ] whileTrue: [ code nextPut: (map at: (clear at: idx) // 4 + 1); nextPut: (map at: (clear at: idx) \\ 4 * 16 + ((clear at: idx + 1) // 16) + 1); nextPut: (map at: (clear at: idx + 1) \\ 16 * 4 + ((clear at: idx + 2) // 64) + 1); nextPut: (map at: (clear at: idx + 2) \\ 64 + 1). idx := idx + 3 ]. code := code contents. idx := code size. clear size - clearSize timesRepeat: [ code at: idx put: $=. idx := idx - 1]. ^code! ! !Authorizer methodsFor: 'authentication' stamp: 'mjg 11/3/97 12:31'! mapFrom: aKey to: aPerson "Establish a mapping from a RFC 1421 key to a user." users isNil ifTrue: [ users := Dictionary new ]. aPerson isNil ifTrue: [ users removeKey: aKey ] ifFalse: [ users removeKey: (users keyAtValue: aPerson ifAbsent: []) ifAbsent: []. users at: aKey put: aPerson ] ! ! !Authorizer methodsFor: 'authentication' stamp: 'tk 5/21/1998 16:32'! mapName: nameString password: pwdString to: aPerson "Insert/remove the encoding per RFC1421 of the username:password combination into/from the UserMap. DO NOT call this directly, use mapName:password:to: in your ServerAction class. Only it knows how to record the change on the disk!!" self mapFrom: (self encode: nameString password: pwdString) to: aPerson ! ! !Authorizer methodsFor: 'authentication' stamp: 'ar 8/17/2001 18:19'! user: userId "Return the requesting user." ^users at: userId ifAbsent: [ self error: (self class unauthorizedFor: realm) ]! ! !Authorizer methodsFor: 'realms' stamp: 'mjg 11/3/97 12:33'! realm ^realm! ! !Authorizer methodsFor: 'realms' stamp: 'mjg 11/3/97 12:33'! realm: aString realm := aString ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Authorizer class instanceVariableNames: ''! !Authorizer class methodsFor: 'as yet unclassified' stamp: 'adrian_lienhard 7/18/2009 15:52'! unauthorizedFor: realm ^'HTTP/1.0 401 Unauthorized', self crlf, 'WWW-Authenticate: Basic realm="Pharo/',realm,'"', String crlfcrlf, 'Unauthorized

Unauthorized for ',realm, '

' ! ! TotalCost subclass: #AverageCost instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CompilerTests'! !AverageCost commentStamp: 'StephaneDucasse 6/9/2010 20:53' prior: 0! 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! ! ImageReadWriter subclass: #BMPReadWriter instanceVariableNames: 'bfType bfSize bfOffBits biSize biWidth biHeight biPlanes biBitCount biCompression biSizeImage biXPelsPerMeter biYPelsPerMeter biClrUsed biClrImportant' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Files'! !BMPReadWriter commentStamp: 'LaurentLaffont 5/4/2011 21:27' prior: 0! 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: '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: '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: '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'! 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: '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: '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 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: '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 class instanceVariableNames: ''! !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')! ! !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: '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) ].! ! TestCase subclass: #BMPReadWriterTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Tests-Files'! !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: '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 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: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: '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: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 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: '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: '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: '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'! 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! ! !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'! 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! ! Object subclass: #BadEqualer instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Core-Utilities'! !BadEqualer commentStamp: 'mjr 8/20/2003 13:28' prior: 0! 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 ! ! Object subclass: #BadHasher instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Core-Utilities'! !BadHasher commentStamp: 'mjr 8/20/2003 13:28' prior: 0! 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! ! Collection subclass: #Bag instanceVariableNames: 'contents' classVariableNames: '' poolDictionaries: '' category: 'Collections-Unordered'! !Bag commentStamp: '' prior: 0! 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: 'accessing' stamp: 'sma 5/12/2000 17:23'! at: index self errorNotKeyed! ! !Bag methodsFor: 'accessing' stamp: 'sma 5/12/2000 17:23'! at: index put: anObject self errorNotKeyed! ! !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: '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: '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: '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: 'accessing' stamp: 'md 1/20/2006 15:58'! valuesAndCounts ^ contents! ! !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: '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: '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: 'converting' stamp: 'sma 5/12/2000 14:34'! asBag ^ self! ! !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: 'copying' stamp: 'nice 10/5/2009 08:54'! postCopy super postCopy. contents := contents copy! ! !Bag methodsFor: 'enumerating'! do: aBlock "Refer to the comment in Collection|do:." contents associationsDo: [:assoc | assoc value timesRepeat: [aBlock value: assoc key]]! ! !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: '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: '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 methodsFor: 'testing'! includes: anObject "Refer to the comment in Collection|includes:." ^contents includesKey: anObject! ! !Bag methodsFor: 'testing'! occurrencesOf: anObject "Refer to the comment in Collection|occurrencesOf:." (self includes: anObject) ifTrue: [^contents at: anObject] ifFalse: [^0]! ! !Bag methodsFor: 'private' stamp: 'sma 5/12/2000 14:49'! setContents: aDictionary contents := aDictionary! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Bag class instanceVariableNames: ''! !Bag class methodsFor: 'instance creation' stamp: 'nk 3/17/2001 09:52'! contentsClass ^Dictionary! ! !Bag class methodsFor: 'instance creation' stamp: 'sma 5/12/2000 13:31'! new ^ self new: 4! ! !Bag class methodsFor: 'instance creation' stamp: 'nk 3/17/2001 09:52'! new: nElements ^ super new setContents: (self contentsClass new: nElements)! ! !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 "! ! CollectionRootTest subclass: #BagTest uses: TAddTest + TIncludesWithIdentityCheckTest + TCloneTest + TCopyTest + TSetArithmetic + TConvertTest + TAsStringCommaAndDelimiterTest + TRemoveForMultiplenessTest + TPrintTest + TConvertAsSortedTest + TConvertAsSetForMultiplinessTest + TConcatenationTest + TStructuralEqualityTest + TCreationWithTest - {#testOfSize} + TOccurrencesForMultiplinessTest instanceVariableNames: 'empty nonEmpty collectResult emptyButAllocatedWith20 elementExistsTwice element collectionWithElement collectionIn collectionNotIn collectionOfString elementNotIn collectionWithCharacters otherCollectionWithoutEqualElements collectionWithoutNilMoreThan5' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Unordered'! !BagTest methodsFor: 'as yet unclassified' 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: '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: '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: 'basic tests' stamp: 'TJ 3/8/2006 08:42'! testAsBag | aBag | aBag := Bag new. self assert: aBag asBag = aBag.! ! !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: '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: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: '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: '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 4/14/2009 12:07'! collectionInForIncluding ^ collectionIn ! ! !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/14/2009 12:08'! collectionNotIncluded ^ collectionNotIn ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 14:07'! collectionOfFloat ^ collectionOfString! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 14:22'! collectionWithCharacters ^ collectionWithCharacters .! ! !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: 'requirements' stamp: 'sd 1/28/2009 16:32'! collectionWithElement "Returns a collection that already includes what is returned by #element." ^ collectionWithElement! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 15:24'! collectionWithElementsToRemove ^ collectionIn! ! !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: 'requirements' stamp: 'delaunay 5/11/2009 11:27'! collectionWithoutEqualElements ^ otherCollectionWithoutEqualElements! ! !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: 'damienpollet 1/30/2009 17:32'! element ^ super element! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 14:19'! elementInForIncludesTest ^ self element ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 14:32'! elementInForOccurrences " return an element included in nonEmpty" ^self nonEmpty anyOne.! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/14/2009 13:40'! elementNotIn ^elementNotIn ! ! !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: '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: '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 5/11/2009 11:27'! integerCollectionWithoutEqualElements ^ otherCollectionWithoutEqualElements! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/30/2009 10:54'! nonEmpty1Element ^ self speciesClass new add: self element ;yourself.! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:28'! nonEmptyWithoutEqualElements " return a collection without equal elements " ^ otherCollectionWithoutEqualElements ! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:27'! otherCollection ^ otherCollectionWithoutEqualElements! ! !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: 'requirements' stamp: 'damienpollet 1/30/2009 17:40'! selectedNumber ^ 4! ! !BagTest methodsFor: 'requirements' stamp: 'stephane.ducasse 10/6/2008 17:39'! speciesClass ^ Bag! ! !BagTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 14:21'! withEqualElements " return a collection including equal elements (classic equality)" ^ nonEmpty .! ! !BagTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/6/2008 17:22'! collection ^ nonEmpty. ! ! !BagTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/5/2008 15:13'! empty ^ empty ! ! !BagTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/6/2008 17:26'! emptyButAllocatedWith20 ^ emptyButAllocatedWith20! ! !BagTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/5/2008 15:14'! nonEmpty ^ nonEmpty ! ! !BagTest methodsFor: 'setup' stamp: 'cyrille.delaunay 12/18/2009 13:12'! result ^ collectResult. ! ! !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: 'setup' stamp: 'delaunay 5/11/2009 11:27'! sizeCollection ^ otherCollectionWithoutEqualElements! ! !BagTest methodsFor: 'test - copy' stamp: 'delaunay 4/17/2009 15:26'! elementToAdd ^ 42! ! !BagTest methodsFor: 'test - creation'! testWith "self debug: #testWith" | aCol anElement | anElement := self collectionMoreThan5Elements anyOne. aCol := self collectionClass with: anElement. self assert: (aCol includes: anElement).! ! !BagTest methodsFor: 'test - creation'! 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: 'test - creation'! 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: 'test - creation'! 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: 'test - creation'! 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: 'test - creation'! 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: 'test - equality'! testEqualSign "self debug: #testEqualSign" self deny: (self empty = self nonEmpty).! ! !BagTest methodsFor: 'test - equality'! 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 - equality'! testEqualSignOfIdenticalCollectionObjects "self debug: #testEqualSignOfIdenticalCollectionObjects" self assert: (self empty = self empty). self assert: (self nonEmpty = self nonEmpty). ! ! !BagTest methodsFor: 'test - iterate' stamp: 'damienpollet 1/30/2009 17:36'! doWithoutNumber ^ 4! ! !BagTest methodsFor: 'test - iterate' stamp: 'marcus.denker 2/20/2009 16:29'! expectedElementByDetect ^ -2 ! ! !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: '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: 'test - set arithmetic' stamp: 'stephane.ducasse 12/20/2008 22:46'! collectionClass ^ Bag! ! !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: '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' 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' 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: '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: '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' 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 - adding'! 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 - adding'! 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 - adding'! 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 - adding'! 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 - adding'! 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: 'tests - adding'! 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 - adding'! 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 - adding'! 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: 'tests - as set tests'! 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 - as set tests'! testAsSetWithEqualsElements | result | result := self withEqualElements asSet. self withEqualElements do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. self assert: result class = Set! ! !BagTest methodsFor: 'tests - as sorted collection' stamp: 'hfm 4/2/2010 13:37'! 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: 'tests - as sorted collection'! 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: 'tests - as sorted collection'! 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 - as string comma delimiter sequenceable'! testAsCommaStringEmpty self assert: self empty asCommaString = ''. self assert: self empty asCommaStringAnd = ''. ! ! !BagTest methodsFor: 'tests - as string comma delimiter sequenceable'! 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: 'tests - as string comma delimiter sequenceable'! testAsCommaStringOne self nonEmpty1Element do: [:each | self assert: each asString =self nonEmpty1Element asCommaString. self assert: each asString=self nonEmpty1Element asCommaStringAnd.]. ! ! !BagTest methodsFor: 'tests - as string comma delimiter sequenceable'! testAsStringOnDelimiterEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim. self assert: emptyStream contents = ''. ! ! !BagTest methodsFor: 'tests - as string comma delimiter sequenceable'! testAsStringOnDelimiterLastEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim last:'and'. self assert: emptyStream contents = ''. ! ! !BagTest methodsFor: 'tests - as string comma delimiter sequenceable'! 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: 'tests - as string comma delimiter sequenceable'! 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 - as string comma delimiter sequenceable'! 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 - as string comma delimiter sequenceable'! 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 - concatenation'! 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 - concatenation'! 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 - concatenation'! testConcatenationWithEmpty | result | result := self firstCollection , self empty. self assert: result = self firstCollection! ! !BagTest methodsFor: 'tests - converting'! 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 - converting'! 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 - converting'! assertSameContents: aCollection whenConvertedTo: aClass | result | result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass. self assert: result size = aCollection size! ! !BagTest methodsFor: 'tests - converting'! testAsArray "self debug: #testAsArray3" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Array! ! !BagTest methodsFor: 'tests - converting'! testAsByteArray | res | self shouldnt: [self integerCollectionWithoutEqualElements ] raise: Error. 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 - converting'! testAsIdentitySet "test with a collection without equal elements :" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: IdentitySet. ! ! !BagTest methodsFor: 'tests - converting'! testAsOrderedCollection self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! ! !BagTest methodsFor: 'tests - copy'! 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 - copy' stamp: 'delaunay 4/17/2009 15:26'! 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 - copy' stamp: 'delaunay 4/17/2009 15:24'! 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 - copy'! 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 - copy'! 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 - copy'! 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: 'delaunay 4/17/2009 15:24'! 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: 'tests - copy' stamp: 'delaunay 3/30/2009 10:33'! testCopyNonEmptyWithoutAllNotIncluded ! ! !BagTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! 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 - copy'! 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 - copy'! 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: 'tests - copy - clone'! testCopyCreatesNewObject "self debug: #testCopyCreatesNewObject" | copy | copy := self nonEmpty copy. self deny: self nonEmpty == copy. ! ! !BagTest methodsFor: 'tests - copy - clone'! testCopyEmpty "self debug: #testCopyEmpty" | copy | copy := self empty copy. self assert: copy isEmpty.! ! !BagTest methodsFor: 'tests - copy - clone'! 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 - fixture' stamp: 'delaunay 4/17/2009 15:26'! test0CopyTest self shouldnt: self empty raise: Error. self assert: self empty size = 0. self shouldnt: self nonEmpty raise: Error. self assert: (self nonEmpty size = 0) not. self shouldnt: self collectionWithElementsToRemove raise: Error. self assert: (self collectionWithElementsToRemove size = 0) not. self shouldnt: self elementToAdd raise: Error! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureAsStringCommaAndDelimiterTest self shouldnt: [self nonEmpty] raise:Error . self deny: self nonEmpty isEmpty. self shouldnt: [self empty] raise:Error . self assert: self empty isEmpty. self shouldnt: [self nonEmpty1Element ] raise:Error . self assert: self nonEmpty1Element size=1.! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureCloneTest self shouldnt: [ self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self empty ] raise: Error. self assert: self empty isEmpty. ! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureConcatenationTest self shouldnt: [ self firstCollection ]raise: Error. self deny: self firstCollection isEmpty. self shouldnt: [ self firstCollection ]raise: Error. self deny: self firstCollection isEmpty. self shouldnt: [ self empty ]raise: Error. self assert: self empty isEmpty! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureConverAsSortedTest self shouldnt: [self collectionWithSortableElements ] raise: Error. self deny: self collectionWithSortableElements isEmpty .! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureCreationWithTest self shouldnt: [ self collectionMoreThan5Elements ] raise: Error. self assert: self collectionMoreThan5Elements size >= 5.! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureIncludeTest | anElementIn | self shouldnt: [ self nonEmpty ]raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self elementNotIn ]raise: Error. anElementIn := true. self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self shouldnt: [ self anotherElementNotIn ]raise: Error. anElementIn := true. self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self shouldnt: [ self empty ] raise: Error. self assert: self empty isEmpty. ! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureIncludeWithIdentityTest | anElement | self shouldnt: [ self collectionWithCopyNonIdentical ]raise: Error. anElement := self collectionWithCopyNonIdentical anyOne. self deny: anElement == anElement copy.! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureOccurrencesForMultiplinessTest | cpt anElement collection | self shouldnt: [ self collectionWithEqualElements ] raise: Error. self shouldnt: [ self collectionWithEqualElements ] raise: Error. self shouldnt: [ self elementTwiceInForOccurrences ] raise: Error. 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 - fixture'! test0FixtureOccurrencesTest | tmp | self shouldnt: [self empty ]raise: Error. self assert: self empty isEmpty. self shouldnt: [ self collectionWithoutEqualElements ] raise: Error. self deny: self collectionWithoutEqualElements isEmpty. tmp := OrderedCollection new. self collectionWithoutEqualElements do: [ :each | self deny: (tmp includes: each). tmp add: each. ]. self shouldnt: [ self elementNotInForOccurrences ] raise: Error. self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! ! !BagTest methodsFor: 'tests - fixture'! test0FixturePrintTest self shouldnt: [self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty.! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureRequirementsOfTAddTest self shouldnt: [ self collectionWithElement ] raise: Exception. self shouldnt: [ self otherCollection ] raise: Exception. self shouldnt: [ self element ] raise: Exception. self assert: (self collectionWithElement includes: self element). self deny: (self otherCollection includes: self element)! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureSetAritmeticTest self shouldnt: [ self collection ] raise: Error. self deny: self collection isEmpty. self shouldnt: [ self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self anotherElementOrAssociationNotIn ] raise: Error. self collection isDictionary ifTrue: [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ] ifFalse: [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ]. self shouldnt: [ self collectionClass ] raise: Error! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureTConvertAsSetForMultiplinessTest "a collection with equal elements:" | res | self shouldnt: [ self withEqualElements] raise: Error. res := true. self withEqualElements detect: [ :each | (self withEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = true. ! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureTConvertTest "a collection of number without equal elements:" | res | self shouldnt: [ self collectionWithoutEqualElements ]raise: Error. res := true. self collectionWithoutEqualElements detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false. ! ! !BagTest methodsFor: 'tests - fixture'! test0FixtureTRemoveTest | duplicate | self shouldnt: [ self empty ]raise: Error. self shouldnt: [ self nonEmptyWithoutEqualElements] raise:Error. self deny: self nonEmptyWithoutEqualElements isEmpty. duplicate := true. self nonEmptyWithoutEqualElements detect: [:each | (self nonEmptyWithoutEqualElements occurrencesOf: each) > 1] ifNone: [duplicate := false]. self assert: duplicate = false. self shouldnt: [ self elementNotIn ] raise: Error. self assert: self empty isEmpty. self deny: self nonEmptyWithoutEqualElements isEmpty. self deny: (self nonEmptyWithoutEqualElements includes: self elementNotIn)! ! !BagTest methodsFor: 'tests - fixture'! test0TStructuralEqualityTest self shouldnt: [self empty] raise: Error. self shouldnt: [self nonEmpty] raise: Error. self assert: self empty isEmpty. self deny: self nonEmpty isEmpty.! ! !BagTest methodsFor: 'tests - includes' stamp: 'stephane.ducasse 11/21/2008 14:58'! anotherElementNotIn ^ 42! ! !BagTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! elementNotInForOccurrences ^ 666! ! !BagTest methodsFor: 'tests - includes' stamp: 'Alexandre Bergel 5/22/2010 12:28'! 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 shouldnt: [ self collectionWithCopyNonIdentical ] raise: Error. collection := self collectionWithCopyNonIdentical. anElement := collection anyOne copy. "self assert: (collection includes: element)." self deny: (collection identityIncludes: anElement)! ! !BagTest methodsFor: 'tests - includes'! 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 - includes'! testIncludesAllNoneThere "self debug: #testIncludesAllOfNoneThere'" self deny: (self empty includesAll: self nonEmpty ). self deny: (self nonEmpty includesAll: { self elementNotIn. self anotherElementNotIn })! ! !BagTest methodsFor: 'tests - includes'! 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: 'tests - includes'! 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: '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 - includes'! testIncludesElementIsThere "self debug: #testIncludesElementIsThere" self assert: (self nonEmpty includes: self nonEmpty anyOne).! ! !BagTest methodsFor: 'tests - occurrencesOf'! testOccurrencesOfEmpty | result | result := self empty occurrencesOf: (self collectionWithoutEqualElements anyOne). self assert: result = 0! ! !BagTest methodsFor: 'tests - occurrencesOf'! testOccurrencesOfNotIn | result | result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences. self assert: result = 0! ! !BagTest methodsFor: 'tests - occurrencesOf for multipliness'! testOccurrencesOfForMultipliness | collection elem | collection := self collectionWithEqualElements . elem := self elementTwiceInForOccurrences . self assert: (collection occurrencesOf: elem ) = 2. ! ! !BagTest methodsFor: 'tests - printing'! 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 - printing'! 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: 'tests - printing'! 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 - printing'! 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 - printing'! 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: 'tests - printing'! 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'! testRemoveAllError "self debug: #testRemoveElementThatExists" | el aSubCollection | el := self elementNotIn. aSubCollection := self nonEmptyWithoutEqualElements copyWith: el. self should: [ | res | res := self nonEmptyWithoutEqualElements removeAll: aSubCollection ] raise: Error! ! !BagTest methodsFor: 'tests - remove'! testRemoveAllFoundIn "self debug: #testRemoveElementThatExists" | el aSubCollection | el := self nonEmptyWithoutEqualElements anyOne. aSubCollection := (self nonEmptyWithoutEqualElements copyWithout: el) copyWith: self elementNotIn. self shouldnt: [ | res | res := self nonEmptyWithoutEqualElements removeAllFoundIn: aSubCollection ] raise: Error. self assert: self nonEmptyWithoutEqualElements size = 1. self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! ! !BagTest methodsFor: 'tests - remove'! 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: 'tests - remove'! testRemoveElementFromEmpty "self debug: #testRemoveElementFromEmpty" self should: [ self empty remove: self nonEmptyWithoutEqualElements anyOne ] raise: Error! ! !BagTest methodsFor: 'tests - remove'! 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 - remove'! testRemoveElementThatExists "self debug: #testRemoveElementThatExists" | el res | el := self nonEmptyWithoutEqualElements anyOne. self shouldnt: [ res := self nonEmptyWithoutEqualElements remove: el ] raise: Error. self assert: res == el! ! !BagTest methodsFor: 'tests - remove'! testRemoveIfAbsent "self debug: #testRemoveElementThatExists" | el res | el := self elementNotIn. self shouldnt: [ res := self nonEmptyWithoutEqualElements remove: el ifAbsent: [ 33 ] ] raise: Error. self assert: res = 33! ! !BagTest methodsFor: 'tests - set arithmetic'! containsAll: union of: one andOf: another self assert: (one allSatisfy: [:each | union includes: each]). self assert: (another allSatisfy: [:each | union includes: each])! ! !BagTest methodsFor: 'tests - set arithmetic'! numberOfSimilarElementsInIntersection ^ self collection occurrencesOf: self anotherElementOrAssociationIn! ! !BagTest methodsFor: 'tests - set arithmetic'! 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 - set arithmetic'! 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: 'tests - set arithmetic'! 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 = 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 = separateCol! ! !BagTest methodsFor: 'tests - set arithmetic'! 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 - set arithmetic'! 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: 'tests - set arithmetic'! 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: 'tests - set arithmetic'! 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: 'tests - set arithmetic'! 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: 'tests - set arithmetic'! testUnionOfEmpties "self debug: #testUnionOfEmpties" self assert: (self empty union: self empty) isEmpty. ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BagTest class uses: TAddTest classTrait + TCloneTest classTrait + TCopyTest classTrait + TSetArithmetic classTrait + TConvertTest classTrait + TAsStringCommaAndDelimiterTest classTrait + TRemoveForMultiplenessTest classTrait + TPrintTest classTrait + TConvertAsSortedTest classTrait + TIncludesWithIdentityCheckTest classTrait + TConvertAsSetForMultiplinessTest classTrait + TConcatenationTest classTrait + TStructuralEqualityTest classTrait + TCreationWithTest classTrait + TOccurrencesForMultiplinessTest classTrait instanceVariableNames: ''! Object subclass: #BalloonBezierSimulation instanceVariableNames: 'start end via lastX lastY fwDx fwDy fwDDx fwDDy maxSteps' classVariableNames: 'HeightSubdivisions LineConversions MonotonSubdivisions OverflowSubdivisions' poolDictionaries: '' category: 'Balloon-Simulation'! !BalloonBezierSimulation commentStamp: '' prior: 0! 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 ^end! ! !BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'! end: aPoint end := aPoint! ! !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'! initialX ^start y <= end y ifTrue:[start x] ifFalse:[end x]! ! !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'! initialZ ^0 "Assume no depth given"! ! !BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/30/1998 01:57'! outTangent "Return the tangent at the end point" ^end - via! ! !BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'! start ^start! ! !BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'! start: aPoint start := aPoint! ! !BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'! via ^via! ! !BalloonBezierSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:45'! via: aPoint via := aPoint! ! !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: '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 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: 'ar 10/30/1998 02:45'! floatStepToNextScanLineAt: yValue in: edgeTableEntry "Float version of forward differencing" [yValue asFloat > lastY] whileTrue:[ (fwDx < -50.0 or:[fwDx > 50.0]) ifTrue:[self halt]. (fwDy < -50.0 or:[fwDy > 50.0]) ifTrue:[self halt]. (fwDDx < -50.0 or:[fwDDx > 50.0]) ifTrue:[self halt]. (fwDDy < -50.0 or:[fwDDy > 50.0]) ifTrue:[self halt]. lastX := lastX + fwDx. lastY := lastY + fwDy. fwDx := fwDx + fwDDx. fwDy := fwDy + fwDDy. ]. edgeTableEntry xValue: lastX asInteger. edgeTableEntry zValue: 0.! ! !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: '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 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: '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: '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/30/1998 22:13'! subdivideAt: parameter "Subdivide the receiver at the given parameter" | both | (parameter <= 0.0 or:[parameter >= 1.0]) ifTrue:[self halt]. 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: '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: 'computing' stamp: 'ar 10/30/1998 02:24'! 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 isMonoton ifFalse:[self halt]. other isMonoton ifFalse:[self halt]. ^other! ! !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: '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: '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: '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: 'private' 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: '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: '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: '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: '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: '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 10/30/1998 04:01'! stepToNextInt "Scaled integer version of forward differencing" self halt. (maxSteps >= 0) ifTrue:[ self validateIntegerRange. lastX := lastX + ((fwDx + 16r8000) // 16r10000). lastY := lastY + ((fwDy + 16r8000) // 16r10000). fwDx := fwDx + fwDDx. fwDy := fwDy + fwDDy. maxSteps := maxSteps - 1. ].! ! !BalloonBezierSimulation methodsFor: 'private' stamp: 'ar 10/30/1998 03:27'! validateIntegerRange fwDx class == SmallInteger ifFalse:[self halt]. fwDy class == SmallInteger ifFalse:[self halt]. fwDDx class == SmallInteger ifFalse:[self halt]. fwDDy class == SmallInteger ifFalse:[self halt]. ! ! !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 instanceVariableNames: ''! !BalloonBezierSimulation class methodsFor: 'initialization' stamp: 'MarcusDenker 9/30/2009 11:56'! initialize HeightSubdivisions := 0. LineConversions := 0. MonotonSubdivisions := 0. OverflowSubdivisions := 0.! ! Object variableWordSubclass: #BalloonBuffer instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Balloon-Engine'! !BalloonBuffer commentStamp: '' prior: 0! BalloonBuffer is a repository for primitive data used by the BalloonEngine.! !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 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 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 instanceVariableNames: ''! !BalloonBuffer class methodsFor: 'instance creation' stamp: 'ar 10/26/1998 21:11'! new ^self new: 256.! ! FormCanvas subclass: #BalloonCanvas instanceVariableNames: 'transform colorTransform engine aaLevel deferred' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Balloon'! !BalloonCanvas commentStamp: '' prior: 0! 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: 'accessing' stamp: 'ar 11/13/1998 01:02'! aaLevel ^aaLevel! ! !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 12/30/1998 10:54'! deferred ^deferred! ! !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: '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: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: '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: '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: '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'! 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: '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: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: '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: 'converting' stamp: 'ar 11/11/1998 22:57'! asBalloonCanvas ^self! ! !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 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: '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: '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: '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: '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: 'drawing' stamp: 'ul 11/15/2010 11:17'! line: pt1 to: pt2 width: w color: c "Draw a line from pt1 to: pt2" (aaLevel = 1 and: [self ifNoTransformWithIn:(pt1 rect: 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: '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-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.! ! !BalloonCanvas methodsFor: 'initialize' stamp: 'ar 11/24/1998 15:28'! flush "Force all pending primitives onscreen" engine ifNotNil:[engine flush].! ! !BalloonCanvas methodsFor: 'initialize' stamp: 'alain.plantec 5/28/2009 09:42'! initialize super initialize. aaLevel := 1. deferred := false.! ! !BalloonCanvas methodsFor: 'initialize' stamp: 'ar 11/11/1998 20:25'! resetEngine engine := nil.! ! !BalloonCanvas methodsFor: 'testing' stamp: 'ar 11/13/1998 13:19'! isBalloonCanvas ^true! ! !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: '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: '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: '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: 'transforming' stamp: 'ar 11/24/1998 14:45'! colorTransformBy: aColorTransform aColorTransform ifNil:[^self]. colorTransform ifNil:[colorTransform := aColorTransform] ifNotNil:[colorTransform := colorTransform composedWithLocal: aColorTransform]! ! !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: '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: '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: '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."! ! Object subclass: #BalloonEdgeData instanceVariableNames: 'index xValue yValue zValue lines source' classVariableNames: '' poolDictionaries: '' category: 'Balloon-Simulation'! !BalloonEdgeData commentStamp: '' prior: 0! 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: 'accessing' stamp: 'ar 10/27/1998 15:34'! index ^index! ! !BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:35'! index: anInteger index := anInteger! ! !BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:13'! lines ^lines! ! !BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:13'! lines: anInteger ^lines := anInteger! ! !BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:34'! source ^source! ! !BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 21:39'! source: anObject source := anObject! ! !BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:34'! xValue ^xValue! ! !BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:35'! xValue: anInteger xValue := anInteger! ! !BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:34'! yValue ^yValue! ! !BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:35'! yValue: anInteger yValue := anInteger! ! !BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 19:56'! zValue ^zValue! ! !BalloonEdgeData methodsFor: 'accessing' stamp: 'ar 10/27/1998 19:56'! zValue: anInteger zValue := anInteger! ! !BalloonEdgeData methodsFor: 'computing' stamp: 'ar 10/27/1998 15:53'! stepToFirstScanLine source stepToFirstScanLineAt: yValue in: self! ! !BalloonEdgeData methodsFor: 'computing' stamp: 'ar 10/27/1998 15:53'! stepToNextScanLine source stepToNextScanLineAt: yValue in: self! ! Object subclass: #BalloonEngine instanceVariableNames: 'workBuffer span bitBlt forms clipRect destOffset externals aaLevel edgeTransform colorTransform deferred postFlushNeeded' classVariableNames: 'BezierStats BufferCache CacheProtect Counts Debug Times' poolDictionaries: 'BalloonEngineConstants' category: 'Balloon-Engine'! !BalloonEngine commentStamp: '' prior: 0! 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: 'accessing' stamp: 'ar 11/11/1998 23:04'! aaLevel ^aaLevel ifNil:[1]! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/11/1998 23:04'! aaLevel: anInteger aaLevel := (anInteger min: 4) max: 1.! ! !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 methodsFor: 'accessing' stamp: 'ar 10/13/1998 03:04'! bitBlt ^bitBlt! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 5/28/2000 15:02'! bitBlt: aBitBlt bitBlt := aBitBlt. bitBlt isNil ifTrue:[^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/1/1998 02:57'! clipRect ^clipRect! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 10/13/1998 02:44'! clipRect: aRect clipRect := aRect truncated! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/24/1998 15:04'! colorTransform ^colorTransform! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/24/1998 15:04'! colorTransform: aColorTransform colorTransform := aColorTransform! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 12/30/1998 11:24'! deferred ^deferred! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 12/30/1998 11:24'! deferred: aBoolean deferred := aBoolean.! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/1/1998 02:56'! destOffset ^destOffset! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/12/1998 00:22'! destOffset: aPoint destOffset := aPoint asIntegerPoint. bitBlt destX: aPoint x; destY: aPoint y.! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/25/1998 22:34'! edgeTransform ^edgeTransform! ! !BalloonEngine methodsFor: 'accessing' stamp: 'ar 11/25/1998 22:34'! edgeTransform: aTransform edgeTransform := aTransform.! ! !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: '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 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: '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: '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: '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: '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: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: '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: '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: '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: '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: '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: '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: 'drawing' stamp: 'ar 11/26/1998 19:45'! registerFill: fill1 and: fill2 ^self registerFills: (Array with: fill1 with: fill2)! ! !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: 'initialize' stamp: 'ar 11/25/1998 22:29'! flush "Force all pending primitives onscreen" workBuffer ifNil:[^self]. self copyBits. self release.! ! !BalloonEngine methodsFor: 'initialize' 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: '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: '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: 'initialize' stamp: 'ar 11/11/1998 22:52'! release self class recycleBuffer: workBuffer. workBuffer := nil.! ! !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: '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:48'! primClipRectInto: rect ^self primitiveFailed! ! !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'! primFlushNeeded: aBoolean ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! primGetAALevel "Set the AA level" ^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:49'! primGetClipRect: rect ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! primGetCounts: statsArray ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:47'! primGetDepth ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! primGetFailureReason ^0! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! primGetOffset ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! primGetTimes: statsArray ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! primSetAALevel: level "Set the AA level" ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! primSetClipRect: rect ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:47'! primSetColorTransform: transform ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:47'! primSetDepth: depth ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:47'! primSetEdgeTransform: transform ^self primitiveFailed! ! !BalloonEngine methodsFor: 'primitives-access' stamp: 'ar 2/2/2001 15:49'! primSetOffset: point ^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: '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'! 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'! 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: '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-adding' stamp: 'ar 2/2/2001 15:47'! primAddExternalFill: index (self canProceedAfter: self primGetFailureReason) ifTrue:[ ^self primAddExternalFill: index ]. ^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'! 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-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: '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: '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-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: '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:48'! primDisplaySpanBuffer "Display the current scan line if necessary" ^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: '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: '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: '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-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: '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: '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-incremental' stamp: 'ar 2/2/2001 15:49'! primRenderScanline: edge with: fill "Start/Proceed rendering the current scan line" ^self primitiveFailed! ! !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: 'primitives-misc' stamp: 'ar 2/2/2001 15:49'! primInitializeBuffer: buffer ^self primitiveFailed! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BalloonEngine class instanceVariableNames: ''! !BalloonEngine class methodsFor: 'accessing' stamp: 'ar 10/25/1998 17:37'! debug: aBoolean "BalloonEngine debug: true" "BalloonEngine debug: false" Debug := aBoolean! ! !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: '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 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 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/30/1998 23:57'! resetBezierStats BezierStats := WordArray new: 4.! ! !BalloonEngine class methodsFor: 'accessing' stamp: 'ar 10/28/1998 23:38'! resetStats Times := WordArray new: 10. Counts := WordArray new: 10.! ! !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: '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: 'private' stamp: 'ar 5/28/2000 22:17'! primitiveSetBitBltPlugin: pluginName ^nil! ! !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]. ].! ! SharedPool subclass: #BalloonEngineConstants instanceVariableNames: '' classVariableNames: 'BEAaLevelIndex BEBalloonEngineSize BEBitBltIndex BEClipRectIndex BEColorTransformIndex BEDeferredIndex BEDestOffsetIndex BEEdgeTransformIndex BEExternalsIndex BEFormsIndex BEPostFlushNeededIndex BESpanIndex BEWorkBufferIndex ETBalloonEdgeDataSize ETIndexIndex ETLinesIndex ETSourceIndex ETXValueIndex ETYValueIndex ETZValueIndex FTBalloonFillDataSize FTDestFormIndex FTIndexIndex FTMaxXIndex FTMinXIndex FTSourceIndex FTYValueIndex GBBaseSize GBBitmapDepth GBBitmapHeight GBBitmapRaster GBBitmapSize GBBitmapWidth GBColormapOffset GBColormapSize GBEndX GBEndY GBFinalX GBMBaseSize GBTileFlag GBUpdateDDX GBUpdateDDY GBUpdateDX GBUpdateDY GBUpdateData GBUpdateX GBUpdateY GBViaX GBViaY GBWideEntry GBWideExit GBWideExtent GBWideFill GBWideSize GBWideUpdateData GBWideWidth GEBaseEdgeSize GEBaseFillSize GEEdgeClipFlag GEEdgeFillsInvalid GEFillIndexLeft GEFillIndexRight GENumLines GEObjectIndex GEObjectLength GEObjectType GEObjectUnused GEPrimitiveBezier GEPrimitiveClippedBitmapFill GEPrimitiveEdge GEPrimitiveEdgeMask GEPrimitiveFill GEPrimitiveFillMask GEPrimitiveLine GEPrimitiveLinearGradientFill GEPrimitiveRadialGradientFill GEPrimitiveRepeatedBitmapFill GEPrimitiveTypeMask GEPrimitiveUnknown GEPrimitiveWide GEPrimitiveWideBezier GEPrimitiveWideEdge GEPrimitiveWideLine GEPrimitiveWideMask GEStateAddingFromGET GEStateBlitBuffer GEStateCompleted GEStateScanningAET GEStateUnlocked GEStateUpdateEdges GEStateWaitingChange GEStateWaitingForEdge GEStateWaitingForFill GEXValue GEYValue GEZValue GErrorAETEntry GErrorBadState GErrorFillEntry GErrorGETEntry GErrorNeedFlush GErrorNoMoreSpace GFDirectionX GFDirectionY GFNormalX GFNormalY GFOriginX GFOriginY GFRampLength GFRampOffset GGBaseSize GLBaseSize GLEndX GLEndY GLError GLErrorAdjDown GLErrorAdjUp GLWideEntry GLWideExit GLWideExtent GLWideFill GLWideSize GLWideWidth GLXDirection GLXIncrement GLYDirection GWAAColorMask GWAAColorShift GWAAHalfPixel GWAALevel GWAAScanMask GWAAShift GWAETStart GWAETUsed GWBezierHeightSubdivisions GWBezierLineConversions GWBezierMonotonSubdivisions GWBezierOverflowSubdivisions GWBufferTop GWClearSpanBuffer GWClipMaxX GWClipMaxY GWClipMinX GWClipMinY GWColorTransform GWCountAddAETEntry GWCountChangeAETEntry GWCountDisplaySpan GWCountFinishTest GWCountInitializing GWCountMergeFill GWCountNextAETEntry GWCountNextFillEntry GWCountNextGETEntry GWCurrentY GWCurrentZ GWDestOffsetX GWDestOffsetY GWEdgeTransform GWFillMaxX GWFillMaxY GWFillMinX GWFillMinY GWFillOffsetX GWFillOffsetY GWGETStart GWGETUsed GWHasClipShapes GWHasColorTransform GWHasEdgeTransform GWHeaderSize GWLastExportedEdge GWLastExportedFill GWLastExportedLeftX GWLastExportedRightX GWMagicIndex GWMagicNumber GWMinimalSize GWNeedsFlush GWObjStart GWObjUsed GWPoint1 GWPoint2 GWPoint3 GWPoint4 GWPointListFirst GWSize GWSpanEnd GWSpanEndAA GWSpanSize GWSpanStart GWState GWStopReason GWTimeAddAETEntry GWTimeChangeAETEntry GWTimeDisplaySpan GWTimeFinishTest GWTimeInitializing GWTimeMergeFill GWTimeNextAETEntry GWTimeNextFillEntry GWTimeNextGETEntry' poolDictionaries: '' category: 'Balloon-Engine'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BalloonEngineConstants class instanceVariableNames: ''! !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: '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 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" ! ! !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: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 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: '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.! ! Object subclass: #BalloonFillData instanceVariableNames: 'index minX maxX yValue source destForm' classVariableNames: '' poolDictionaries: '' category: 'Balloon-Simulation'! !BalloonFillData commentStamp: '' prior: 0! 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 ^destForm! ! !BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:56'! destForm: aForm destForm := aForm! ! !BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'! index ^index! ! !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: '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'! minX: anInteger minX := anInteger! ! !BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:56'! source ^source! ! !BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:56'! source: anObject source := anObject! ! !BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/28/1998 16:35'! width ^maxX - minX! ! !BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'! yValue ^yValue! ! !BalloonFillData methodsFor: 'accessing' stamp: 'ar 10/27/1998 15:55'! yValue: anInteger yValue := anInteger! ! !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! ! Object subclass: #BalloonLineSimulation instanceVariableNames: 'start end xIncrement xDirection error errorAdjUp errorAdjDown' classVariableNames: '' poolDictionaries: '' category: 'Balloon-Simulation'! !BalloonLineSimulation commentStamp: '' prior: 0! 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 ^end! ! !BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/30/1998 03:02'! end: aPoint end := aPoint! ! !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/27/1998 20:31'! initialY ^start y <= end y ifTrue:[start y] ifFalse:[end y]! ! !BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/27/1998 20:31'! initialZ ^0 "Assume no depth given"! ! !BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/30/1998 03:02'! start ^start! ! !BalloonLineSimulation methodsFor: 'accessing' stamp: 'ar 10/30/1998 03:02'! start: aPoint start := aPoint! ! !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: '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: '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/29/1998 23:42'! subdivide ^nil! ! !BalloonLineSimulation methodsFor: 'printing' stamp: 'ar 10/27/1998 23:20'! printOn: aStream aStream nextPutAll: self class name; nextPut:$(; print: start; nextPutAll:' - '; print: end; nextPut:$)! ! PolygonMorph subclass: #BalloonMorph instanceVariableNames: 'target offsetFromTarget balloonOwner balloonColor' classVariableNames: 'BalloonColor BalloonFont' poolDictionaries: '' category: 'Morphic-Widgets'! !BalloonMorph commentStamp: '' prior: 0! 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: 'accessing' stamp: 'BenjaminVanRyseghem 1/20/2011 12:25'! balloonColor ^ balloonColor! ! !BalloonMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/20/2011 12:35'! balloonColor: aColor balloonColor := aColor. self color: aColor! ! !BalloonMorph methodsFor: 'accessing' stamp: 'ar 10/3/2000 17:19'! balloonOwner ^balloonOwner! ! !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: 'initialization' stamp: 'AlainPlantec 10/20/2010 20:12'! defaultBorderWidth "answer the default border width for the receiver" ^ 1! ! !BalloonMorph methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/20/2011 12:21'! defaultColor "answer the default color/fill style for the receiver" ^ self balloonColor! ! !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: '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: '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: 'stepping and presenter' stamp: 'sma 12/23/1999 14:05'! step "Move with target." target ifNotNil: [self position: target position + offsetFromTarget]. ! ! !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: 'private' stamp: 'sma 12/23/1999 14:06'! setTarget: aMorph (target := aMorph) ifNotNil: [offsetFromTarget := self position - target position]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BalloonMorph class instanceVariableNames: ''! !BalloonMorph class methodsFor: '*FreeType-override' stamp: 'AlainPlantec 12/18/2009 16:45'! chooseBalloonFont "BalloonMorph chooseBalloonFont" StandardFonts chooseStandardFont: #balloonFont ! ! !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: 'instance creation' stamp: 'sma 12/23/1999 20:05'! string: str for: morph ^ self string: str for: morph corner: #bottomLeft! ! !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: 'utility' stamp: 'BenjaminVanRyseghem 1/20/2011 11:29'! balloonColor ^ BalloonColor ifNil: [BalloonColor := self defaultBalloonColor]! ! !BalloonMorph class methodsFor: 'utility' stamp: 'AlainPlantec 11/30/2009 09:27'! balloonFont ^ BalloonFont ifNil: [BalloonFont := StandardFonts defaultFont]! ! !BalloonMorph class methodsFor: 'utility' stamp: 'AlainPlantec 11/30/2009 09:40'! balloonFont: aFont BalloonFont := aFont! ! !BalloonMorph class methodsFor: 'utility' stamp: 'sma 11/11/2000 14:59'! setBalloonColorTo: aColor aColor ifNotNil: [BalloonColor := aColor]! ! !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: '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: '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: '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! ! Object subclass: #BalloonSolidFillSimulation instanceVariableNames: 'color' classVariableNames: '' poolDictionaries: '' category: 'Balloon-Simulation'! !BalloonSolidFillSimulation commentStamp: '' prior: 0! 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: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].! ! !BalloonSolidFillSimulation methodsFor: 'computing' stamp: 'ar 10/27/1998 23:08'! computeInitialStateFrom: source with: aColorTransform color := source asColor.! ! Object subclass: #BalloonState instanceVariableNames: 'transform colorTransform aaLevel' classVariableNames: '' poolDictionaries: '' category: 'Balloon-Engine'! !BalloonState commentStamp: '' prior: 0! 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:47'! aaLevel ^aaLevel! ! !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 ^colorTransform! ! !BalloonState methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:42'! colorTransform: aColorTransform colorTransform := aColorTransform! ! !BalloonState methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:41'! transform ^transform! ! !BalloonState methodsFor: 'accessing' stamp: 'ar 12/30/1998 10:42'! transform: aMatrixTransform transform := aMatrixTransform! ! MimeConverter subclass: #Base64MimeConverter instanceVariableNames: 'data multiLine' classVariableNames: 'FromCharTable ToCharTable' poolDictionaries: '' category: 'Network-MIME'! !Base64MimeConverter commentStamp: '' prior: 0! 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: 'accessing' stamp: 'dik 9/22/2010 18:07'! multiLine ^ multiLine! ! !Base64MimeConverter methodsFor: 'accessing' stamp: 'dik 9/22/2010 18:07'! multiLine: anObject multiLine := anObject! ! !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: '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: '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 methodsFor: 'initialize-release' stamp: 'dik 9/22/2010 18:09'! initialize super initialize. multiLine := true.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Base64MimeConverter class instanceVariableNames: ''! !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! ! !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: '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: '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: '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: '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: '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! ! TestCase subclass: #Base64MimeConverterTest instanceVariableNames: 'message' classVariableNames: '' poolDictionaries: '' category: 'NetworkTests-Kernel'! !Base64MimeConverterTest commentStamp: '' prior: 0! 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: 'setup' stamp: 'StephaneDucasse 1/16/2010 12:53'! setUp message := 'Hi There!!' readStream.! ! !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: '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:54'! testOnByteArray "self run: #testOnByteArray" self assert: ('Hi There!!' base64Encoded = 'Hi There!!' asByteArray base64Encoded)! ! TestCase subclass: #BaseStreamTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Files'! !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: 'CamilloBruni 7/23/2012 19:53'! 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) ensureDeleted ].! ! !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 class instanceVariableNames: ''! !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! ! TestCase subclass: #BasicBehaviorClassMetaclassTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Classes'! !BasicBehaviorClassMetaclassTest commentStamp: '' prior: 0! This class contains some tests regarding the classes Behavior ClassDescription Class Metaclass --- ! !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: 'md 7/24/2009 15:29'! testClassDescriptionAllSubInstances "self run: #testClassDescriptionAllSubInstances" | cdNo clsNo metaclsNo | Smalltalk garbageCollect. cdNo := ClassDescription allSubInstances size. clsNo := Class allSubInstances size . metaclsNo := Metaclass allSubInstances size. self assert: cdNo = (clsNo + metaclsNo). ! ! !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: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: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:18'! testMetaclassPointOfCircularity "self run: #testMetaclassPointOfCircularity" self assert: Metaclass class instanceCount = 1. self assert: Metaclass class someInstance == 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: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: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.! ! Categorizer subclass: #BasicClassOrganizer instanceVariableNames: 'subject classComment commentStamp' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Classes'! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'Sd 1/28/2011 14:35'! classComment classComment ifNil: [^ '']. ^ classComment string ifNil: ['']! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'marcus.denker 8/17/2008 20:56'! classComment: aString "Store the comment, aString, associated with the object that refers to the receiver." (aString isKindOf: RemoteString) ifTrue: [classComment := aString] ifFalse: [aString isEmptyOrNil ifTrue: [classComment := nil] ifFalse: [ self error: 'use aClass classComment:'. classComment := RemoteString newString: aString onFileNumber: 2]] "Later add priorSource and date and initials?"! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'marcus.denker 8/17/2008 20:56'! classComment: aString stamp: aStamp "Store the comment, aString, associated with the object that refers to the receiver." self commentStamp: aStamp. (aString isKindOf: RemoteString) ifTrue: [classComment := aString] ifFalse: [aString isEmptyOrNil ifTrue: [classComment := nil] ifFalse: [self error: 'use aClass classComment:'. classComment := RemoteString newString: aString onFileNumber: 2]] "Later add priorSource and date and initials?"! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'! commentRemoteStr ^ classComment! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'! commentStamp "Answer the comment stamp for the class" ^ commentStamp! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'! commentStamp: aStamp commentStamp := aStamp! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:03'! dateCommentLastSubmitted "Answer a Date object indicating when my class comment was last submitted. If there is no date stamp, or one of the old-time guys, return nil" "RecentMessageSet organization dateCommentLastSubmitted" | aStamp tokens | (aStamp := self commentStamp) isEmptyOrNil ifTrue: [^ nil]. tokens := aStamp findBetweenSubStrs: ' '. "space is expected delimiter, but cr is sometimes seen, though of mysterious provenance" ^ tokens size > 1 ifTrue: [[tokens second asDate] ifError: [nil]] ifFalse: [nil]! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'marcus.denker 7/29/2009 15:26'! hasComment "Answer whether the class classified by the receiver has a comment." ^classComment notNil! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:04'! hasSubject ^ self subject notNil! ! !BasicClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 16:04'! subject ^ subject.! ! !BasicClassOrganizer methodsFor: 'fileIn/Out' stamp: 'DamienCassou 5/14/2011 17:19'! 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 | classComment ifNotNil: [aFileStream cr. fileComment := RemoteString newString: classComment string onFileNumber: fileIndex toFile: aFileStream. moveSource ifTrue: [classComment := fileComment]]! ! !BasicClassOrganizer methodsFor: 'fileIn/Out' stamp: 'NS 4/7/2004 16:04'! putCommentOnFile: aFileStream numbered: sourceIndex moveSource: moveSource forClass: aClass "Store the comment about the class onto file, aFileStream." | header | classComment ifNotNil: [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]! ! !BasicClassOrganizer methodsFor: 'private' stamp: 'NS 4/7/2004 16:04'! setSubject: aClassDescription subject := aClassDescription! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BasicClassOrganizer class instanceVariableNames: ''! !BasicClassOrganizer class methodsFor: 'constants' stamp: 'NS 4/19/2004 15:52'! ambiguous ^ #ambiguous! ! !BasicClassOrganizer class methodsFor: 'instance creation' stamp: 'NS 4/7/2004 16:04'! class: aClassDescription ^ self new setSubject: aClassDescription! ! !BasicClassOrganizer class methodsFor: 'instance creation' stamp: 'NS 4/7/2004 16:04'! class: aClassDescription defaultList: aSortedCollection | inst | inst := self defaultList: aSortedCollection. inst setSubject: aClassDescription. ^ inst! ! CommandLineHandler subclass: #BasicCodeLoader instanceVariableNames: 'sourceFiles' classVariableNames: '' poolDictionaries: '' category: 'System-CommandLine'! !BasicCodeLoader commentStamp: '' prior: 0! CodeLoader provides a way to load smalltalk source file from local. Example: CodeLoader new loadSourceFiles: (Array with: (#file:, FileDirectory default fullName, '/useless.st')); installSourceFiles ! !BasicCodeLoader methodsFor: 'activation' stamp: 'CamilloBruni 10/13/2012 15:50'! activate self activateHelp. self loadSourceFiles: (self commandLine allFilesWithExtension: 'st'). self installSourceFiles. (self commandLine hasOption: 'quit') ifTrue: [ self exitSuccess ].! ! !BasicCodeLoader methodsFor: 'installing' stamp: 'CamilloBruni 6/14/2012 23:15'! handleErrorsDuring: aBlock reference: aReference aBlock on: Error, ParserNotification do: [ :e| self handleError: e reference: aReference ]. ! ! !BasicCodeLoader methodsFor: 'installing' stamp: 'CamilloBruni 6/14/2012 23:29'! installSourceFile: aReference "Install the the source file given by aFileReference" | codeImporter | " parse the code given in the source file" aReference readStreamDo: [ :stream | self handleErrorsDuring: [ codeImporter := CodeImporter fileStream: stream. codeImporter parseDeclarations ] reference: aReference]. "evaluate the declarations in a second step to allow for properly closing the source file stream" self handleErrorsDuring: [ codeImporter evaluate ] reference: aReference.! ! !BasicCodeLoader methodsFor: 'installing' stamp: 'EstebanLorenzano 4/4/2012 10:31'! installSourceFiles "Install the previously loaded source files" sourceFiles ifNil: [ ^self ]. [ sourceFiles do: [ :reference | self installSourceFile: reference ] ] ensure: [ sourceFiles := nil ]. ! ! !BasicCodeLoader methodsFor: 'loading' stamp: 'CamilloBruni 5/1/2012 20:51'! loadSourceFiles: anArray "Load all the source files in the given array." sourceFiles := anArray collect: [ :each | (FileSystem disk resolve: each) asFileReference ]. ! ! !BasicCodeLoader methodsFor: 'private' stamp: 'CamilloBruni 4/28/2012 21:48'! handleError: error "for syntax errors we can used the default action" "otherwise resignal it" (error isKindOf: SyntaxErrorNotification) ifTrue: [ error defaultAction ] ifFalse: [ error pass ]! ! !BasicCodeLoader methodsFor: 'private' stamp: 'CamilloBruni 11/2/2012 15:25'! handleError: error reference: aReference "Print a header before failing on an errro / syntax notification from the the script loaded by the given request" "spit out a warning if in headless mode, otherwise a debugger will popup" Smalltalk isHeadless ifTrue: [ self inform: 'Errors in script loaded from ', aReference fullName ]. (error isKindOf: SyntaxErrorNotification) "for syntax errors we can used the default action" ifTrue: [ error defaultAction ] "otherwise resignal it" ifFalse: [ error pass ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BasicCodeLoader class instanceVariableNames: ''! !BasicCodeLoader class methodsFor: 'accessing' stamp: 'CamilloBruni 5/2/2012 11:35'! commandName ^ 'st'! ! !BasicCodeLoader class methodsFor: 'accessing' stamp: 'CamilloBruni 2/6/2013 18:18'! description ^ 'Loads and executes .st source files'! ! !BasicCodeLoader class methodsFor: 'handler selection' stamp: 'CamilloBruni 5/2/2012 11:31'! isResponsibleFor: aCommandLine "This handler is reponsible only for .st files" (aCommandLine hasFileWithExtension: '.st') ifTrue: [ ^ true ]. ^ super isResponsibleFor: aCommandLine! ! TestCase subclass: #BasicCodeLoaderTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-System-CommandLine'! !BasicCodeLoaderTest methodsFor: 'tests' stamp: 'CamilloBruni 5/4/2012 12:06'! testCommandLineHandlerCondition | commandLine reference | commandLine := CommandLineArguments withArguments: {'/non/existing/file.st'}. "the reponsibility is transfered tot the BasicCodeLoader as soon as there is a .st file in the arguments" self assert: (BasicCodeLoader isResponsibleFor: commandLine). [ reference := FileSystem disk workingDirectory / 'codeLoad1.st'. reference writeStreamDo: [ :stream | stream nextPutAll: '42' ]. commandLine := CommandLineArguments withArguments: {reference fullName}. self assert: (BasicCodeLoader isResponsibleFor: commandLine) ] ensure: [ reference delete ] ! ! !BasicCodeLoaderTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/12/2012 14:28'! testInstallSourceFilesFail | codeLoader reference | codeLoader := BasicCodeLoader new. codeLoader loadSourceFiles: {'codeLoad1.st'}. "Ensure file is not there" (FileSystem disk workingDirectory / 'codeLoad1.st') asFileReference delete. "Trying non existing file" self should: [ codeLoader installSourceFiles ] raise: Error.! ! !BasicCodeLoaderTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/12/2012 14:25'! testLoadSourceFiles | codeLoader | codeLoader := BasicCodeLoader new. codeLoader loadSourceFiles: { '/not/existing/codeLoad1.st'. '/not/existing/codeLoad2.st'}. self assert: (codeLoader instVarNamed: 'sourceFiles') notNil. self assert: (codeLoader instVarNamed: 'sourceFiles') size = 2. self assert: ((codeLoader instVarNamed: 'sourceFiles') allSatisfy: [ :each | each isKindOf: FileReference ]).! ! Inspector subclass: #BasicInspector instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tools-Inspector'! !BasicInspector methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 2/28/2012 11:44'! inspect: anObject "Initialize the receiver so that it is inspecting anObject." self initialize. object := anObject. selectionIndex := 1. contents := ''! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BasicInspector class instanceVariableNames: ''! !BasicInspector class methodsFor: 'tools registry' stamp: 'IgorStasenko 2/19/2011 02:59'! registerToolsOn: registry "Add ourselves to registry. See [Smalltalk tools]" registry register: self as: #basicInspector ! ! TestCase subclass: #BecomeTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-VM'! !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'. ! ! !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 17:36'! 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 hb | a := 'ab' copy. b := 'cd' copy. hb := b identityHash. a becomeForward: b copyHash: false. self assert: a identityHash = hb; assert: b identityHash = hb. ! ! !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: '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: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. ! ! Object subclass: #Beeper instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Support'! !Beeper commentStamp: 'gk 2/26/2004 22:44' prior: 0! 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: 'PavelKrivanek 2/8/2013 10:18'! 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." Smalltalk globals at: #SoundService ifPresent: [:soundService | soundService default new beep]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Beeper class instanceVariableNames: 'default'! !Beeper class methodsFor: 'beeping'! 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: 'beeping' stamp: 'PavelKrivanek 2/8/2013 10:21'! 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." Smalltalk globals at: #SoundService ifPresent: [:soundService | soundService soundEnabled ifTrue: [self primitiveBeep]] ifAbsent: [self primitiveBeep].! ! !Beeper class methodsFor: 'customize'! clearDefault "Clear the default playable. Will be lazily initialized in Beeper class >>default." default := nil! ! !Beeper class methodsFor: 'customize'! default "When the default is not defined it is initialized using #newDefault." default isNil ifTrue: [default := self newDefault ]. ^ default! ! !Beeper class methodsFor: 'customize'! 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: 'customize'! setDefault: aPlayableEntity "Set the playable entity used when making a beep. The playable entity should implement the message #play." default := aPlayableEntity! ! !Beeper class methodsFor: 'private'! 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! ! Object subclass: #Behavior uses: TPureBehavior instanceVariableNames: 'superclass methodDict format layout' classVariableNames: 'ObsoleteSubclasses' poolDictionaries: '' category: 'Kernel-Classes'! !Behavior commentStamp: 'al 12/8/2005 20:44' prior: 0! 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: '*Compiler-Kernel'! binding ^ nil -> self! ! !Behavior methodsFor: '*Compiler-Kernel'! 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: '*Compiler-Kernel'! compile: code classified: category notifying: requestor trailer: bytes ifFail: failBlock "Compile code without logging the source in the changes file" | methodNode | methodNode := self compilerClass new compile: code in: self classified: category notifying: requestor ifFail: failBlock. ^ CompiledMethodWithNode generateMethodFromNode: methodNode trailer: bytes.! ! !Behavior methodsFor: '*Compiler-Kernel'! 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." | methodAndNode | methodAndNode := self compile: code "a Text" classified: nil notifying: requestor trailer: self defaultMethodTrailer ifFail: [^nil]. methodAndNode method putSource: code fromParseNode: methodAndNode node inFile: 2 withPreamble: [:f | f cr; nextPut: $!!; nextChunkPut: 'Behavior method'; cr]. self addSelector: methodAndNode selector withMethod: methodAndNode method notifying: requestor. ^ methodAndNode selector! ! !Behavior methodsFor: '*Compiler-Kernel'! compileAll ^ self compileAllFrom: self! ! !Behavior methodsFor: '*Compiler-Kernel'! compilerClass "Answer a compiler class appropriate for source methods of this class." ^Smalltalk compilerClass! ! !Behavior methodsFor: '*Compiler-Kernel'! decompile: selector "Find the compiled code associated with the argument, selector, as a message selector in the receiver's method dictionary and decompile it. Answer the resulting source code as a string. Create an error notification if the selector is not in the receiver's method dictionary." ^self decompilerClass new decompile: selector in: self! ! !Behavior methodsFor: '*Compiler-Kernel'! decompilerClass "Answer a decompiler class appropriate for compiled methods of this class." ^ self compilerClass decompilerClass! ! !Behavior methodsFor: '*Compiler-Kernel'! defaultMethodTrailer ^ CompiledMethodTrailer empty! ! !Behavior methodsFor: '*Compiler-Kernel'! evaluatorClass "Answer an evaluator class appropriate for evaluating expressions in the context of this class." ^self compilerClass! ! !Behavior methodsFor: '*Compiler-Kernel'! parserClass "Answer a parser class to use for parsing method headers." ^self compilerClass parserClass! ! !Behavior methodsFor: '*Compiler-Kernel'! prettyPrinterClass ^ self compilerClass! ! !Behavior methodsFor: '*Compiler-Kernel'! recompile: selector "Compile the method associated with selector in the receiver's method dictionary." ^self recompile: selector from: self! ! !Behavior methodsFor: '*Compiler-Kernel'! recompile: selector from: oldClass "Compile the method associated with selector in the receiver's method dictionary." "ar 7/10/1999: Use oldClass compiledMethodAt: not self compiledMethodAt:" | method trailer methodNode | method := oldClass compiledMethodAt: selector. trailer := method trailer. methodNode := self compilerClass new compile: (oldClass sourceCodeAt: selector) in: self notifying: nil ifFail: [^ self]. "Assume OK after proceed from SyntaxError" selector == methodNode selector ifFalse: [self error: 'selector changed!!']. self basicAddSelector: selector withMethod: (methodNode generate: trailer). ! ! !Behavior methodsFor: '*Compiler-Kernel'! 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: '*Compiler-Kernel'! 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: '*Fuel' stamp: 'MartinDias 6/13/2011 01:04'! fuelIgnoredInstanceVariableNames "Indicates which variables have to be ignored during serialization." ^#()! ! !Behavior methodsFor: '*Fuel' stamp: 'MartinDias 2/20/2013 21:49'! fuelNew "Answer an instance of mine in which serialized references will be injected." ^ self basicNew! ! !Behavior methodsFor: '*Fuel' stamp: 'MartinDias 2/20/2013 21:50'! fuelNew: sizeRequested "Answer an instance of mine in which serialized references will be injected." ^ self basicNew: sizeRequested! ! !Behavior methodsFor: '*Manifest-Core' stamp: 'SimonAllier 5/29/2012 10:36'! isManifest ^ self name beginsWith: 'Manifest'! ! !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: '*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: '*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: '*Nautilus' stamp: 'BenjaminVanRyseghem 7/13/2012 14:12'! realClass ^ self! ! !Behavior methodsFor: '*NautilusCommon'! addCategory: newName before: aCategory ^ self organization addCategory: newName before: aCategory! ! !Behavior methodsFor: '*Ring-Core-Kernel'! methodNamed: aSelector ^ self methodDict at: aSelector! ! !Behavior methodsFor: '*Ring-Core-Kernel'! methods ^ self methodDict values! ! !Behavior methodsFor: '*Ring-Core-Kernel'! methodsInProtocol: aString ^ (self organization listAtCategoryNamed: aString) collect: [:each | (self methodDict at: each) ]! ! !Behavior methodsFor: '*Ring-Core-Kernel'! protocols ^ self organization categories copy! ! !Behavior methodsFor: '*Rpackage-Core'! originalName ^self isObsolete ifTrue: [ (self name copyFrom: 'AnObsolete' size + 1 to: self name size ) asSymbol ] ifFalse: [ self name asSymbol ].! ! !Behavior methodsFor: '*System-Support' stamp: 'StephaneDucasse 4/30/2011 21:36'! 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: '*System-Support' stamp: 'StephaneDucasse 4/30/2011 21:35'! allCallsOn: aSymbol "Answer a SortedCollection of all the methods that call on aSymbol." ^ self systemNavigation allCallsOn: aSymbol from: self . ! ! !Behavior methodsFor: '*System-Support' stamp: 'StephaneDucasse 4/30/2011 21:35'! 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: '*System-Support' stamp: 'MarcusDenker 7/12/2012 17:58'! 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: '*System-Support' stamp: 'AlexandreBergel 9/12/2011 11:17'! 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: '*Tools-Inspector' stamp: 'CamilloBruni 8/1/2012 16:10'! 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: '*Tools-Inspector' stamp: 'CamilloBruni 8/1/2012 16:10'! 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: '*ast-core' stamp: 'lr 10/20/2009 19:21'! parseTreeFor: aSymbol ^ RBParser parseMethod: (self sourceCodeAt: aSymbol) onError: [ :msg :pos | ^ nil ]! ! !Behavior methodsFor: 'accessing' stamp: 'ajh 9/19/2001 17:30'! classDepth superclass ifNil: [^ 1]. ^ superclass classDepth + 1! ! !Behavior methodsFor: 'accessing' stamp: 'StephaneDucasse 3/16/2010 16:26'! environment "Return the environment in which the receiver is visible" ^Smalltalk globals! ! !Behavior methodsFor: 'accessing'! format "Answer an Integer that encodes the kinds and numbers of variables of instances of the receiver." ^format! ! !Behavior methodsFor: 'accessing' stamp: 'EstebanLorenzano 7/20/2012 18:53'! isComposedBy: aTrait "Answers if this object includes trait aTrait into its composition" aTrait isTrait ifFalse: [ self error: aTrait name, ' is not a Trait']. ^self hasTraitComposition ifTrue: [ self traitComposition includesTrait: aTrait ] ifFalse: [ false ]! ! !Behavior methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 2/8/2012 18:20'! 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 == nil ifTrue: [^ MethodDictionary new ]. ^ methodDict! ! !Behavior methodsFor: 'accessing' stamp: 'rca 7/26/2000 16:53'! name "Answer a String that is the name of the receiver." ^'a subclass of ', superclass name! ! !Behavior methodsFor: 'accessing' stamp: 'Alexandre Bergel 4/27/2010 14:05'! numberOfInstanceVariables ^ self instVarNames size ! ! !Behavior methodsFor: 'accessing' stamp: 'MarcusDenker 2/2/2013 16:19'! subclassDefinerClass "Answer an evaluator class appropriate for evaluating definitions of new subclasses of this class." ^self compilerClass! ! !Behavior methodsFor: 'accessing' stamp: 'ar 7/13/1999 22:00'! 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 class hierarchy' stamp: 'StephaneDucasse 3/1/2011 21:24'! 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: 'sd 3/28/2003 15:06'! 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 class hierarchy'! 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 | ^ superclass == nil ifTrue: [ OrderedCollection new] ifFalse: [temp := superclass allSuperclasses. temp addFirst: superclass. temp]! ! !Behavior methodsFor: 'accessing class hierarchy' stamp: 'MarcusDenker 5/12/2012 13:10'! 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]. ^ superclass == aClass ifTrue: [ OrderedCollection with: aClass] ifFalse: [temp := superclass allSuperclassesIncluding: aClass. temp addFirst: superclass. temp]! ! !Behavior methodsFor: 'accessing class hierarchy' stamp: 'sd 3/14/2004 18:09'! subclasses "slow implementation since Behavior does not keep trace of subclasses" ^ self class allInstances select: [:each | each superclass = self ]! ! !Behavior methodsFor: 'accessing class hierarchy'! superclass "Answer the receiver's superclass, a Class." ^superclass! ! !Behavior methodsFor: 'accessing class hierarchy' stamp: 'ar 7/10/1999 12:10'! 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 == nil or: [aClass isBehavior]) ifTrue: [superclass := aClass. Object flushCache] ifFalse: [self error: 'superclass must be a class-describing object']! ! !Behavior methodsFor: 'accessing class hierarchy'! 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: 'accessing class hierarchy'! 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: 'accessing instances and variables'! allClassVarNames "Answer a Set of the names of the receiver's and the receiver's ancestor's class variables." ^superclass allClassVarNames! ! !Behavior methodsFor: 'accessing instances and variables'! 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 | superclass == nil ifTrue: [vars := self instVarNames copy] "Guarantee a copy is answered." ifFalse: [vars := superclass allInstVarNames , self instVarNames]. ^vars! ! !Behavior methodsFor: 'accessing instances and variables' stamp: 'MarcusDenker 10/17/2009 16:49'! 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 instances and variables' stamp: 'StephaneDucasse 12/13/2011 17:03'! allSharedPools "Answer an ordered collection of the shared pools that the receiver and the receiver's ancestors share." ^superclass allSharedPools! ! !Behavior methodsFor: 'accessing instances and variables' stamp: 'di 6/20/97 10:51'! 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: 'accessing instances and variables' stamp: 'ajh 10/17/2002 11:03'! allowsSubInstVars "Classes that allow instances to change classes among its subclasses will want to override this and return false, so inst vars are not accidentally added to its subclasses." ^ true! ! !Behavior methodsFor: 'accessing instances and variables' stamp: 'nice 10/20/2009 22:03'! classVarNames "Answer a collection of the receiver's class variable names." ^#()! ! !Behavior methodsFor: 'accessing instances and variables' stamp: 'StephaneDucasse 11/9/2010 14:47'! includesSharedPoolNamed: aSharedPoolString "Answer whether the receiver uses the shared pool named aSharedPoolString" ^ (self sharedPools anySatisfy: [:each | each name = aSharedPoolString])! ! !Behavior methodsFor: 'accessing instances and variables'! 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 := superclass == nil ifTrue: [0] ifFalse: [superclass instSize]. mySize = superSize ifTrue: [^#()]. ^(superSize + 1 to: mySize) collect: [:i | 'inst' , i printString]! ! !Behavior methodsFor: 'accessing instances and variables'! 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: 'accessing instances and variables' stamp: 'StephaneDucasse 12/13/2011 16:32'! sharedPools "Answer an ordered collection of the shared pools that the receiver shares" ^ OrderedCollection new! ! !Behavior methodsFor: 'accessing instances and variables'! 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: 'accessing instances and variables'! 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: 'accessing method dictionary'! >> 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: 'accessing method dictionary' stamp: 'MarcusDenker 10/24/2010 16:34'! 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: 'kph 8/27/2008 22:31'! allSelectors "Answer all selectors understood by instances of the receiver" ^ self allSelectorsBelow: nil! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'sd 1/28/2009 14:29'! allSelectorsAbove ^ self allSelectorsAboveUntil: ProtoObject ! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'sd 1/28/2009 14:28'! allSelectorsAboveUntil: aRootClass | coll | coll := IdentitySet new. (self allSuperclassesIncluding: aRootClass) do: [:aClass | aClass selectorsDo: [ :sel | coll add: sel ]]. ^ coll ! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'dc 9/28/2008 15:54'! allSelectorsBelow: topClass | coll | coll := IdentitySet new. self withAllSuperclassesDo: [:aClass | aClass = topClass ifTrue: [^ coll ] ifFalse: [aClass selectorsDo: [ :sel | coll add: sel ]]]. ^ coll ! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'StephaneDucasse 2/23/2012 12:40'! 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 asOrderedCollection ! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'al 6/12/2006 10:48'! basicLocalSelectors "Direct accessor for the instance variable localSelectors. Because of hardcoded ivar indexes of Behavior and Class in the VM, Class and Metaclass declare the needed ivar and override this method as an accessor. By returning nil instead of declaring this method as a subclass responsibility, Behavior can be instantiated for creating anonymous classes." ^nil! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'al 3/25/2006 13:17'! basicLocalSelectors: aSetOrNil self subclassResponsibility ! ! !Behavior methodsFor: 'accessing method dictionary'! 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: 'accessing method dictionary' stamp: 'nice 1/5/2010 15:59'! 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 method dictionary' stamp: 'mga 3/20/2005 11:11'! 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: 'ul 11/15/2010 10:09'! 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'! 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'! 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 value]! ! !Behavior methodsFor: 'accessing method dictionary'! compress "Compact the method dictionary of the receiver." self methodDict rehash! ! !Behavior methodsFor: 'accessing method dictionary'! deregisterLocalSelector: aSymbol self basicLocalSelectors notNil ifTrue: [ self basicLocalSelectors remove: aSymbol ifAbsent: []]! ! !Behavior methodsFor: 'accessing method dictionary'! 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: 'accessing method dictionary' stamp: 'damiencassou 5/30/2008 10:56'! 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" "Behavior firstPrecodeCommentFor: #firstPrecodeCommentFor:" | parser source tree | (#(#Comment #Definition #Hierarchy ) includes: selector) ifTrue: [ "Not really a selector" ^ nil ]. source := self sourceCodeAt: selector asSymbol ifAbsent: [ ^ nil ]. parser := self parserClass new. tree := parser parse: source readStream class: self noPattern: false context: nil notifying: nil ifFail: [ ^ nil ]. ^ (tree comment ifNil: [ ^ nil ]) first! ! !Behavior methodsFor: 'accessing method dictionary'! "popeye" formalHeaderPartsFor: "olive oil" aSelector "RELAX!! The warning you may have just seen about possibly having a bad source file does not apply here, because this method *intends* to have its source code start with a comment. This method returns a collection giving the parts in the formal declaration for aSelector. This parse is in support of schemes in which adjutant properties of a method can be declared via special comments secreted in the formal header The result will have 3 elements for a simple, argumentless selector. 5 elements for a single-argument selector 9 elements for a two-argument selector 13 elements for a three-argument, selector etc... The syntactic elements are: 1 comment preceding initial selector fragment 2 first selector fragment 3 comment following first selector fragment (nil if selector has no arguments) ---------------------- (ends here for, e.g., #copy) 4 first formal argument 5 comment following first formal argument (nil if selector has only one argument) ---------------------- (ends here for, e.g., #copyFrom:) 6 second keyword 7 comment following second keyword 8 second formal argument 9 comment following second formal argument (nil if selector has only two arguments) ---------------------- (ends here for, e.g., #copyFrom:to:) Any nil element signifies an absent comment. NOTE: The comment following the final formal argument is *not* successfully retrieved by this method in its current form, though it can be obtained, if needed, by other means (e.g. calling #firstPrecodeCommentFor:). Thus, the *final* element in the structure returned by this method is always going to be nil." ^ Scanner new scanMessageParts: (self methodHeaderFor: aSelector) " Behavior class formalHeaderPartsFor: #formalHeaderPartsFor: " ! ! !Behavior methodsFor: 'accessing method dictionary'! formalParametersAt: aSelector "Return the names of the arguments used in this method." | source | source := self sourceCodeAt: aSelector ifAbsent: [^ #()]. "for now" ^(self parserClass new) parseParameterNames: source! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'di 1/2/1999 15:45'! 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: 'accessing method dictionary' stamp: 'dvf 9/27/2005 17:08'! methodDict: aDictionary methodDict := aDictionary! ! !Behavior methodsFor: 'accessing method dictionary'! methodDictionary "Convenience" ^self methodDict! ! !Behavior methodsFor: 'accessing method dictionary'! methodDictionary: aDictionary self methodDict: aDictionary! ! !Behavior methodsFor: 'accessing method dictionary'! methodHeaderFor: selector "Answer the string corresponding to the method header for the given selector" | sourceString parser | sourceString := self ultimateSourceCodeAt: selector ifAbsent: [self standardMethodHeaderFor: selector]. (parser := self parserClass new) parseSelector: sourceString. ^ sourceString asString copyFrom: 1 to: (parser endOfLastToken min: sourceString size) "Behavior methodHeaderFor: #methodHeaderFor: " ! ! !Behavior methodsFor: 'accessing method dictionary'! methodsDo: aBlock "Evaluate aBlock for all the compiled methods in my method dictionary." ^ self methodDict valuesDo: aBlock! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'mga 3/21/2005 12:04'! 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: 'accessing method dictionary' stamp: 'StephaneDucasse 3/6/2010 09:26'! 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: [superclass == nil or: [(aSuper := superclass whichClassIncludesSelector: selector) == nil]]) ifFalse: [aSuper precodeCommentOrInheritedCommentFor: selector]] ifFalse: [aComment]! ! !Behavior methodsFor: 'accessing method dictionary'! registerLocalSelector: aSymbol self basicLocalSelectors notNil ifTrue: [ self basicLocalSelectors add: aSymbol]! ! !Behavior methodsFor: 'accessing method dictionary'! selectors "Answer a Set of all the message selectors specified in the receiver's method dictionary." ^ self methodDict keys! ! !Behavior methodsFor: 'accessing method dictionary'! selectorsAndMethodsDo: selectorAndMethodBlock "Evaluate selectorAndMethodBlock with two arguments for each selector/method pair in my method dictionary." ^ self methodDict keysAndValuesDo: selectorAndMethodBlock! ! !Behavior methodsFor: 'accessing method dictionary'! selectorsDo: selectorBlock "Evaluate selectorBlock for all the message selectors in my method dictionary." ^ self methodDict keysDo: selectorBlock! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'md 1/2/2006 18:56'! selectorsWithArgs: numberOfArgs "Return all selectors defined in this class that take this number of arguments" ^ self selectors select: [:selector | selector numArgs = numberOfArgs]! ! !Behavior methodsFor: 'accessing method dictionary'! sourceCodeAt: selector ^ (self methodDict at: selector) sourceCode.! ! !Behavior methodsFor: 'accessing method dictionary'! sourceCodeAt: selector ifAbsent: aBlock ^ (self methodDict at: selector ifAbsent: [^ aBlock value]) sourceCode.! ! !Behavior methodsFor: 'accessing method dictionary'! standardMethodHeaderFor: aSelector | args | args := (1 to: aSelector numArgs) collect:[:i| 'arg', i printString]. args size = 0 ifTrue:[^aSelector asString]. args size = 1 ifTrue:[^aSelector,' arg1']. ^String streamContents:[:s| (aSelector findTokens:':') with: args do:[:tok :arg| s nextPutAll: tok; nextPutAll:': '; nextPutAll: arg; nextPutAll:' '. ]. ]. ! ! !Behavior methodsFor: 'accessing method dictionary'! 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: [superclass == nil or: [(aSuper := superclass whichClassIncludesSelector: selector) == nil]]) ifFalse: ["There is a super implementor" superComment := aSuper supermostPrecodeCommentFor: selector]. ^ superComment ifNil: [self firstPrecodeCommentFor: selector "ActorState supermostPrecodeCommentFor: #printOn:"]! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'al 12/6/2004 11:36'! ultimateSourceCodeAt: selector ifAbsent: aBlock "Return the source code at selector, deferring to superclass if necessary" ^ self sourceCodeAt: selector ifAbsent: [superclass ifNil: [aBlock value] ifNotNil: [superclass ultimateSourceCodeAt: selector ifAbsent: aBlock]]! ! !Behavior methodsFor: 'accessing method dictionary' stamp: 'sd 11/19/2004 15:18'! zapAllMethods "Remove all methods in this class which is assumed to be obsolete" methodDict := self emptyMethodDictionary. self class isMeta ifTrue: [self class zapAllMethods]! ! !Behavior methodsFor: 'adding/removing methods'! addSelector: selector withMethod: compiledMethod ^ self addSelector: selector withMethod: compiledMethod notifying: nil! ! !Behavior methodsFor: 'adding/removing methods'! addSelector: selector withMethod: compiledMethod notifying: requestor ^ self addSelectorSilently: selector withMethod: compiledMethod! ! !Behavior methodsFor: 'adding/removing methods'! addSelectorSilently: selector withMethod: compiledMethod self methodDictAddSelectorSilently: selector withMethod: compiledMethod. self registerLocalSelector: selector! ! !Behavior methodsFor: 'adding/removing methods' stamp: 'HenrikSperreJohansen 2/16/2011 13:34'! 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: 'adding/removing methods' stamp: 'VeronicaUquillas 6/11/2010 12:46'! 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: 'adding/removing methods' stamp: 'nice 12/3/2009 23:57'! 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 isNil ifTrue: [self selectors asSet] ifFalse: [self basicLocalSelectors].! ! !Behavior methodsFor: 'adding/removing methods'! methodDictAddSelectorSilently: selector withMethod: compiledMethod self basicAddSelector: selector withMethod: compiledMethod! ! !Behavior methodsFor: 'adding/removing methods'! 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 TPureBehavior 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) ! ! !Behavior methodsFor: 'adding/removing methods' stamp: 'EstebanLorenzano 8/3/2012 13:59'! removeSelectorSilently: selector "Remove selector without sending system change notifications" ^ SystemAnnouncer uniqueInstance suspendAllWhile: [self removeSelector: selector].! ! !Behavior methodsFor: 'cleanup' stamp: 'StephaneDucasse 3/9/2010 16:08'! 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: 'cleanup' stamp: 'StephaneDucasse 3/9/2010 16:11'! 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: 'compiling' stamp: 'stephaneducasse 8/16/2010 23:21'! 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" | binding | oldClass selectorsDo: [:sel | self recompile: sel from: oldClass]. "Ensure that we share a common binding after recompilation. This is so that ClassBuilder reshapes avoid creating new bindings for every method when recompiling a large class hierarchy." binding := self binding. self methodsDo: [:m| m methodClassAssociation == binding ifFalse: [m methodClassAssociation: binding ]]. ! ! !Behavior methodsFor: 'compiling' stamp: 'eem 5/13/2008 09:50'! 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: 'compiling' stamp: 'eem 6/19/2008 09:08'! 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'! copyOfMethodDictionary "Return a copy of the receiver's method dictionary" ^ self methodDict copy! ! !Behavior methodsFor: 'copying'! deepCopy "Classes should only be shallowCopied or made anew." ^ self shallowCopy! ! !Behavior methodsFor: 'copying'! postCopy super postCopy. self methodDictionary: self copyOfMethodDictionary! ! !Behavior methodsFor: 'enumerating' stamp: 'nice 11/14/2009 19:22'! 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: 'enumerating' stamp: 'di 6/20/97 10:50'! 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: 'enumerating'! allSubclassesDo: aBlock "Evaluate the argument, aBlock, for each of the receiver's subclasses." self subclassesDo: [:cl | aBlock value: cl. cl allSubclassesDo: aBlock]! ! !Behavior methodsFor: 'enumerating'! allSuperclassesDo: aBlock "Evaluate the argument, aBlock, for each of the receiver's superclasses." superclass == nil ifFalse: [aBlock value: superclass. superclass allSuperclassesDo: aBlock]! ! !Behavior methodsFor: 'enumerating' stamp: 'marcus.denker 9/29/2008 15:17'! 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: 'enumerating'! 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: 'enumerating'! 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: 'enumerating' stamp: 'AdrianKuhn 12/22/2009 08:07'! subclassesDo: aBlock self subclasses do: aBlock! ! !Behavior methodsFor: 'enumerating'! withAllSubclassesDo: aBlock "Evaluate the argument, aBlock, for the receiver and each of its subclasses." aBlock value: self. self allSubclassesDo: aBlock! ! !Behavior methodsFor: 'enumerating' stamp: 'StephaneDucasse 2/13/2010 15:34'! withAllSuperAndSubclassesDo: aBlock self allSuperclassesDo: aBlock. aBlock value: self. self allSubclassesDo: aBlock! ! !Behavior methodsFor: 'enumerating' stamp: 'ar 7/11/1999 04:21'! withAllSuperclassesDo: aBlock "Evaluate the argument, aBlock, for each of the receiver's superclasses." aBlock value: self. superclass == nil ifFalse: [superclass withAllSuperclassesDo: aBlock]! ! !Behavior methodsFor: 'initialization'! emptyMethodDictionary ^ MethodDictionary new! ! !Behavior methodsFor: 'initialization'! 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: 'initialize-release' stamp: 'alain.plantec 5/28/2009 09:43'! initialize "moved here from the class side's #new" super initialize. superclass := Object. "no longer sending any messages, some of them crash the VM" methodDict := self emptyMethodDictionary. format := Object format! ! !Behavior methodsFor: 'initialize-release' stamp: 'sd 3/28/2003 15:07'! 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: 'initialize-release' stamp: 'al 12/12/2003 20:59'! 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." superclass := aClass. format := fmt. methodDict := mDict. self traitComposition: nil! ! !Behavior methodsFor: 'instance creation' stamp: 'StephaneDucasse 12/18/2009 12:00'! 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: 'instance creation' stamp: 'StephaneDucasse 12/18/2009 12:00'! 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: 'instance creation' stamp: 'MarianoMartinezPeck 8/24/2012 15:57'! 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: 'instance creation' stamp: 'sd 5/20/2004 11:20'! 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: 'memory usage' stamp: 'AlexandreBergel 8/31/2011 15:58'! 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: 'obsolete subclasses' stamp: 'apb 7/12/2004 23:13'! addObsoleteSubclass: aClass "Weakly remember that aClass was a subclass of the receiver and is now obsolete" | obs | obs := ObsoleteSubclasses at: self ifAbsent:[WeakArray new]. (obs includes: aClass) ifTrue:[^self]. obs := obs copyWithout: nil. obs := obs copyWith: aClass. ObsoleteSubclasses at: self put: obs. ! ! !Behavior methodsFor: 'obsolete subclasses' stamp: 'StephaneDucasse 8/12/2011 14:56'! 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: 'obsolete subclasses' stamp: 'apb 7/12/2004 23:20'! obsoleteSubclasses "Return all the weakly remembered obsolete subclasses of the receiver" | obs | obs := ObsoleteSubclasses at: self ifAbsent: [^ #()]. ^ obs copyWithout: nil! ! !Behavior methodsFor: 'obsolete subclasses' stamp: 'apb 7/12/2004 23:21'! removeAllObsoleteSubclasses "Remove all the obsolete subclasses of the receiver" ObsoleteSubclasses removeKey: self ifAbsent: []. ! ! !Behavior methodsFor: 'obsolete subclasses' stamp: 'apb 7/12/2004 23:22'! removeObsoleteSubclass: aClass "Remove aClass from the weakly remembered obsolete subclasses" | obs | obs := ObsoleteSubclasses at: self ifAbsent:[^ self]. (obs includes: aClass) ifFalse:[^self]. obs := obs copyWithout: aClass. obs := obs copyWithout: nil. ObsoleteSubclasses at: self put: obs! ! !Behavior methodsFor: 'printing'! 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 isNil ifTrue: "###" [(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: 'printing'! 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: 'printing' stamp: 'PeterHugossonMiller 9/3/2009 00:11'! 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: 'printing'! printOn: aStream "Refer to the comment in Object|printOn:." aStream nextPutAll: 'a descendent of '. superclass printOn: aStream! ! !Behavior methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! printWithClosureAnalysisOn: aStream "Refer to the comment in Object|printOn:." aStream nextPutAll: 'a descendent of '. superclass printWithClosureAnalysisOn: aStream! ! !Behavior methodsFor: 'printing'! 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: 'queries' stamp: 'MarcusDenker 4/29/2012 10:33'! 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: 'queries' stamp: 'StephaneDucasse 5/15/2011 17:21'! copiedMethodsFromSuperclass "Returns the methods that the receiver copied with its ancestors" | methods | methods := OrderedCollection new. self methodDict valuesDo: [ :method| methods addAll: (self copiedFromSuperclass: method)]. ^ methods! ! !Behavior methodsFor: 'queries' stamp: 'MarcusDenker 4/29/2012 10:33'! 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: 'queries' stamp: 'StephaneDucasse 5/15/2011 17:20'! copiesMethodsFromSuperclass "Checks whether the receiver copied some method from its superclass" self methodDict valuesDo: [ :method| (self copiesFromSuperclass: method) ifTrue: [ ^ true ]]. ^ false! ! !Behavior methodsFor: 'queries' stamp: 'StephaneDucasse 12/5/2009 11:51'! whichClassDefinesClassVar: aString Symbol hasInterned: aString ifTrue: [ :aSymbol | ^self whichSuperclassSatisfies: [:aClass | aClass classVarNames anySatisfy: [:each | each = aSymbol]]]. ^#()! ! !Behavior methodsFor: 'queries' stamp: 'dvf 9/17/2001 00:18'! whichClassDefinesInstVar: aString ^self whichSuperclassSatisfies: [:aClass | aClass instVarNames includes: aString]! ! !Behavior methodsFor: 'queries' stamp: 'bh 3/6/2000 00:51'! whichSelectorsAssign: instVarName "Answer a Set of selectors whose methods store into the argument, instVarName, as a named instance variable." ^self whichSelectorsStoreInto: instVarName! ! !Behavior methodsFor: 'queries' stamp: 'bh 3/6/2000 00:52'! whichSelectorsRead: instVarName "Answer a Set of selectors whose methods access the argument, instVarName, as a named instance variable." ^self whichSelectorsAccess: instVarName! ! !Behavior methodsFor: 'queries' stamp: 'dvf 9/17/2001 00:18'! whichSuperclassSatisfies: aBlock (aBlock value: self) ifTrue: [^self]. ^superclass isNil ifTrue: [nil] ifFalse: [superclass whichSuperclassSatisfies: aBlock]! ! !Behavior methodsFor: 'system startup' stamp: 'MarianoMartinezPeck 8/24/2012 15:57'! shutDown "This message is sent on system shutdown to registered classes" ! ! !Behavior methodsFor: 'system startup' stamp: 'ar 11/16/1999 20:15'! shutDown: quitting "This message is sent on system shutdown to registered classes" ^self shutDown.! ! !Behavior methodsFor: 'system startup' stamp: 'MarianoMartinezPeck 8/24/2012 15:57'! startUp "This message is sent to registered classes when the system is coming up." ! ! !Behavior methodsFor: 'system startup' stamp: 'ar 11/16/1999 20:15'! startUp: resuming "This message is sent to registered classes when the system is coming up." ^self startUp! ! !Behavior methodsFor: 'testing'! canZapMethodDictionary "Return true if it is safe to zap the method dictionary on #obsolete" ^true! ! !Behavior methodsFor: 'testing' stamp: 'StephaneDucasse 12/16/2012 23:12'! 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: 'testing'! 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. " ^ ((format bitShift: -10) bitAnd: 16rC0) + ((format bitShift: -1) bitAnd: 16r3F) - 1! ! !Behavior methodsFor: 'testing'! instSpec ^ (format bitShift: -7) bitAnd: 16rF! ! !Behavior methodsFor: 'testing' stamp: 'MarcusDenker 2/21/2013 17:01'! isAnonymous ^true! ! !Behavior methodsFor: 'testing' stamp: 'ar 7/9/1999 18:18'! isBehavior "Return true if the receiver is a behavior" ^true! ! !Behavior methodsFor: 'testing'! isBits "Answer whether the receiver contains just bits (not pointers)." ^ self instSpec >= 6! ! !Behavior methodsFor: 'testing'! isBytes "Answer whether the receiver has 8-bit instance variables." ^ self instSpec >= 8! ! !Behavior methodsFor: 'testing' stamp: 'MarianoMartinezPeck 1/9/2012 21:14'! isCompact ^self indexIfCompact ~= 0! ! !Behavior methodsFor: 'testing'! isFixed "Answer whether the receiver does not have a variable (indexable) part." ^self isVariable not! ! !Behavior methodsFor: 'testing' stamp: 'dvf 9/27/2005 14:57'! isMeta ^ false! ! !Behavior methodsFor: 'testing' stamp: 'ar 7/14/1999 02:38'! isObsolete "Return true if the receiver is obsolete." ^self instanceCount = 0! ! !Behavior methodsFor: 'testing'! isPointers "Answer whether the receiver contains just pointers (not bits)." ^self isBits not! ! !Behavior methodsFor: 'testing'! isVariable "Answer whether the receiver has indexable variables." ^ self instSpec >= 2! ! !Behavior methodsFor: 'testing' stamp: 'ar 3/21/98 02:36'! isWeak "Answer whether the receiver has contains weak references." ^ self instSpec = 4! ! !Behavior methodsFor: 'testing' stamp: 'MarcusDenker 11/4/2010 13:37'! isWords "Answer true if the receiver is made of 32-bit instance variables." ^self isBytes not! ! !Behavior methodsFor: 'testing' stamp: 'StephaneDucasse 3/20/2010 23:17'! shouldNotBeRedefined "Return true if the receiver should not be redefined. The assumption is that compact classes, classes in Smalltalk specialObjects and Behaviors should not be redefined" ^(Smalltalk compactClassesArray includes: self) or:[(Smalltalk specialObjectsArray includes: self) or: [self isKindOf: self]]! ! !Behavior methodsFor: 'testing' stamp: 'MarcusDenker 3/3/2012 16:28'! 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 trailer methodNode | method := self compiledMethodAt: selector. trailer := method trailer. methodNode := self compilerClass new compile: (self sourceCodeAt: selector) in: self notifying: nil ifFail: [^ false]. "Assume OK after proceed from SyntaxError" selector == methodNode selector ifFalse: [self error: 'selector changed!!!!']. ^ (methodNode generate: trailer) = method! ! !Behavior methodsFor: 'testing class hierarchy' stamp: 'ar 3/12/98 12:36'! includesBehavior: aClass ^self == aClass or:[self inheritsFrom: aClass]! ! !Behavior methodsFor: 'testing class hierarchy'! inheritsFrom: aClass "Answer whether the argument, aClass, is on the receiver's superclass chain." | aSuperclass | aSuperclass := superclass. [aSuperclass == nil] whileFalse: [aSuperclass == aClass ifTrue: [^true]. aSuperclass := aSuperclass superclass]. ^false! ! !Behavior methodsFor: 'testing class hierarchy'! 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: 'testing method dictionary' stamp: 'al 2/29/2004 14:18'! bindingOf: varName "Answer the binding of some variable resolved in the scope of the receiver" ^superclass bindingOf: varName! ! !Behavior methodsFor: 'testing method dictionary' stamp: 'sd 5/7/2006 09:58'! 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: 'testing method dictionary'! canUnderstand: selector "Answer whether the receiver can respond to the message whose selector is the argument. The selector can be in the method dictionary of the receiver's class or any of its superclasses." (self includesSelector: selector) ifTrue: [^true]. superclass == nil ifTrue: [^false]. ^superclass canUnderstand: selector! ! !Behavior methodsFor: 'testing method dictionary' stamp: 'ar 5/18/2003 18:13'! classBindingOf: varName "Answer the binding of some variable resolved in the scope of the receiver's class" ^self bindingOf: varName! ! !Behavior methodsFor: 'testing method dictionary'! hasMethods "Answer whether the receiver has any methods in its method dictionary." ^ self methodDict notEmpty! ! !Behavior methodsFor: 'testing method dictionary'! includesLocalSelector: aSymbol ^self basicLocalSelectors isNil ifTrue: [self includesSelector: aSymbol] ifFalse: [self localSelectors includes: aSymbol]! ! !Behavior methodsFor: 'testing method dictionary'! 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: 'testing method dictionary' stamp: 'StephaneDucasse 4/27/2010 11:48'! 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 method dictionary'! isDisabledSelector: selector ^ self classAndMethodFor: selector do: [:c :m | m isDisabled] ifAbsent: [false]! ! !Behavior methodsFor: 'testing method dictionary'! 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: 'testing method dictionary'! 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: 'testing method dictionary' stamp: 'G.C 10/22/2008 09:59'! 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 | ((method refersToLiteral: literal) or: [ specialFlag and: [ method scanFor: specialByte ] ]) ifTrue: [ selectors add: sel ] ]. ^ selectors! ! !Behavior methodsFor: 'testing method dictionary'! 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]. superclass == nil ifTrue: [^ nil]. ^ superclass whichClassIncludesSelector: aSymbol! ! !Behavior methodsFor: 'testing method dictionary' stamp: 'MarcusDenker 2/21/2010 12:50'! 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 methodDict at: sel) readsField: instVarIndex) or: [(self methodDict at: sel) writesField: instVarIndex]] "Point whichSelectorsAccess: 'x'."! ! !Behavior methodsFor: 'testing method dictionary'! 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: 'testing method dictionary'! 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: 'testing method dictionary' stamp: 'MarcusDenker 2/21/2010 12:51'! 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 methodDict at: sel) writesField: instVarIndex] "Point whichSelectorsStoreInto: 'x'."! ! !Behavior methodsFor: 'traits'! addExclusionOf: aSymbol to: aTrait self setTraitComposition: ( self traitComposition copyWithExclusionOf: aSymbol to: aTrait)! ! !Behavior methodsFor: 'traits'! addToComposition: aTrait self setTraitComposition: (self traitComposition copyTraitExpression add: aTrait; yourself)! ! !Behavior methodsFor: 'traits' stamp: 'CamilloBruni 4/27/2012 18:22'! addTraitSelector: aSymbol withMethod: aCompiledMethod "Add aMethod with selector aSymbol to my methodDict. aMethod must not be defined locally." | source methodAndNode | [(self includesLocalSelector: aSymbol) not] assert. self ensureLocalSelectors. source := aCompiledMethod getSourceReplacingSelectorWith: aSymbol. methodAndNode := self compile: source classified: aCompiledMethod category notifying: nil trailer: self defaultMethodTrailer ifFail: [^nil]. methodAndNode method putSource: source fromParseNode: methodAndNode node inFile: 2 withPreamble: [:f | f cr; nextPut: $!!; nextChunkPut: 'Trait method'; cr]. methodAndNode method properties at: #traitSource put: aCompiledMethod. self basicAddSelector: aSymbol withMethod: methodAndNode method! ! !Behavior methodsFor: 'traits'! applyChangesOfNewTraitCompositionReplacing: oldComposition | changedSelectors | changedSelectors := self traitComposition changedSelectorsComparedTo: oldComposition. changedSelectors isEmpty ifFalse: [ self noteChangedSelectors: changedSelectors]. self traitComposition isEmpty ifTrue: [ self purgeLocalSelectors]. ^changedSelectors! ! !Behavior methodsFor: 'traits' stamp: 'dvf 9/9/2005 19:45'! classesComposedWithMe ^{self}! ! !Behavior methodsFor: 'traits'! 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 isNil ifTrue: [self basicLocalSelectors: self selectors asSet]! ! !Behavior methodsFor: 'traits' stamp: 'jannik.laval 5/1/2010 15:53'! 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: 'traits' stamp: 'jannik.laval 5/1/2010 15:53'! flattenDownAllTraits self traitComposition allTraits do: [:each | self flattenDown: each]. [ self traitComposition isEmpty ] assert. self traitComposition: nil.! ! !Behavior methodsFor: 'traits' stamp: 'al 3/25/2006 12:39'! hasTraitComposition self subclassResponsibility ! ! !Behavior methodsFor: 'traits'! 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: 'traits'! notifyUsersOfChangedSelector: aSelector self notifyUsersOfChangedSelectors: (Array with: aSelector)! ! !Behavior methodsFor: 'traits'! notifyUsersOfChangedSelectors: aCollection! ! !Behavior methodsFor: 'traits'! purgeLocalSelectors self basicLocalSelectors: nil! ! !Behavior methodsFor: 'traits'! removeAlias: aSymbol of: aTrait self setTraitComposition: ( self traitComposition copyWithoutAlias: aSymbol of: aTrait)! ! !Behavior methodsFor: 'traits'! removeFromComposition: aTrait self setTraitComposition: (self traitComposition copyTraitExpression removeFromComposition: aTrait)! ! !Behavior methodsFor: 'traits' stamp: 'jannik.laval 5/1/2010 15:53'! removeTraitSelector: aSymbol [(self includesLocalSelector: aSymbol) not] assert. self basicRemoveSelector: aSymbol! ! !Behavior methodsFor: 'traits' stamp: 'CamilloBruni 4/27/2012 17:48'! 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: 'traits'! setTraitCompositionFrom: aTraitExpression ^ self setTraitComposition: aTraitExpression asTraitComposition! ! !Behavior methodsFor: 'traits' stamp: 'al 3/25/2006 12:36'! traitComposition self subclassResponsibility! ! !Behavior methodsFor: 'traits' stamp: 'al 3/25/2006 12:39'! traitComposition: aTraitComposition self subclassResponsibility ! ! !Behavior methodsFor: 'traits'! traitCompositionIncludes: aTrait ^self == aTrait or: [self hasTraitComposition and: [self traitComposition allTraits includes: aTrait]]! ! !Behavior methodsFor: 'traits'! traitCompositionString ^self hasTraitComposition ifTrue: [self traitComposition asString] ifFalse: ['{}']! ! !Behavior methodsFor: 'traits'! 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: 'traits'! traitTransformations ^ self traitComposition transformations ! ! !Behavior methodsFor: 'traits'! traits "Returns a collection of all traits used by the receiver" ^ self traitComposition traits! ! !Behavior methodsFor: 'traits' stamp: 'mada 5/5/2012 11:34'! 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: 'traits'! 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 = ClassOrganizer default ]) ifTrue: [ self organization classify: selector under: methodDescription effectiveMethodCategory. ]. modifiedSelectors add: selector]]]. ^modifiedSelectors! ! !Behavior methodsFor: 'user interface' stamp: 'marcus.denker 9/29/2008 13:01'! 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: 'user interface' stamp: 'RAA 5/28/2001 12:00'! withAllSubAndSuperclassesDo: aBlock self withAllSubclassesDo: aBlock. self allSuperclassesDo: aBlock. ! ! !Behavior methodsFor: 'private' stamp: 'VeronicaUquillas 6/11/2010 12:46'! 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 Pharo's method cache, either by selector or by method" oldMethod flushCache. selector flushCache! ! !Behavior methodsFor: 'private' stamp: 'MarianoMartinezPeck 1/9/2012 22:32'! becomeCompact "Here are the restrictions on compact classes in order for export segments to work: A compact class index may not be reused. If a class was compact in a release of Pharo, no other class may use that index. The class might not be compact later, and there should be nil in its place in the array." | cct index | self isWeak ifTrue: [^ Halt halt: 'You must not make a weak class compact']. cct := Smalltalk compactClassesArray. (self isCompact or: [cct includes: self]) ifTrue: [^ self halt: self name , 'is already compact']. index := cct indexOf: nil ifAbsent: [^ self halt: 'compact class table is full']. "Install this class in the compact class table" cct at: index put: self. "Update instspec so future instances will be compact" format := format + (index bitShift: 11). "Make up new instances and become old ones into them" self updateInstancesFrom: self. "Purge any old instances" Smalltalk garbageCollect.! ! !Behavior methodsFor: 'private' stamp: 'MarianoMartinezPeck 1/9/2012 22:32'! becomeCompactSimplyAt: index "Make me compact, but don't update the instances. For importing segments." "Here are the restrictions on compact classes in order for export segments to work: A compact class index may not be reused. If a class was compact in a release of Pharo, no other class may use that index. The class might not be compact later, and there should be nil in its place in the array." | cct | self isWeak ifTrue: [^ Halt halt: 'You must not make a weak class compact']. cct := Smalltalk compactClassesArray. (self isCompact or: [cct includes: self]) ifTrue: [^ self halt: self name , 'is already compact']. (cct at: index) ifNotNil: [^ self halt: 'compact table slot already in use']. "Install this class in the compact class table" cct at: index put: self. "Update instspec so future instances will be compact" format := format + (index bitShift: 11). "Caller must convert the instances" ! ! !Behavior methodsFor: 'private' stamp: 'MarianoMartinezPeck 12/16/2011 10:44'! becomeUncompact | cct index | cct := Smalltalk compactClassesArray. (index := self indexIfCompact) = 0 ifTrue: [^ self]. (cct includes: self) ifFalse: [^ self halt "inconsistent state"]. self checkCanBeUncompact. "Update instspec so future instances will not be compact" format := format - (index bitShift: 11). "Make up new instances and become old ones into them" self updateInstancesFrom: self. "Make sure there are no compact ones left around" Smalltalk garbageCollect. "Remove this class from the compact class table" cct at: index put: nil. ! ! !Behavior methodsFor: 'private' stamp: 'MarianoMartinezPeck 12/16/2011 10:47'! 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: 'private'! 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: 'private' stamp: 'StephaneDucasse 3/12/2011 15:39'! 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." ^ (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: '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: 'private'! 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 class uses: TPureBehavior classTrait instanceVariableNames: ''! !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: '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: 'class initialization' stamp: 'apb 7/12/2004 23:46'! initializeObsoleteSubclasses ObsoleteSubclasses := WeakKeyToCollectionDictionary new.! ! !Behavior class methodsFor: 'cleanup' stamp: 'StephaneDucasse 3/9/2010 16:08'! cleanUp "Flush the obsolete subclasses." self flushObsoleteSubclasses! ! !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! ! CodeDeclaration subclass: #BehaviorInstallingDeclaration instanceVariableNames: 'behaviorName isMeta' classVariableNames: '' poolDictionaries: '' category: 'CodeImport'! !BehaviorInstallingDeclaration commentStamp: '' prior: 0! 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'! behaviorName: aBehaviorName behaviorName := aBehaviorName! ! !BehaviorInstallingDeclaration methodsFor: 'accessing' stamp: 'GuillermoPolito 5/5/2012 20:35'! isMeta: aBoolean isMeta := aBoolean! ! !BehaviorInstallingDeclaration methodsFor: 'accessing' stamp: 'GuillermoPolito 5/5/2012 20:36'! targetClass | target | target := self class environment at: behaviorName. ^isMeta ifTrue: [ target classSide ] ifFalse: [ target ]! ! !BehaviorInstallingDeclaration methodsFor: 'testing' stamp: 'GuillermoPolito 5/5/2012 20:37'! existsBehavior ^self class environment includesKey: behaviorName! ! TestCase subclass: #BehaviorTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Classes'! !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/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: '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). ! ! !BehaviorTest methodsFor: 'tests' stamp: 'AlexandreBergel 10/28/2009 11:02'! 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 methodDictionary associationsDo: [:assoc | (Object includesSelector: assoc key) ifFalse: [ nonOverridenMethods add: assoc value ] ]. self assert: (allMethods includesAllOf: nonOverridenMethods).! ! !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: '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' 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: '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: 'sd 3/14/2004 18:11'! testBehaviorSubclasses "self run: #testBehaviorSubclasses" | b b2 | b := Behavior new. b superclass: OrderedCollection. b methodDictionary: MethodDictionary new. self shouldnt: [b subclasses ] raise: Error. self shouldnt: [b withAllSubclasses] raise: Error. self shouldnt: [b allSubclasses] raise: Error. b2 := Behavior new. b2 superclass: b. b2 methodDictionary: MethodDictionary new. self assert: (b subclasses includes: b2). self assert: (b withAllSubclasses includes: b).! ! !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: '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: 'ar 9/27/2005 21:43'! testChange "self debug: #testChange" | behavior model | behavior := Behavior new. behavior superclass: Model. behavior setFormat: Model format. model := Model new. model primitiveChangeClassTo: behavior new. behavior compile: 'thisIsATest ^ 2'. self assert: model thisIsATest = 2. self should: [Model new thisIsATest] raise: MessageNotUnderstood. ! ! !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: 'tests' stamp: 'PavelKrivanek 11/8/2012 20:57'! testComposedBy "tests the #isComposedBy: aTrait method" self should: [ Object isComposedBy: Object ] raise: Error. self deny: (Object isComposedBy: TSortable). self deny: (Object new isComposedBy: TSortable). self assert: (SequenceableCollection isComposedBy: TSortable). self assert: (SequenceableCollection new isComposedBy: TSortable).! ! !BehaviorTest methodsFor: 'tests' stamp: 'nice 12/25/2009 19:10'! testFormalParameterNames | method | method := #sampleMessageWithFirstArgument:andInterleavedCommentBeforeSecondArgument:. self assert: (self class formalParametersAt: method) size = 2. self assert: (self class formalParametersAt: method) asArray = #('firstArgument' 'secondArgument'). Object selectorsDo: [:e | self assert: (Object formalParametersAt: e) size = e numArgs].! ! !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 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: '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 - 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).! ! LineSegment subclass: #Bezier2Segment instanceVariableNames: 'via' classVariableNames: '' poolDictionaries: '' category: 'Balloon-Geometry'! !Bezier2Segment commentStamp: '' prior: 0! This class represents a quadratic bezier segment between two points Instance variables: via The additional control point (OFF the curve)! !Bezier2Segment methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:14'! bounds "Return the bounds containing the receiver" ^super bounds encompass: via! ! !Bezier2Segment methodsFor: 'accessing' stamp: 'ar 6/8/2003 00:07'! degree ^2! ! !Bezier2Segment methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:14'! via "Return the control point" ^via! ! !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: 'converting' stamp: 'ar 6/8/2003 04:19'! asBezier2Points: error ^Array with: start with: via with: end! ! !Bezier2Segment methodsFor: 'converting' stamp: 'ar 11/2/1998 12:17'! asBezier2Segment "Represent the receiver as quadratic bezier segment" ^self! ! !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: '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: 'converting' stamp: 'ar 6/7/2003 20:58'! asTangentSegment ^LineSegment from: via-start to: end-via! ! !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 11/2/1998 12:13'! from: startPoint to: endPoint via: viaPoint "Initialize the receiver" start := startPoint. end := endPoint. via := viaPoint.! ! !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: '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: '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: '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: 'testing' stamp: 'ar 11/2/1998 12:15'! hasZeroLength "Return true if the receiver has zero length" ^start = end and:[start = via]! ! !Bezier2Segment methodsFor: 'testing' stamp: 'ar 11/2/1998 12:15'! isBezier2Segment "Return true if the receiver is a quadratic bezier segment" ^true! ! !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: '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: '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/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: '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: '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: '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: '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/9/2003 03:43'! parameterAtExtremeY "Note: Only valid for non-monoton receivers" ^self parameterAtExtreme: 1.0@0.0. ! ! !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 methodsFor: 'vector functions' stamp: 'nk 12/27/2003 13:00'! roundTo: quantum super roundTo: quantum. via := via roundTo: quantum. ! ! !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: 'vector functions' stamp: 'ar 11/2/1998 12:16'! tangentAtEnd "Return the tangent for the last point" ^end - via! ! !Bezier2Segment methodsFor: 'vector functions' stamp: 'ar 11/2/1998 12:16'! tangentAtStart "Return the tangent for the first point" ^via - start! ! !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 class instanceVariableNames: ''! !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: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: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: '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! ! !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: '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}! ! LineSegment subclass: #Bezier3Segment instanceVariableNames: 'via1 via2' classVariableNames: '' poolDictionaries: '' category: 'Balloon-Geometry'! !Bezier3Segment commentStamp: '' prior: 0! This class represents a cubic bezier segment between two points Instance variables: via1, via2 The additional control points (OFF the curve)! !Bezier3Segment methodsFor: 'accessing' stamp: 'DSM 10/15/1999 15:20'! bounds ^ ((super bounds encompassing: via1) encompassing: via2)! ! !Bezier3Segment methodsFor: 'accessing' stamp: 'ar 6/8/2003 00:07'! degree ^3! ! !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: '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: 'accessing' stamp: 'ar 6/6/2003 22:37'! via1 ^via1! ! !Bezier3Segment methodsFor: 'accessing' stamp: 'DSM 10/14/1999 15:31'! via1: aPoint via1 := aPoint! ! !Bezier3Segment methodsFor: 'accessing' stamp: 'ar 6/6/2003 22:37'! via2 ^via2! ! !Bezier3Segment methodsFor: 'accessing' stamp: 'DSM 10/14/1999 15:31'! via2: aPoint via2 := aPoint! ! !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: '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: '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: '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: '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: '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 methodsFor: 'converting' stamp: 'ar 6/7/2003 20:58'! asTangentSegment ^Bezier2Segment from: via1-start via: via2-via1 to: end-via2! ! !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: '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: '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: 'vector functions' stamp: 'ar 6/7/2003 00:08'! controlPoints ^{start. via1. via2. end}! ! !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/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: '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: '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/6/2003 22:01'! tangentAtStart ^via1 - start! ! !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: '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 class instanceVariableNames: ''! !Bezier3Segment class methodsFor: '*Morphic-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: '*Morphic-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: '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: '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: '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: '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: '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: '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 ! ! !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: '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 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! ! Object subclass: #BindingsHolder instanceVariableNames: 'bindings' classVariableNames: 'Bindings' poolDictionaries: '' category: 'Spec-Bindings'! !BindingsHolder commentStamp: '' prior: 0! A BindingsHolder is a simple wrapper to manage the bindings It has actually two bindings - the current one: the inst var bindings it's the first one queried - is the needed selector is not defined in the current binding, itchecks in a default one (the class var Bindings)! !BindingsHolder methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/12/2012 15:21'! bindings ^ bindings contents! ! !BindingsHolder methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/12/2012 15:21'! bindings: anObject bindings contents: anObject! ! !BindingsHolder methodsFor: 'as yet unclassified' stamp: 'BenjaminVanRyseghem 12/12/2012 15:22'! printOn: s super printOn: s. s nextPutAll: '('. self bindings printOn: s. s nextPutAll: ')'! ! !BindingsHolder methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 12/12/2012 15:20'! initialize "Initialization code for BindingsHolder" super initialize. bindings := MorphicBindings new asValueHolder.! ! !BindingsHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/12/2012 15:22'! classSymbolFor: aSymbol ifAbsent: aBlock ^ self bindings classSymbolFor: aSymbol ifAbsent: aBlock! ! !BindingsHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/12/2012 15:22'! resetBinding self bindings: self class bindings! ! !BindingsHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/24/2012 10:29'! retrieveClassSymbolFor: aSymbol ^ self bindings ifNil: [ self retrieveDefaultClassSymbolFor: aSymbol ] ifNotNil: [:bdg | bdg classSymbolFor: aSymbol ifAbsent: [ self retrieveDefaultClassSymbolFor: aSymbol ]]! ! !BindingsHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/24/2012 10:29'! retrieveDefaultClassSymbolFor: aSymbol ^ self class bindings classSymbolFor: aSymbol ifAbsent: [ aSymbol ]! ! !BindingsHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/24/2012 10:29'! retrieveDefaultSelectorSymbolFor: aSymbol ^ self class bindings selectorSymbolFor: aSymbol ifAbsent: [ aSymbol ]! ! !BindingsHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/12/2012 15:21'! retrieveSelectorSymbolFor: aSymbol ^ self bindings ifNil: [ self retrieveDefaultSelectorSymbolFor: aSymbol ] ifNotNil: [:binding | binding selectorSymbolFor: aSymbol ifAbsent: [ self retrieveDefaultSelectorSymbolFor: aSymbol ]]! ! !BindingsHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/12/2012 15:22'! selectorSymbolFor: aSymbol ifAbsent: aBlock ^ self bindings selectorSymbolFor: aSymbol ifAbsent: aBlock! ! !BindingsHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/12/2012 15:24'! whenChangedDo: aBlock bindings whenChangedDo: aBlock! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BindingsHolder class instanceVariableNames: ''! !BindingsHolder class methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/24/2012 10:36'! bindings ^ Bindings ifNil: [ Bindings := self defaultBindings ]! ! !BindingsHolder class methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/24/2012 10:37'! defaultBindings ^ MorphicBindings new! ! Object subclass: #BitBlt instanceVariableNames: 'destForm sourceForm halftoneForm combinationRule destX destY width height sourceX sourceY clipX clipY clipWidth clipHeight colorMap' classVariableNames: 'CachedFontColorMaps ColorConvertingMaps' poolDictionaries: '' category: 'Graphics-Primitives'! !BitBlt commentStamp: '' prior: 0! 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: '*FreeType-Addition' stamp: 'tween 8/1/2006 17:52'! combinationRule "Answer the receiver's combinationRule" ^combinationRule! ! !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: '*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 methodsFor: '*FreeType-Addition' stamp: 'FernandoOlivero 6/10/2011 16:34'! lastFontForegroundColor ^ nil ! ! !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: '*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: '*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/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: '*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: '*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: '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: 'ar 5/17/2000 18:58'! clipHeight ^clipHeight! ! !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: 'accessing'! clipRect "Answer the receiver's clipping area rectangle." ^clipX @ clipY extent: clipWidth @ clipHeight! ! !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: 'accessing' stamp: 'ar 5/17/2000 18:58'! clipWidth ^clipWidth! ! !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: 'accessing' stamp: 'ar 5/17/2000 18:58'! clipX ^clipX! ! !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: 'ar 5/17/2000 18:58'! clipY ^clipY! ! !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: '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'! colorMap ^ colorMap! ! !BitBlt methodsFor: 'accessing' stamp: 'CamilloBruni 8/1/2012 16:02'! colorMap: map "See last part of BitBlt comment." colorMap := map! ! !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: 'accessing'! destForm ^ destForm! ! !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: '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: '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'! destX: anInteger "Set the top left x coordinate of the receiver's destination form to be the argument, anInteger." destX := anInteger! ! !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'! fillColor ^ halftoneForm! ! !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: 'tbn 9/14/2004 20:38'! halftoneForm "Returns the receivers half tone form. See class commment." ^halftoneForm! ! !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: '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: 'accessing'! sourceForm ^ sourceForm! ! !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: '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: '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'! sourceX: anInteger "Set the receiver's source form top left x to be the argument, anInteger." sourceX := anInteger! ! !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: 'accessing' stamp: 'ar 5/25/2000 19:39'! tallyMap "Return the map used for tallying pixels" ^colorMap! ! !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: 'lr 7/4/2009 10:42'! width: anInteger "Set the receiver's destination form width to be the argument, anInteger." width := anInteger! ! !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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: 'line drawing'! drawFrom: startPoint to: stopPoint ^ self drawFrom: startPoint to: stopPoint withFirstPoint: true! ! !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: '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: '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: 'private' stamp: 'StephaneDucasse 10/17/2009 17:15'! 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) isNil ifTrue: [ mapsForSourceAndDest := mapsForSource at: destDepth put: Dictionary new ]. map := mapsForSourceAndDest at: targetColor ifAbsentPut: [ Color computeColorConvertingMap: targetColor from: sourceDepth to: destDepth keepSubPixelAA: keepSubPix ]. ^ 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: '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: '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: '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: 'private' stamp: 'StephaneDucasse 10/20/2011 15:43'! paintBits "Perform the paint operation, which requires two calls to BitBlt." | color oldMap saveRule | sourceForm depth = 1 ifFalse: [ ^ Halt halt: '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: '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: '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: '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: '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 class instanceVariableNames: ''! !BitBlt class methodsFor: 'class initialization' stamp: 'jmv 9/7/2009 09:32'! initialize self recreateColorMaps! ! !BitBlt class methodsFor: 'cleanup' stamp: 'StephaneDucasse 3/9/2010 16:18'! cleanUp "Flush caches" 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: '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: 'instance creation' stamp: 'MarcusDenker 11/18/2012 19:28'! current "Return the class currently to be used for BitBlt" ^self! ! !BitBlt class methodsFor: 'instance creation'! 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: 'instance creation'! 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'! toForm: aForm ^ self new setDestForm: aForm! ! !BitBlt class methodsFor: 'private' stamp: 'StephaneDucasse 10/17/2009 17:15'! recreateColorMaps CachedFontColorMaps := ColorConvertingMaps := nil! ! TestCase subclass: #BitBltClipBugs instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Bugs'! !BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:33'! 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. self shouldnt:[bb copyBits] raise: Error. ! ! !BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:33'! 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. self shouldnt:[bb copyBits] raise: Error.! ! !BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:33'! 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. self shouldnt:[bb copyBits] raise: Error. ! ! !BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:34'! 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. self shouldnt:[bb copyBits] raise: Error. ! ! !BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:34'! 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. self shouldnt:[bb copyBits] raise: Error.! ! !BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:34'! 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. self shouldnt:[bb copyBits] raise: Error. ! ! !BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:32'! 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. self shouldnt:[bb copyBits] raise: Error. ! ! !BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:32'! 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. self shouldnt:[bb copyBits] raise: Error.! ! !BitBltClipBugs methodsFor: 'as yet unclassified' stamp: 'ar 3/8/2003 00:32'! 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. self shouldnt:[bb copyBits] raise: Error. ! ! ClassTestCase subclass: #BitBltTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Tests-Primitives'! !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: '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 ] ]! ! !BitBltTest methodsFor: 'bugs' stamp: 'sd 6/5/2005 10:13'! testPeekerUnhibernateBug "self run: #testPeekerUnhibernateBug" | bitBlt | bitBlt := BitBlt bitPeekerFromForm: Display. bitBlt destForm hibernate. self shouldnt:[bitBlt pixelAt: 1@1] raise: Error.! ! !BitBltTest methodsFor: 'bugs' stamp: 'sd 6/5/2005 10:14'! testPokerUnhibernateBug "self run: #testPokerUnhibernateBug" | bitBlt | bitBlt := BitBlt bitPokerToForm: Display. bitBlt sourceForm hibernate. self shouldnt:[bitBlt pixelAt: 1@1 put: 0] raise: Error.! ! ArrayedCollection variableWordSubclass: #Bitmap instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Primitives'! !Bitmap commentStamp: '' prior: 0! 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: '*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: '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: '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: '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: '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: 'accessing' stamp: 'ar 3/3/2001 16:18'! byteSize ^self size * 4! ! !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: 'ar 11/2/1998 12:19'! defaultElement "Return the default element of the receiver" ^0! ! !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: '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: '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'! 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'! 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: '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 methodsFor: 'conversion' stamp: 'CamilloBruni 11/2/2012 10:12'! restoreEndianness "nothing to do here?"! ! !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: '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: '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: '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: '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: '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: '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: '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: '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: '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: 'printing' stamp: 'sma 6/1/2000 09:42'! printOn: aStream self printNameOn: aStream. aStream nextPutAll: ' of length '; print: self size! ! !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 class instanceVariableNames: ''! !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: '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'! 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) ]! ! !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! ! OrientedFillStyle subclass: #BitmapFillStyle instanceVariableNames: 'form tileFlag' classVariableNames: '' poolDictionaries: '' category: 'Balloon-Fills'! !BitmapFillStyle commentStamp: '' prior: 0! 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: '*morphic-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: '*morphic-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: 'accessing' stamp: 'ar 11/11/1998 22:40'! form ^form! ! !BitmapFillStyle methodsFor: 'accessing' stamp: 'ar 11/11/1998 22:40'! form: aForm form := aForm! ! !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: 'accessing' stamp: 'ar 11/27/1998 14:37'! tileFlag ^tileFlag! ! !BitmapFillStyle methodsFor: 'accessing' stamp: 'ar 11/27/1998 14:30'! tileFlag: aBoolean tileFlag := aBoolean! ! !BitmapFillStyle methodsFor: 'converting' stamp: 'ar 11/11/1998 22:41'! asColor ^form colorAt: 0@0! ! !BitmapFillStyle methodsFor: 'testing' stamp: 'ar 11/11/1998 22:40'! isBitmapFill ^true! ! !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 class instanceVariableNames: ''! !BitmapFillStyle class methodsFor: 'instance creation' stamp: 'ar 11/13/1998 20:32'! form: aForm ^self new form: aForm! ! !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 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! ! ComposableModel subclass: #BlocEditor instanceVariableNames: 'block ok post pre text' classVariableNames: '' poolDictionaries: '' category: 'Spec-Tools-Editor'! !BlocEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/11/2012 18:17'! block ^ block contents! ! !BlocEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/11/2012 18:17'! block: aBlock block contents: aBlock ! ! !BlocEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/12/2012 18:20'! ok ^ ok! ! !BlocEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/11/2012 18:08'! post ^ post! ! !BlocEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/11/2012 18:08'! pre ^ pre! ! !BlocEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/12/2012 18:20'! text ^ text! ! !BlocEditor 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! ! !BlocEditor methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 7/11/2012 18:20'! okAction text accept. block contents: (Compiler evaluate: (String streamContents: [:s | s << '[' << text getText <<']'])).! ! !BlocEditor methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 7/11/2012 18:18'! initialize "Initialization code for BlocEditor" super initialize. block := nil asValueHolder! ! !BlocEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/11/2012 18:05'! buildWithSpec ^ self buildWithSpecLayout: self layout! ! !BlocEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/11/2012 18:09'! buildWithSpec: aSpec ^ self buildWithSpecLayout: self layout! ! !BlocEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/12/2012 18:00'! help: aString text help: aString ! ! !BlocEditor methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/11/2012 19:11'! whenBlockChangedDo: aBlock block whenChangedDo: aBlock ! ! !BlocEditor 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! ! AbstractApiSetter subclass: #BlockApiSetter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Spec-Tools-Editor'! !BlockApiSetter methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 7/11/2012 19:11'! initializeWidgets self instantiateModels: #( selector LabelModel choice BlocEditor ). 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! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BlockApiSetter class instanceVariableNames: ''! !BlockApiSetter class methodsFor: 'as yet unclassified' stamp: 'BenjaminVanRyseghem 7/11/2012 19:00'! spec ^ SpecLayout composed newRow: [:r | r add: #selector; newColumn: [:c | c add: #choice ] width: 75] height: 25; yourself! ! Error subclass: #BlockCannotReturn instanceVariableNames: 'result deadHome' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Exceptions'! !BlockCannotReturn commentStamp: '' prior: 0! 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 ^ deadHome! ! !BlockCannotReturn methodsFor: 'accessing' stamp: 'ajh 2/6/2002 11:12'! deadHome: context deadHome := context! ! !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! ! !BlockCannotReturn methodsFor: 'exceptiondescription' stamp: 'tfei 3/30/1999 12:55'! defaultAction self messageText: 'Block cannot return'. ^super defaultAction! ! !BlockCannotReturn methodsFor: 'exceptiondescription' stamp: 'tfei 4/2/1999 15:49'! isResumable ^true! ! Object variableSubclass: #BlockClosure instanceVariableNames: 'outerContext startpc numArgs' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Methods'! !BlockClosure commentStamp: '' prior: 0! I am a block closure for Eliot's closure implementation. Not to be confused with the old BlockClosure.! !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: '*Compiler-Kernel' stamp: 'MarcusDenker 2/2/2013 18:22'! decompile ^self method decompilerClass new decompileBlock: self! ! !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: '*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: '*Fuel' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^ self shouldBeSubstitutedByCleanCopy ifTrue: [ aGeneralMapper visitSubstitution: self by: self cleanCopy ] ifFalse: [ aGeneralMapper visitVariableObject: self ]! ! !BlockClosure methodsFor: '*Fuel' stamp: 'adas 4/16/2012 16:37'! shouldBeSubstitutedByCleanCopy "The 'self sender isNil not' is just to avoid an infinitive loop for the substitution. As you can see, the copy of this closure has a cleaned outer context (see #cleanOuterContext) and such context has a nil sender (see #cleanCopy)" ^ self isClean and: [ self sender isNil not ]! ! !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: '*FuelTests' stamp: 'MarianoMartinezPeck 8/19/2012 15:46'! fuelValueWithoutNotifications SystemAnnouncer uniqueInstance suspendAllWhile: self! ! !BlockClosure methodsFor: '*Kernel-Job' stamp: 'SeanDeNigris 8/29/2012 13:41'! asJob ^ Job block: self.! ! !BlockClosure methodsFor: '*Text-Core' stamp: 'stephane.ducasse 4/21/2009 11:52'! asText ^ self asString asText! ! !BlockClosure methodsFor: '*Tools' stamp: 'BernardoContreras 8/15/2011 20:25'! timeProfile ^Smalltalk tools timeProfiler onBlock: self! ! !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: '*compatibility' stamp: 'SeanDeNigris 8/31/2011 14:20'! fixTemps "Fix the values of the temporary variables used in the block that are ordinarily shared with the method in which the block is defined. This is a no-op for closures, provided for backward-compatibility with old BlockContexts that needed the fixTemps hack to persist." self deprecated: 'BlockClosure does not need to fixTemps' on: '10 February 2010' in: 'Pharo1.2'! ! !BlockClosure methodsFor: '*deprecated20' stamp: 'SeanDeNigris 8/30/2012 10:40'! silentlyValue "evaluates the receiver but avoiding progress bar notifications to show up." self deprecated: 'dont use' on: 'Jul 2012' in: '2.0'. ^ self asJob loggingProgress; run.! ! !BlockClosure methodsFor: '*metacello-core' stamp: 'dkh 10/7/2009 00:12'! setAuthorInMetacelloConfig: aMetacelloConfig aMetacelloConfig setAuthorWithBlock: self! ! !BlockClosure methodsFor: '*metacello-core' stamp: 'dkh 10/7/2009 00:12'! setBlessingInMetacelloConfig: aMetacelloConfig aMetacelloConfig setBlessingWithBlock: self! ! !BlockClosure methodsFor: '*metacello-core' stamp: 'dkh 10/7/2009 00:14'! setDescriptionInMetacelloConfig: aMetacelloConfig aMetacelloConfig setDescriptionWithBlock: self! ! !BlockClosure methodsFor: '*metacello-core' stamp: 'dkh 10/9/2009 11:28'! setPackage: aString withInMetacelloConfig: aMetacelloConfig aMetacelloConfig setPackage: aString withBlock: self! ! !BlockClosure methodsFor: '*metacello-core' stamp: 'dkh 10/9/2009 11:17'! setProject: aString withInMetacelloConfig: aMetacelloConfig aMetacelloConfig setProject: aString withBlock: self! ! !BlockClosure methodsFor: '*metacello-core' stamp: 'dkh 10/7/2009 00:15'! setTimestampInMetacelloConfig: aMetacelloConfig aMetacelloConfig setTimestampWithBlock: self! ! !BlockClosure methodsFor: '*metacello-mc' stamp: 'DaleHenrichs 1/16/2010 11:42'! 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: '*system-announcements' stamp: 'EstebanLorenzano 8/8/2012 11:20'! valueWithoutNotifications ^SystemAnnouncer uniqueInstance suspendAllWhile: self! ! !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: 'accessing' stamp: 'eem 9/3/2008 13:57'! copiedValueAt: i ^self basicAt: i! ! !BlockClosure methodsFor: 'accessing' stamp: 'eem 4/26/2012 10:20'! endPC ^self blockCreationBytecodeMessage arguments last + startpc - 1! ! !BlockClosure methodsFor: 'accessing' stamp: 'eem 7/28/2008 13:58'! home ^outerContext home! ! !BlockClosure methodsFor: 'accessing' stamp: 'ajh 1/21/2003 13:16'! isBlock ^ true! ! !BlockClosure methodsFor: 'accessing' stamp: 'eem 5/29/2008 12:18'! method ^outerContext method! ! !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: '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: 'accessing' stamp: 'eem 4/26/2012 11:01'! numTemps "Answer the number of temporaries for the receiver; this includes the number of arguments and the number of copied values." | blockCreationBytecodeSize | ^self numCopiedValues + self numArgs + (BlockLocalTempCounter tempCountForBlockAt: startpc - (blockCreationBytecodeSize := 4) in: self method)! ! !BlockClosure methodsFor: 'accessing' stamp: 'eem 5/24/2008 11:21'! outerContext ^outerContext! ! !BlockClosure methodsFor: 'accessing' stamp: 'eem 6/26/2008 09:17'! receiver ^outerContext receiver! ! !BlockClosure methodsFor: 'accessing' stamp: 'eem 6/1/2008 09:39'! startpc ^startpc! ! !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: '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: '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: '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: 'controlling'! 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: 'controlling'! 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: '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: '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: 'controlling'! 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: 'controlling'! 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: '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: '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: '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: 'evaluating' stamp: 'HenrikSperreJohansen 2/18/2010 14:35'! cull: anArg ^numArgs = 0 ifTrue: [self value] ifFalse: [self value: anArg] ! ! !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: '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: '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: 'evaluating' stamp: 'StephaneDucasse 8/17/2011 22:24'! durationToRun "Answer the duration taken to execute this block." ^ Duration milliSeconds: self timeToRun ! ! !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: '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: 'evaluating' stamp: 'jm 6/3/1998 14:25'! timeToRun "Answer the number of milliseconds taken to execute this block." ^ Time millisecondsToRun: self ! ! !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: '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: '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: '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: '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: '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: '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: '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: 'MarcusDenker 1/22/2010 08:41'! 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 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: 'jrp 10/10/2004 22:28'! valueSuppressingAllMessages ^ self valueSuppressingMessages: #('*')! ! !BlockClosure methodsFor: 'evaluating' stamp: 'al 4/3/2009 18:24'! valueSuppressingMessages: aListOfStrings ^ self valueSuppressingMessages: aListOfStrings supplyingAnswers: #()! ! !BlockClosure methodsFor: 'evaluating' stamp: 'al 4/3/2009 18:24'! valueSuppressingMessages: aListOfStrings supplyingAnswers: aListOfPairs ^ self valueSupplyingAnswers: aListOfPairs, (aListOfStrings collect: [:each | {each. true}])! ! !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: '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: 'evaluating' stamp: 'md 3/28/2006 20:17'! valueWithExit self value: [ ^nil ]! ! !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: '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: '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: 'exceptions' stamp: 'jannik.laval 5/2/2010 06:40'! assert self value ifFalse: [AssertionFailure signal: 'Assertion failed'] ! ! !BlockClosure methodsFor: 'exceptions' stamp: 'MarcusDenker 12/9/2010 14:53'! assertWithDescription: aStringOrABlock self value ifFalse: [ |value| value := aStringOrABlock value. AssertionFailure signal: value]! ! !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: '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: '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: '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: '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: '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: '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: 'printing' stamp: 'eem 7/28/2008 14:09'! fullPrintOn: aStream aStream print: self; cr. (self decompile ifNil: ['--source missing--']) printOn: aStream indent: 0! ! !BlockClosure methodsFor: 'printing' stamp: 'NikoSchwarz 6/5/2010 17:51'! printOn: aStream self decompile printAsIfCompiledOn: aStream.! ! !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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: 'testing' stamp: 'eem 5/23/2008 13:48'! isClosure ^true! ! !BlockClosure methodsFor: 'testing' stamp: 'eem 11/26/2008 20:27'! isDead "Has self finished" ^false! ! !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: 'private' stamp: 'sd 3/22/2009 19:33'! asMinimalRepresentation "Answer the receiver." ^self! ! !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: 'private' stamp: 'sd 3/22/2009 19:33'! isValid "Answer the receiver." ^true! ! !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 class instanceVariableNames: ''! !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! ! TestCase subclass: #BlockClosureTest instanceVariableNames: 'aBlockContext contextOfaBlockContext' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Methods'! !BlockClosureTest methodsFor: 'setup' stamp: 'MarcusDenker 2/24/2010 12:28'! setUp super setUp. aBlockContext := [100@100 corner: 200@200]. contextOfaBlockContext := thisContext.! ! !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: '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: '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: '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: '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' stamp: 'MarcusDenker 2/24/2010 12:28'! testRunSimulated self assert: (ContextPart runSimulated: aBlockContext) class = Rectangle.! ! !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: 'MarcusDenker 2/24/2010 12:28'! testSupplyAnswerThroughNestedBlocks self should: [true = ([[self confirm: 'You like Smalltalk?'] valueSupplyingAnswer: #('Blub' false)] valueSupplyingAnswer: #('Smalltalk' true))]! ! !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' stamp: 'MarcusDenker 2/24/2010 12:28'! testSupplyAnswerUsingTraditionalMatchOfQuestion self should: [true = ([self confirm: 'You like Smalltalk?'] valueSupplyingAnswer: #('*Smalltalk#' true))]! ! !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' 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: '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' 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' 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: 'tests' stamp: 'md 6/24/2010 16:25'! testTallyInstructions self assert: (ContextPart tallyInstructions: aBlockContext) size = 21.! ! !BlockClosureTest methodsFor: 'tests' stamp: 'md 6/24/2010 16:25'! testTallyMethods self assert: (ContextPart tallyMethods: aBlockContext) size = 5.! ! !BlockClosureTest methodsFor: 'tests' stamp: 'MarcusDenker 2/24/2010 12:28'! testTrace self assert: (ContextPart trace: aBlockContext) class = Rectangle.! ! !BlockClosureTest methodsFor: 'tests - evaluating' stamp: 'MarcusDenker 2/24/2010 12:32'! testCull self shouldnt: [ [ ] cull: 1 ] raise: Error. self shouldnt: [ [ :x | ] cull: 1 ] raise: Error. 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 - evaluating' stamp: 'MarcusDenker 2/24/2010 12:31'! testCullCull self shouldnt: [ [ ] cull: 1 cull: 2 ] raise: Error. self shouldnt: [ [ :x | ] cull: 1 cull: 2 ] raise: Error. self shouldnt: [ [ :x :y | ] cull: 1 cull: 2 ] raise: Error. 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 - evaluating' stamp: 'MarcusDenker 2/24/2010 12:32'! testCullCullCull self shouldnt: [ [ ] cull: 1 cull: 2 cull: 3 ] raise: Error. self shouldnt: [ [ :x | ] cull: 1 cull: 2 cull: 3 ] raise: Error. self shouldnt: [ [ :x :y | ] cull: 1 cull: 2 cull: 3 ] raise: Error. self shouldnt: [ [ :x :y :z | ] cull: 1 cull: 2 cull: 3 ] raise: Error. 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: 'MarcusDenker 2/24/2010 12:31'! testCullCullCullCull self shouldnt: [ [ ] cull: 1 cull: 2 cull: 3 cull: 4 ] raise: Error. self shouldnt: [ [ :x | ] cull: 1 cull: 2 cull: 3 cull: 4 ] raise: Error. self shouldnt: [ [ :x :y | ] cull: 1 cull: 2 cull: 3 cull: 4 ] raise: Error. self shouldnt: [ [ :x :y :z | ] cull: 1 cull: 2 cull: 3 cull: 4 ] raise: Error. self shouldnt: [ [ :x :y :z :a | ] cull: 1 cull: 2 cull: 3 cull: 4 ] raise: Error. 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 - evaluating' stamp: 'HenrikSperreJohansen 6/28/2010 12:19'! testValueWithArguments self should: [aBlockContext valueWithArguments: #(1 )] raise: Error. self shouldnt: [aBlockContext valueWithArguments: #()] raise: Error. [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 - 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 - 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 - 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'! 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 - 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 - 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 - 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 - 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 - on-fork' stamp: 'GuillermoPolito 5/28/2011 14:32'! testOnForkErrorTakesLessThanOneSecond "Test that if code runs with error, there is fork" | sema timeout | sema := Semaphore new. [ 1/0 ] on: Exception fork: [ sema signal ]. timeout := (sema waitTimeoutSeconds: 1). self assert: timeout == false. ! ! !BlockClosureTest methodsFor: 'tests - on-fork' stamp: 'GuillermoPolito 5/28/2011 14:37'! testOnForkSplit "Test that when forking, the stack are split correctly (there is no any contexts referenced by both processes)" | sema timeout forkedContexts myContexts c | 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 - printing' stamp: 'MarcusDenker 2/24/2010 12:28'! testDecompile self assert: ([3 + 4] decompile printString = '{[3 + 4]}').! ! TestCase subclass: #BlockClosuresTestCase instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Methods'! !BlockClosuresTestCase commentStamp: '' prior: 0! This test case collects examples for block uses that require full block closures.! !BlockClosuresTestCase methodsFor: 'examples' stamp: 'rw 1/26/2002 01:20'! constructCannotReturnBlockInDeadFrame ^ [:arg | ^arg]. ! ! !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: '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: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: '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: '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: '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: '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: '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: '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: '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: '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: 'rw 1/26/2002 01:22'! testCannotReturn | blk | blk := self constructCannotReturnBlockInDeadFrame. self should: [blk value: 1] raise: Exception ! ! !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: '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: '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: 'BG 1/24/2002 16:05'! testExample1 self assert: ((self example1: 5) = 5 factorial) ! ! !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: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: '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 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: '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: '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 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: '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). ! ! InstructionClient subclass: #BlockLocalTempCounter instanceVariableNames: 'stackPointer scanner blockEnd joinOffsets' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Support'! !BlockLocalTempCounter commentStamp: '' prior: 0! 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: 'initialize-release' stamp: 'eem 9/26/2008 13:40'! 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 isNil ifTrue: [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: 'initialize-release' stamp: 'eem 9/26/2008 13:41'! 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 isNil ifTrue: [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/26/2008 11:36'! blockReturnTop "Return Top Of Stack bytecode." stackPointer := stackPointer - 1. scanner pc < blockEnd ifTrue: [self doJoin]! ! !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/23/2008 16:17'! doPop "Remove Top Of Stack 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/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/26/2008 11:36'! methodReturnConstant: value "Return Constant bytecode." self doJoin! ! !BlockLocalTempCounter methodsFor: 'instruction decoding' stamp: 'eem 9/26/2008 11:36'! methodReturnReceiver "Return Self bytecode." self doJoin! ! !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'! popIntoLiteralVariable: anAssociation "Remove Top Of Stack And Store Into Literal Variable bytecode." stackPointer := stackPointer - 1! ! !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/23/2008 16:20'! popIntoTemporaryVariable: offset "Remove Top Of Stack And Store Into Temporary Variable bytecode." stackPointer := stackPointer - 1! ! !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: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: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/23/2008 16:21'! pushConstant: value "Push Constant, value, 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:22'! pushNewArrayOfSize: numElements "Push New Array of size numElements bytecode." stackPointer := stackPointer + 1! ! !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: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: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: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/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: 'private' stamp: 'eem 9/26/2008 13:40'! doJoin scanner pc < blockEnd ifTrue: [stackPointer := joinOffsets at: scanner pc]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BlockLocalTempCounter class instanceVariableNames: ''! !BlockLocalTempCounter class methodsFor: 'instance creation' stamp: 'eem 9/23/2008 16:07'! tempCountForBlockAt: pc in: method ^self new tempCountForBlockAt: pc in: method! ! ParseNode subclass: #BlockNode instanceVariableNames: 'arguments statements returns nArgsNode size remoteCopyNode temporaries optimized optimizedMessageNode actualScopeIfOptimized blockExtent remoteTempNode copiedValues closureCreationNode startOfLastStatement' classVariableNames: '' poolDictionaries: '' category: 'Compiler-ParseNodes'! !BlockNode commentStamp: '' prior: 0! 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: 'accessing' stamp: 'eem 8/31/2010 12:31'! arguments ^arguments ifNil: [#()]! ! !BlockNode methodsFor: 'accessing'! arguments: argNodes "Decompile." arguments := argNodes! ! !BlockNode methodsFor: 'accessing' stamp: 'tk 8/4/1999 22:53'! block ^ self! ! !BlockNode methodsFor: 'accessing' stamp: 'eem 8/22/2008 10:01'! closureCreationNode closureCreationNode ifNil: [closureCreationNode := LeafNode new key: #closureCreationNode code: nil]. ^closureCreationNode! ! !BlockNode methodsFor: 'accessing'! firstArgument ^ arguments first! ! !BlockNode methodsFor: 'accessing' stamp: 'eem 5/30/2008 12:12'! nArgsSlot "Private for the Encoder to use in bindArg" ^nArgsNode! ! !BlockNode methodsFor: 'accessing' stamp: 'eem 5/30/2008 12:12'! nArgsSlot: anInteger "Private for the Encoder to use in bindArg" nArgsNode := anInteger! ! !BlockNode methodsFor: 'accessing'! numberOfArguments ^arguments size! ! !BlockNode methodsFor: 'accessing' stamp: 'eem 7/24/2008 12:37'! optimized ^optimized! ! !BlockNode methodsFor: 'accessing'! returnLast self returns ifFalse: [returns := true. statements at: statements size put: statements last asReturnNode]! ! !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: '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: 'accessing' stamp: 'eem 8/4/2008 10:48'! startOfLastStatement ^startOfLastStatement! ! !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 8/31/2010 12:30'! temporaries ^temporaries ifNil: [#()]! ! !BlockNode methodsFor: 'accessing' stamp: 'sma 2/27/2000 22:37'! temporaries: aCollection temporaries := aCollection! ! !BlockNode methodsFor: 'code generation'! code ^statements first code! ! !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: '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: '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' 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' 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' stamp: 'eem 5/14/2008 14:52'! sizeCodeForEvaluatedValue: encoder ^(self sizeCodeExceptLast: encoder) + (statements last sizeCodeForBlockValue: encoder)! ! !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: '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: '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: 'nice 3/1/2010 23:14'! addTempNode: aTempVariableNode "Utilities for when we want to add some temporaries." self makeTemporariesRemovable. ^temporaries add: aTempVariableNode! ! !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 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 5/20/2008 12:16'! blockExtent "^" ^blockExtent! ! !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: '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: 'code generation (closures)' stamp: 'eem 2/3/2011 09:19'! deoptimize optimized := false. optimizedMessageNode := nil! ! !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: '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: '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: '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: '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: 'code generation (closures)' stamp: 'eem 5/19/2008 17:12'! noteOptimized optimized := true! ! !BlockNode methodsFor: 'code generation (closures)' stamp: 'eem 9/6/2009 13:30'! noteOptimizedIn: anOptimizedMessageNode optimized := true. optimizedMessageNode := anOptimizedMessageNode! ! !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 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: '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 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 (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: '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: '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: 'equation translation'! statements ^statements! ! !BlockNode methodsFor: 'equation translation'! statements: val statements := val! ! !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: '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: '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: '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: '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: '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: '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: '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: 'eem 6/2/2008 12:06'! printWithClosureAnalysisArgumentsOn: aStream indent: level arguments size = 0 ifTrue: [^self]. arguments do: [:tempNode | aStream space; nextPut: $:. tempNode printDefinitionForClosureAnalysisOn: aStream]. aStream nextPut: $|; space. "If >0 args and >1 statement, put all statements on separate lines" statements size > 1 ifTrue: [aStream crtab: level]! ! !BlockNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:53'! printWithClosureAnalysisOn: aStream indent: level aStream nextPut: $[. blockExtent ifNotNil: [aStream print: blockExtent]. self printWithClosureAnalysisArgumentsOn: aStream indent: level. self printWithClosureAnalysisTemporariesOn: aStream indent: level. self printWithClosureAnalysisStatementsOn: aStream indent: level. aStream nextPut: $]! ! !BlockNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:48'! printWithClosureAnalysisStatementsOn: 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: [(len = 1 and: [((statements at: 1) == NodeNil) & (arguments size = 0)]) ifTrue: [shown := shown - 1]]. 1 to: shown do: [:i | thisStatement := statements at: i. thisStatement printWithClosureAnalysisOn: 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: 'printing' stamp: 'eem 6/2/2008 11:54'! printWithClosureAnalysisTemporariesOn: aStream indent: level (temporaries == nil or: [temporaries size = 0]) ifFalse: [aStream nextPut: $|. temporaries do: [:tempNode | aStream space. tempNode printDefinitionForClosureAnalysisOn: aStream]. aStream nextPutAll: ' | '. "If >0 args and >1 statement, put all statements on separate lines" statements size > 1 ifTrue: [aStream crtab: level]]! ! !BlockNode methodsFor: 'testing' stamp: 'eem 9/25/2008 12:10'! isBlockNode ^true! ! !BlockNode methodsFor: 'testing'! isComplex ^statements size > 1 or: [statements size = 1 and: [statements first isComplex]]! ! !BlockNode methodsFor: 'testing'! isJust: node returns ifTrue: [^false]. ^statements size = 1 and: [statements first == node]! ! !BlockNode methodsFor: 'testing'! isJustCaseError ^ statements size = 1 and: [statements first isMessage: #caseError receiver: [:r | r==NodeSelf] arguments: nil]! ! !BlockNode methodsFor: 'testing'! isQuick ^ statements size = 1 and: [statements first isVariableReference or: [statements first isSpecialConstant]]! ! !BlockNode methodsFor: 'testing'! returns ^returns or: [statements last isReturningIf]! ! !BlockNode methodsFor: 'visiting' stamp: 'eem 9/6/2009 12:33'! accept: aVisitor ^aVisitor visitBlockNode: self! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BlockNode class instanceVariableNames: ''! !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! ! InstructionClient subclass: #BlockStartLocator instanceVariableNames: 'nextJumpIsAroundBlock' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Methods'! !BlockStartLocator methodsFor: 'initialize-release' stamp: 'alain.plantec 5/28/2009 09:43'! initialize super initialize. nextJumpIsAroundBlock := false! ! !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]! ! !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 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."! ! UITheme subclass: #BlueUITheme instanceVariableNames: 'windowActiveDropShadowStyle' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Themes'! !BlueUITheme commentStamp: 'TudorGirba 1/30/2011 22:51' prior: 0! 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. ! !BlueUITheme methodsFor: 'accessing' stamp: 'TudorGirba 4/7/2011 23:46'! windowActiveDropShadowStyle: anObject "Set the value of windowActiveDropShadowStyle" windowActiveDropShadowStyle := anObject! ! !BlueUITheme 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"! ! !BlueUITheme 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]]! ! !BlueUITheme methodsFor: 'basic-colors' stamp: 'TudorGirba 4/8/2011 00:02'! treeLineWidth "Answer the width of the tree lines." ^0! ! !BlueUITheme methodsFor: 'border-styles' stamp: 'TudorGirba 1/13/2011 23:06'! configureWindowBorderFor: aWindow " super configureWindowBorderFor: aWindow. aWindow roundedCorners: #()" | aStyle | aStyle := SimpleBorder new color: (Color black alpha: 0.5); width: 1. aWindow borderStyle: aStyle.! ! !BlueUITheme methodsFor: 'border-styles' stamp: 'TudorGirba 1/13/2011 22:59'! configureWindowDropShadowFor: aWindow aWindow hasDropShadow: false! ! !BlueUITheme methodsFor: 'border-styles' stamp: 'tg 9/4/2010 22:55'! dropListNormalBorderStyleFor: aDropList "Return the normal borderStyle for the given drop list" ^ self buttonNormalBorderStyleFor: aDropList! ! !BlueUITheme 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))! ! !BlueUITheme 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! ! !BlueUITheme methodsFor: 'border-styles' stamp: 'tg 8/31/2010 15:28'! tabLabelNormalBorderStyleFor: aTabLabel " ^SimpleBorder new width: 0; baseColor: (self buttonBaseColorFor: aTabLabel) darker " ^ self buttonNormalBorderStyleFor: aTabLabel! ! !BlueUITheme methodsFor: 'border-styles' stamp: 'StephaneDucasse 4/11/2011 22:31'! tabPanelBorderStyleFor: aTabGroup ^ ExtendedTabPanelBorder new width: 1; baseColor: ((self glamorousDarkBaseColorFor: aTabGroup)); tabSelector: aTabGroup tabSelectorMorph! ! !BlueUITheme methodsFor: 'border-styles' stamp: 'tg 9/4/2010 20:23'! taskbarThumbnailCornerStyleFor: aMorph "Answer the corner style for the taskbar thumbnail/tasklist." ^#square! ! !BlueUITheme methodsFor: 'border-styles' stamp: 'tg 9/4/2010 20:56'! taskbarThumbnailNormalBorderStyleFor: aWindow ^ self buttonNormalBorderStyleFor: aWindow! ! !BlueUITheme 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! ! !BlueUITheme methodsFor: 'border-styles-buttons' stamp: 'tg 9/4/2010 23:06'! buttonCornerStyleIn: aThemedMorph "If asked, we only allow square corners" ^ #square! ! !BlueUITheme methodsFor: 'border-styles-buttons' stamp: 'tg 9/9/2010 22:43'! 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! ! !BlueUITheme 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! ! !BlueUITheme methodsFor: 'defaults' stamp: 'tg 9/6/2010 14:04'! buttonMinHeight "Answer the minumum height of a button for this theme." ^24! ! !BlueUITheme methodsFor: 'defaults' stamp: 'tg 9/6/2010 14:04'! buttonMinWidth "Answer the minumum width of a button for this theme." ^24! ! !BlueUITheme methodsFor: 'fill-styles' stamp: 'tg 9/3/2010 12:30'! dockingBarNormalFillStyleFor: aToolDockingBar ^ SolidFillStyle color: Color transparent! ! !BlueUITheme methodsFor: 'fill-styles' stamp: 'tg 9/5/2010 20:47'! dropListDisabledFillStyleFor: aDropList "Return the disabled fillStyle for the given drop list." ^ self textEditorDisabledFillStyleFor: aDropList! ! !BlueUITheme 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! ! !BlueUITheme 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! ! !BlueUITheme methodsFor: 'fill-styles' stamp: 'tg 9/5/2010 20:48'! listDisabledFillStyleFor: aList "Return the disabled fillStyle for the given list." ^ self textEditorDisabledFillStyleFor: aList! ! !BlueUITheme methodsFor: 'fill-styles' stamp: 'tg 9/5/2010 20:51'! progressBarFillStyleFor: aProgressBar ^ self glamorousBasePassiveBackgroundColorFor: aProgressBar! ! !BlueUITheme methodsFor: 'fill-styles' stamp: 'tg 9/7/2010 13:52'! progressBarProgressFillStyleFor: aProgressBar ^ (self glamorousLightSelectionColorFor: aProgressBar)! ! !BlueUITheme 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! ! !BlueUITheme 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! ! !BlueUITheme methodsFor: 'fill-styles' stamp: 'tg 9/5/2010 20:48'! sliderDisabledFillStyleFor: aSlider "Return the disabled fillStyle for the given slider." ^ self textEditorDisabledFillStyleFor: aSlider! ! !BlueUITheme 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! ! !BlueUITheme methodsFor: 'fill-styles' stamp: 'tg 9/5/2010 20:41'! 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! ! !BlueUITheme methodsFor: 'fill-styles' stamp: 'tg 8/31/2010 12:51'! taskbarFillStyleFor: aTaskbar ^ self buttonNormalFillStyleFor: aTaskbar! ! !BlueUITheme methodsFor: 'fill-styles' stamp: 'tg 9/5/2010 20:46'! textEditorDisabledFillStyleFor: aTextEditor "Return the disabled fillStyle for the given text editor." ^self glamorousBasePassiveBackgroundColorFor: aTextEditor! ! !BlueUITheme methodsFor: 'fill-styles' stamp: 'tg 9/13/2010 10:41'! windowActiveFillStyleFor: aWindow "We do not want the lighting effect when the window goes inactive" ^SolidFillStyle color: self class baseColor! ! !BlueUITheme methodsFor: 'fill-styles' stamp: 'TudorGirba 4/7/2011 23:53'! windowActiveTitleFillStyleFor: aWindow ^ "self glamorousNormalFillStyleFor: aWindow height: aWindow labelHeight" self windowActiveFillStyleFor: aWindow ! ! !BlueUITheme 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! ! !BlueUITheme 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! ! !BlueUITheme 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! ! !BlueUITheme 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! ! !BlueUITheme methodsFor: 'fill-styles-buttons' stamp: 'tg 8/31/2010 11:13'! tabLabelNormalFillStyleFor: aTabLabel ^ self buttonNormalFillStyleFor: aTabLabel ! ! !BlueUITheme methodsFor: 'fill-styles-buttons' stamp: 'tg 8/31/2010 11:13'! tabLabelSelectedFillStyleFor: aTabLabel ^ self buttonSelectedFillStyleFor: aTabLabel ! ! !BlueUITheme 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! ! !BlueUITheme methodsFor: 'fill-styles-scrollbars' stamp: 'tg 9/13/2010 10:50'! 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])! ! !BlueUITheme methodsFor: 'forms' stamp: 'FernandoOlivero 10/28/2010 09:08'! checkboxForm "Answer the form to use for a normal checkbox." ^self checkboxUnselectedForm! ! !BlueUITheme methodsFor: 'forms' stamp: 'FernandoOlivero 10/28/2010 14:10'! checkboxSelectedForm "Answer the form to use for a selected checkbox." ^BlueUIThemeIcons checkboxSelectedForm! ! !BlueUITheme methodsFor: 'forms' stamp: 'FernandoOlivero 10/28/2010 13:54'! checkboxUnselectedForm "Answer the form to use for a selected checkbox." ^ BlueUIThemeIcons checkboxUnselectedForm! ! !BlueUITheme methodsFor: 'forms' stamp: 'FernandoOlivero 10/28/2010 09:09'! menuPinForm "Answer the form to use for the pin button of a menu." ^ BlueUIThemeIcons menuPinForm! ! !BlueUITheme methodsFor: 'forms' stamp: 'FernandoOlivero 10/28/2010 09:09'! newCheckboxMarkerForm "Answer a new checkbox marker form." ^BlueUIThemeIcons checkboxMarkerForm! ! !BlueUITheme methodsFor: 'forms' stamp: 'FernandoOlivero 10/28/2010 09:46'! 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." ^BlueUIThemeIcons radioButtonMarkerForm ! ! !BlueUITheme methodsFor: 'forms' stamp: 'FernandoOlivero 10/28/2010 13:05'! newWindowCloseForm "Answer a new form for a window close box." ^ BlueUIThemeIcons windowCloseForm ! ! !BlueUITheme methodsFor: 'forms' stamp: 'FernandoOlivero 10/28/2010 14:18'! newWindowCloseOverForm "Answer a new form for a window menu box." ^ self newWindowCloseForm! ! !BlueUITheme methodsFor: 'forms' stamp: 'FernandoOlivero 10/28/2010 13:06'! newWindowMaximizeForm "Answer a new form for a window maximize box." ^ BlueUIThemeIcons windowMaximizeForm! ! !BlueUITheme methodsFor: 'forms' stamp: 'FernandoOlivero 10/28/2010 14:18'! newWindowMaximizeOverForm "Answer a new form for a window menu box." ^ self newWindowMaximizeForm! ! !BlueUITheme methodsFor: 'forms' stamp: 'FernandoOlivero 10/28/2010 13:08'! newWindowMenuForm "Answer a new form for a window menu box." ^ BlueUIThemeIcons windowMenuForm! ! !BlueUITheme methodsFor: 'forms' stamp: 'FernandoOlivero 10/28/2010 13:15'! newWindowMenuPassiveForm "Answer a new form for a window menu box." ^ BlueUIThemeIcons windowMenuInactiveForm! ! !BlueUITheme methodsFor: 'forms' stamp: 'FernandoOlivero 10/28/2010 13:10'! newWindowMinimizeForm "Answer a new form for a window minimize box." ^ BlueUIThemeIcons windowMinimizeForm! ! !BlueUITheme methodsFor: 'forms' stamp: 'FernandoOlivero 10/28/2010 15:09'! newWindowMinimizeOverForm "Answer a new form for a window menu box." ^ self newWindowMinimizeForm! ! !BlueUITheme methodsFor: 'forms' stamp: 'FernandoOlivero 10/28/2010 14:11'! radioButtonForm "Answer the form to use for a normal radio button." ^ BlueUIThemeIcons radioButtonUnselectedForm! ! !BlueUITheme methodsFor: 'forms' stamp: 'FernandoOlivero 10/28/2010 14:11'! radioButtonSelectedForm "Answer the form to use for a selected radio button." ^ BlueUIThemeIcons radioButtonSelectedForm ! ! !BlueUITheme methodsFor: 'forms' stamp: 'FernandoOlivero 10/28/2010 13:17'! windowClosePassiveForm "Answer the form to use for passive (background) window close buttons" ^BlueUIThemeIcons windowCloseInactiveForm! ! !BlueUITheme methodsFor: 'forms' stamp: 'FernandoOlivero 10/28/2010 13:18'! windowMaximizePassiveForm "Answer the form to use for passive (background) window maximize/restore buttons" ^BlueUIThemeIcons windowMaximizeInactiveForm! ! !BlueUITheme methodsFor: 'forms' stamp: 'FernandoOlivero 10/28/2010 13:18'! windowMinimizePassiveForm "Answer the form to use for passive (background) window minimize buttons" ^BlueUIThemeIcons windowMinimizeInactiveForm! ! !BlueUITheme methodsFor: 'initialize-release' stamp: 'tg 8/31/2010 13:51'! initialize "self beCurrent" super initialize. self windowActiveDropShadowStyle: #nodiffuse! ! !BlueUITheme 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! ! !BlueUITheme methodsFor: 'initialize-release' stamp: 'tg 9/6/2010 14:38'! newRadioMarkerForm "Answer a new checkbox marker form." ^Form extent: 12@12 depth: 32! ! !BlueUITheme 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)! ! !BlueUITheme 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)! ! !BlueUITheme 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)! ! !BlueUITheme 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]! ! !BlueUITheme 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)! ! !BlueUITheme 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! ! !BlueUITheme 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! ! !BlueUITheme 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! ! !BlueUITheme 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]! ! !BlueUITheme 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]! ! !BlueUITheme methodsFor: 'label-styles' stamp: 'tg 9/3/2010 10:52'! windowMenuPassiveForm "Answer the form to use for passive (background) window menu buttons" ^self newWindowMenuPassiveForm! ! !BlueUITheme 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]! ! !BlueUITheme 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! ! !BlueUITheme 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! ! !BlueUITheme 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]"! ! !BlueUITheme methodsFor: 'private' stamp: 'tg 9/5/2010 20:40'! glamorousBasePassiveBackgroundColorFor: aButton ^ self class basePassiveBackgroundColor! ! !BlueUITheme methodsFor: 'private' stamp: 'tg 9/5/2010 20:40'! glamorousBaseSelectionColorFor: aButton ^ self class baseSelectionColor! ! !BlueUITheme methodsFor: 'private' stamp: 'tg 9/9/2010 22:50'! glamorousDarkBaseColorFor: aButton ^ self class darkBaseColor! ! !BlueUITheme methodsFor: 'private' stamp: 'tg 9/9/2010 22:02'! glamorousLightColorFor: aButton ^ self class lightBaseColor! ! !BlueUITheme methodsFor: 'private' stamp: 'tg 9/5/2010 21:44'! glamorousLightSelectionColorFor: aMorph ^ self class lightSelectionColor! ! !BlueUITheme methodsFor: 'private' stamp: 'tg 9/13/2010 10:49'! 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 ! ! !BlueUITheme methodsFor: 'private' stamp: 'tg 9/13/2010 10:49'! glamorousNormalFillStyleWithBaseColor: aColor for: aMorph height: anInteger | top bottom | top := aColor twiceLighter. bottom := aColor. ^(GradientFillStyle ramp: { 0.0->top. 0.7->bottom.}) origin: aMorph bounds origin; direction: 0 @ anInteger; radial: false! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BlueUITheme class instanceVariableNames: ''! !BlueUITheme class methodsFor: 'accessing' stamp: 'TudorGirba 4/8/2011 01:03'! baseColor ^ (Color r: 190 g: 190 b: 190 range: 255)! ! !BlueUITheme class methodsFor: 'accessing' stamp: 'tg 9/5/2010 20:50'! basePassiveBackgroundColor ^ Color r: 245 g: 245 b: 245 range: 255! ! !BlueUITheme class methodsFor: 'accessing' stamp: 'tg 9/5/2010 21:46'! baseSelectionColor ^ Color r: 97 g: 163 b: 225 range: 255! ! !BlueUITheme class methodsFor: 'accessing' stamp: 'tg 9/9/2010 22:43'! darkBaseColor ^ Color r: 180 g: 180 b: 180 range: 255! ! !BlueUITheme class methodsFor: 'accessing' stamp: 'tg 9/9/2010 22:37'! lightBaseColor ^ Color r: 200 g: 200 b: 200 range: 255! ! !BlueUITheme class methodsFor: 'accessing' stamp: 'tg 9/7/2010 13:51'! lightSelectionColor ^ Color r: 175 g: 213 b: 250 range: 255! ! !BlueUITheme class methodsFor: 'accessing' stamp: 'StephaneDucasse 4/11/2011 22:28'! themeName ^ 'Blue Pharo'! ! !BlueUITheme class methodsFor: 'accessing' stamp: 'tg 9/7/2010 13:51'! veryLightSelectionColor ^ Color r: 218 g: 234 b: 250 range: 255! ! !BlueUITheme class methodsFor: 'settings' stamp: 'tg 9/7/2010 13:47'! newDefaultSettings 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; flatMenu: true! ! !BlueUITheme class methodsFor: 'settings' stamp: 'MarcusDenker 4/12/2011 09:53'! setPreferredShoutColors "self setPreferredShoutColors" Smalltalk globals at: #SHTextStylerST80 ifPresent: [:cls | cls 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)))] ! ! !BlueUITheme class methodsFor: 'settings' stamp: 'TudorGirba 4/8/2011 00:13'! setPreferredWorldBackground "self setPreferredWorldBackground" World color: Color white! ! !BlueUITheme class methodsFor: 'testing' stamp: 'TudorGirba 4/7/2011 23:45'! isAbstract "Answer whether the receiver is considered to be abstract." ^false! ! !BlueUITheme class methodsFor: 'private' stamp: 'tg 11/5/2010 20:50'! 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: BlueUIThemeIcons category: '*glamour-morphic-theme'! ! !BlueUITheme 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! ! PharoUIThemeIcons subclass: #BlueUIThemeIcons instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Themes'! Object subclass: #Boolean instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Objects'! !Boolean commentStamp: '' prior: 0! 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: '*Fuel' stamp: 'MartinDias 2/21/2013 12:49'! fuelAccept: aGeneralMapper ^aGeneralMapper visitHookPrimitive: self! ! !Boolean methodsFor: '*Fuel' stamp: 'MartinDias 2/21/2013 12:49'! serializeOn: anEncoder "Do nothing"! ! !Boolean methodsFor: '*NativeBoost-Core' stamp: 'Igor.Stasenko 4/28/2010 12:19'! 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 ifTrue: [1] ifFalse:[0])! ! !Boolean methodsFor: '*compatibility' stamp: 'SeanDeNigris 8/31/2011 14:20'! and: block1 and: block2 "Nonevaluating conjunction without deep nesting. The receiver is evaluated, followed by the blocks in order. If any of these evaluates as false, then return false immediately, without evaluating any further blocks. If all return true, then return true." self deprecated: 'use and:' on: '27 June 2010' in: 'Pharo1.2'. self ifFalse: [ ^ false ]. block1 value ifFalse: [ ^ false ]. block2 value ifFalse: [ ^ false ]. ^ true! ! !Boolean methodsFor: '*compatibility' stamp: 'SeanDeNigris 8/31/2011 14:20'! and: block1 and: block2 and: block3 "Nonevaluating conjunction without deep nesting. The receiver is evaluated, followed by the blocks in order. If any of these evaluates as false, then return false immediately, without evaluating any further blocks. If all return true, then return true." self deprecated: 'Use and: instead' on: '27 April 2010' in: 'Pharo1.2'. self ifFalse: [ ^ false ]. block1 value ifFalse: [ ^ false ]. block2 value ifFalse: [ ^ false ]. block3 value ifFalse: [ ^ false ]. ^ true! ! !Boolean methodsFor: '*compatibility' stamp: 'SeanDeNigris 8/31/2011 14:20'! and: block1 and: block2 and: block3 and: block4 "Nonevaluating conjunction without deep nesting. The receiver is evaluated, followed by the blocks in order. If any of these evaluates as false, then return false immediately, without evaluating any further blocks. If all return true, then return true." self deprecated: 'Use and: instead' on: '26 May 2010' in: 'Pharo1.2'. self ifFalse: [ ^ false ]. block1 value ifFalse: [ ^ false ]. block2 value ifFalse: [ ^ false ]. block3 value ifFalse: [ ^ false ]. block4 value ifFalse: [ ^ false ]. ^ true! ! !Boolean methodsFor: '*compatibility' stamp: 'SeanDeNigris 8/31/2011 14:20'! or: block1 or: block2 "Nonevaluating alternation without deep nesting. The receiver is evaluated, followed by the blocks in order. If any of these evaluates as true, then return true immediately, without evaluating any further blocks. If all return false, then return false." self deprecated: 'use a or:[b or:[c]] instead' on: '5 February 2010' in: 'Pharo1.2'. self ifTrue: [ ^ true ]. block1 value ifTrue: [ ^ true ]. block2 value ifTrue: [ ^ true ]. ^ false! ! !Boolean methodsFor: '*compatibility' stamp: 'SeanDeNigris 8/31/2011 14:20'! or: block1 or: block2 or: block3 "Nonevaluating alternation without deep nesting. The receiver is evaluated, followed by the blocks in order. If any of these evaluates as true, then return true immediately, without evaluating any further blocks. If all return false, then return false." self deprecated: 'use a or:[b or:[c or:[d]]] instead' on: '5 February 2010' in: 'Pharo1.2'. self ifTrue: [ ^ true ]. block1 value ifTrue: [ ^ true ]. block2 value ifTrue: [ ^ true ]. block3 value ifTrue: [ ^ true ]. ^ false! ! !Boolean methodsFor: '*compatibility' stamp: 'SeanDeNigris 8/31/2011 14:20'! or: block1 or: block2 or: block3 or: block4 "Nonevaluating alternation without deep nesting. The receiver is evaluated, followed by the blocks in order. If any of these evaluates as true, then return true immediately, without evaluating any further blocks. If all return false, then return false." self deprecated: 'use a or:[b or:[c or:[d or:[e]]]] instead' on: '5 February 2010' in: 'Pharo1.2'. self ifTrue: [ ^ true ]. block1 value ifTrue: [ ^ true ]. block2 value ifTrue: [ ^ true ]. block3 value ifTrue: [ ^ true ]. block4 value ifTrue: [ ^ true ]. ^ false! ! !Boolean methodsFor: 'controlling'! 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: 'controlling'! 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: 'controlling'! ifFalse: falseAlternativeBlock ifTrue: trueAlternativeBlock "Same as ifTrue:ifFalse:." self subclassResponsibility! ! !Boolean methodsFor: 'controlling'! 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'! 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: 'controlling'! 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: '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: 'copying'! deepCopy "Receiver has two concrete subclasses, True and False. Only one instance of each should be made, so return self."! ! !Boolean methodsFor: 'copying'! shallowCopy "Receiver has two concrete subclasses, True and False. Only one instance of each should be made, so return self."! ! !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: 'logical operations'! & aBoolean "Evaluating conjunction. Evaluate the argument. Then answer true if both the receiver and the argument are true." self subclassResponsibility! ! !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: 'logical operations'! eqv: aBoolean "Answer true if the receiver is equivalent to aBoolean." ^self == aBoolean! ! !Boolean methodsFor: 'logical operations'! not "Negation. Answer true if the receiver is false, answer false if the receiver is true." self subclassResponsibility! ! !Boolean methodsFor: 'logical operations'! | aBoolean "Evaluating disjunction (OR). Evaluate the argument. Then answer true if either the receiver or the argument is true." self subclassResponsibility! ! !Boolean methodsFor: 'printing' stamp: 'apb 4/21/2006 09:22'! isLiteral ^ true! ! !Boolean methodsFor: 'printing'! storeOn: aStream "Refer to the comment in Object|storeOn:." self printOn: aStream! ! !Boolean methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 21:45'! isSelfEvaluating ^ true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Boolean class instanceVariableNames: ''! !Boolean class methodsFor: '*System-Settings-Browser' stamp: 'alain.plantec 3/18/2009 14:48'! settingInputWidgetForNode: aSettingNode ^ aSettingNode inputWidgetForBoolean! ! !Boolean class methodsFor: 'instance creation'! new self error: 'You may not create any more Booleans - this is two-valued logic'! ! AbstractApiSetter subclass: #BooleanApiSetter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Spec-Tools-Editor'! !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! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BooleanApiSetter class instanceVariableNames: ''! !BooleanApiSetter class methodsFor: 'as yet unclassified' stamp: 'BenjaminVanRyseghem 7/11/2012 17:30'! spec ^ SpecLayout composed newRow: [:r | r add: #selector; newColumn: [:c | c add: #choice ] width: 75] height: 25; yourself! ! ClassTestCase subclass: #BooleanTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Objects'! !BooleanTest commentStamp: '' prior: 0! 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'! 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. ! ! !BooleanTest methodsFor: 'tests' stamp: 'StephaneDucasse 6/9/2012 22:43'! testNew self should: [Boolean new] raise: self classForTestResult error. ! ! Object subclass: #BorderStyle instanceVariableNames: '' classVariableNames: 'Default' poolDictionaries: '' category: 'Morphic-Borders'! !BorderStyle commentStamp: 'kfr 10/27/2003 10:19' prior: 0! See BorderedMorph BorderedMorh new borderStyle: (BorderStyle inset width: 2); openInWorld.! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 18:15'! baseColor ^Color transparent! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 18:15'! baseColor: aColor "Ignored"! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:07'! color ^Color transparent! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:07'! color: aColor "Ignored"! ! !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 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 methodsFor: 'accessing' stamp: 'ar 8/25/2001 17:51'! style ^#none! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:07'! width ^0! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:07'! width: aNumber "Ignored"! ! !BorderStyle methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:08'! widthForRounding ^self width! ! !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: '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: '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: '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: '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: '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: '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: '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: 'initialize' stamp: 'ar 8/25/2001 16:06'! releaseCachedState "Release any associated cached state"! ! !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: 'printing' stamp: 'gvc 2/25/2009 15:34'! storeOn: aStream "Store a reconstructable representation of the receiver on the given stream." aStream nextPutAll: '(' , self class name; nextPutAll: ' width: '; print: self width; nextPutAll: ' color: '; print: self color; nextPutAll: ')'! ! !BorderStyle methodsFor: 'testing' stamp: 'gvc 6/25/2008 12:09'! hasFillStyle "Answer false." ^false! ! !BorderStyle methodsFor: 'testing' stamp: 'ar 8/25/2001 16:08'! isBorderStyle ^true! ! !BorderStyle methodsFor: 'testing' stamp: 'ar 8/26/2001 19:30'! isComplex ^false! ! !BorderStyle methodsFor: 'testing' stamp: 'gvc 3/14/2007 10:31'! isComposite "Answer false." ^false! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BorderStyle class instanceVariableNames: ''! !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: '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: '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! ! !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 11/26/2001 15:01'! complexAltInset ^ComplexBorder style: #complexAltInset! ! !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:00'! complexFramed ^ComplexBorder style: #complexFramed! ! !BorderStyle class methodsFor: 'instance creation' stamp: 'ar 11/26/2001 15:00'! complexInset ^ComplexBorder style: #complexInset! ! !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 17:26'! default ^Default ifNil:[Default := self new]! ! !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 14:59'! raised ^RaisedBorder new! ! !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: 'rr 6/21/2005 13:50'! thinGray ^ self width: 1 color: Color gray! ! !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: 'ar 8/25/2001 16:19'! width: aNumber color: aColor ^SimpleBorder new color: aColor; width: aNumber; yourself! ! Morph subclass: #BorderedMorph instanceVariableNames: 'borderWidth borderColor' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Kernel'! !BorderedMorph commentStamp: 'kfr 10/27/2003 11:17' prior: 0! 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: '*Polymorph-Widgets' 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: 'accessing' stamp: 'sw 8/6/97 14:34'! borderColor ^ borderColor! ! !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: 'accessing' stamp: 'di 6/20/97 11:24'! borderInset self borderColor: #inset! ! !BorderedMorph methodsFor: 'accessing' stamp: 'di 6/20/97 11:25'! borderRaised self borderColor: #raised! ! !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: '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: 'di 6/20/97 11:09'! borderWidth ^ borderWidth! ! !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: '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: 'accessing' stamp: 'di 1/3/1999 12:24'! hasTranslucentColor "Answer true if this any of this morph is translucent but not transparent." (color isColor and: [color isTranslucentColor]) ifTrue: [^ true]. (borderColor isColor and: [borderColor isTranslucentColor]) ifTrue: [^ true]. ^ false ! ! !BorderedMorph methodsFor: 'accessing' stamp: 'sw 11/29/1999 17:36'! useRoundedCorners self cornerStyle: #rounded! ! !BorderedMorph methodsFor: 'accessing' stamp: 'sw 11/29/1999 17:37'! useSquareCorners self cornerStyle: #square! ! !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: '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: 'geometry' stamp: 'nk 4/5/2001 14:23'! intersectionWithLineSegmentFromCenterTo: aPoint "account for round corners. Still has a couple of glitches at upper left and right corners" | pt | pt := super intersectionWithLineSegmentFromCenterTo: 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: 'initialization' stamp: 'dgd 3/7/2003 15:53'! borderInitialize "initialize the receiver state related to border" borderColor:= self defaultBorderColor. borderWidth := self defaultBorderWidth! ! !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: 'initialization' stamp: 'dgd 2/14/2003 22:36'! defaultBorderWidth "answer the default border width for the receiver" ^ 2! ! !BorderedMorph methodsFor: 'initialization' stamp: 'MarcusDenker 12/11/2009 23:56'! initialize "initialize the state of the receiver" super initialize. self borderInitialize! ! !BorderedMorph methodsFor: 'lookenhancements' stamp: 'kfr 11/5/2006 21:36'! 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: 'IgorStasenko 12/19/2012 17:13'! addPaneHSplitterBetween: topMorph and: bottomMorphs | targetY minX maxX splitter | Halt now. "Hello, anybody here? is there anyone using this?" self flag: #toRemove. targetY := topMorph layoutFrame bottomFraction. minX := (bottomMorphs detectMin: [:each | each layoutFrame leftFraction]) layoutFrame leftFraction. maxX := (bottomMorphs detectMax: [:each | each layoutFrame rightFraction]) layoutFrame rightFraction. splitter := ProportionalSplitterMorph new beSplitsTopAndBottom; yourself. splitter layoutFrame: ( (minX @ targetY corner: maxX @ targetY) asLayoutFrame leftOffset: topMorph layoutFrame leftOffset; rightOffset: topMorph layoutFrame rightOffset; bottomOffset: 4 + topMorph layoutFrame bottomOffset; topOffset: topMorph layoutFrame bottomOffset ). self addMorphBack: (splitter position: self position).! ! !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: '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: '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: 'lookenhancements' stamp: 'jrp 7/23/2005 00:03'! removeCornerGrips | corners | corners := self submorphsSatisfying: [:each | each isKindOf: CornerGripMorph]. corners do: [:each | each delete]! ! !BorderedMorph methodsFor: 'lookenhancements' stamp: 'jrp 7/23/2005 22:28'! removePaneSplitters self splitters do: [:each | each delete]! ! !BorderedMorph methodsFor: 'lookenhancements' stamp: 'jrp 7/23/2005 22:16'! splitters ^ self submorphsSatisfying: [:each | each isKindOf: ProportionalSplitterMorph]! ! !BorderedMorph methodsFor: 'menu' stamp: 'StephaneDucasse 2/25/2011 18:34'! addBorderStyleMenuItems: aMenu hand: aHandMorph "Add border-style menu items" | subMenu | subMenu := UIManager default newMenuIn: self for: self. subMenu addStayUpItemSpecial. subMenu addList: {{'border color...' translated. #changeBorderColor:}. {'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: 'menu' stamp: 'dik 6/28/2010 00:41'! changeBorderColor: evt UIManager default chooseColor: self borderColor for: [:newColor | self borderColor: newColor]! ! !BorderedMorph methodsFor: 'menu' stamp: 'AlainPlantec 12/1/2010 09:38'! changeBorderWidth: evt | aHand origin oldWidth handle newWidth | aHand := evt ifNil: [self primaryHand] ifNotNil: [evt hand]. origin := aHand position. oldWidth := borderWidth. 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 class instanceVariableNames: ''! !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.! ! CornerGripMorph subclass: #BottomLeftGripMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Windows'! !BottomLeftGripMorph commentStamp: 'jmv 1/29/2006 17:17' prior: 0! I am the handle in the left bottom of windows used for resizing them.! !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]! ! !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: 'accessing' stamp: 'md 2/24/2006 22:43'! ptName ^#bottomLeft! ! !BottomLeftGripMorph methodsFor: 'accessing' stamp: 'jmv 1/29/2006 17:52'! resizeCursor ^ Cursor resizeForEdge: #bottomLeft! ! !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: '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))! ! CornerGripMorph subclass: #BottomRightGripMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Windows'! !BottomRightGripMorph commentStamp: 'jmv 1/29/2006 17:18' prior: 0! I am the handle in the right bottom of windows used for resizing them.! !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]! ! !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: 'accessing' stamp: 'md 2/24/2006 22:43'! ptName ^#bottomRight! ! !BottomRightGripMorph methodsFor: 'accessing' stamp: 'jmv 1/29/2006 17:51'! resizeCursor ^ Cursor resizeForEdge: #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)! ! GradientFillStyle subclass: #BoundedGradientFillStyle instanceVariableNames: 'extent' classVariableNames: '' poolDictionaries: '' category: 'Balloon-Fills'! !BoundedGradientFillStyle commentStamp: 'gvc 3/13/2009 12:19' prior: 0! 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: 'accessing' stamp: 'gvc 3/13/2009 12:22'! extent: anObject "Set the value of extent" extent := anObject! ! !BoundedGradientFillStyle methodsFor: 'as yet unclassified' stamp: 'gvc 3/13/2009 12:39'! = aGradientFillStyle "Answer whether equal." ^super = aGradientFillStyle and: [self extent = aGradientFillStyle extent]! ! !BoundedGradientFillStyle methodsFor: 'as yet unclassified' 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! ! !BoundedGradientFillStyle methodsFor: 'as yet unclassified' stamp: 'gvc 3/13/2009 12:39'! hash "Hash is implemented because #= is implemented." ^super hash bitXor: self extent hash! ! ParseNode subclass: #BraceNode instanceVariableNames: 'elements sourceLocations emitNode' classVariableNames: '' poolDictionaries: '' category: 'Compiler-ParseNodes'! !BraceNode commentStamp: '' prior: 0! 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: '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: '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: '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: '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/21/2008 10:40'! elements ^elements! ! !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: 'enumerating'! 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: 'enumerating'! 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'! elements: collection "Decompile." elements := collection! ! !BraceNode methodsFor: 'initialize-release'! elements: collection sourceLocations: locations "Compile." elements := collection. sourceLocations := locations! ! !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: '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: '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 methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! printWithClosureAnalysisOn: aStream indent: level aStream nextPut: ${. 1 to: elements size do: [:i | (elements at: i) printWithClosureAnalysisOn: aStream indent: level. i < elements size ifTrue: [aStream nextPutAll: '. ']]. aStream nextPut: $}! ! !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: 'testing'! numElements ^ elements size! ! !BraceNode methodsFor: 'visiting' stamp: 'eem 9/6/2009 12:33'! accept: aVisitor ^aVisitor visitBraceNode: self! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BraceNode class instanceVariableNames: ''! !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 )" ! ! Morph subclass: #BracketMorph instanceVariableNames: 'orientation' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !BracketMorph commentStamp: 'gvc 5/18/2007 13:48' prior: 0! Morph displaying opposing arrows.! !BracketMorph methodsFor: 'accessing' stamp: 'gvc 9/21/2006 15:48'! horizontal "Answer whether horizontal or vertical." ^self orientation == #horizontal! ! !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: 'accessing' stamp: 'gvc 9/19/2006 15:51'! orientation "Answer the value of orientation" ^ orientation! ! !BracketMorph methodsFor: 'accessing' stamp: 'gvc 9/19/2006 15:52'! orientation: anObject "Set the value of orientation" orientation := anObject. self changed! ! !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: '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: '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: 'initialization' stamp: 'gvc 9/19/2006 15:52'! initialize "Initialize the receiver." super initialize. self orientation: #horizontal! ! PluggableSliderMorph subclass: #BracketSliderMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !BracketSliderMorph commentStamp: 'gvc 5/18/2007 13:39' prior: 0! Abstract superclass for morphs that are used to select a component (R, G, B or A) of a colour.! !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: 'access' stamp: 'gvc 9/19/2006 15:43'! sliderShadowColor "Answer the color for the slider shadow." ^Color black alpha: 0.6! ! !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: 'geometry' stamp: 'gvc 9/3/2009 13:40'! extent: aPoint "Update the gradient directions." super extent: aPoint. self updateFillStyle! ! !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))]! ! !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: '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: '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: '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: 'protocol' stamp: 'gvc 9/3/2009 13:40'! defaultFillStyle "Answer the defauolt fill style." ^Color gray! ! !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])]! ! FileSystemGuide subclass: #BreadthFirstGuide instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Core-Implementation'! !BreadthFirstGuide commentStamp: 'cwp 11/18/2009 12:13' prior: 0! 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 8/12/2011 18:23'! show: aReference self push: aReference entry. self whileNotDoneDo: [ self visitNextEntry: self top ]! ! !BreadthFirstGuide methodsFor: 'showing' stamp: 'CamilloBruni 8/12/2011 18:19'! visitNextEntry: entry entry isFile ifTrue: [ ^ visitor visitFile: entry ]. visitor visitDirectory: entry. self pushAll: entry reference entries.! ! GuideTest subclass: #BreadthFirstGuideTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Tests-Core'! !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' )! ! Halt subclass: #BreakPoint instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tools-Debugger'! !BreakPoint commentStamp: 'md 11/18/2003 09:32' prior: 0! This exception is raised on executing a breakpoint. "BreakPoint signal" is called from "Object>>break".! Object subclass: #BreakpointManager instanceVariableNames: '' classVariableNames: 'Installed' poolDictionaries: '' category: 'Tools-Debugger'! !BreakpointManager commentStamp: 'md 10/9/2008 20:17' prior: 0! 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 instanceVariableNames: ''! !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: 'nice 4/10/2008 22:00'! 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 isNil ifTrue: [^ nil]. self installed at: breakMethod put: aClass >> aSymbol. "old method" aClass basicAddSelector: aSymbol withMethod: breakMethod.! ! !BreakpointManager class methodsFor: 'install-uninstall' stamp: 'md 2/15/2006 21:25'! unInstall: breakMethod | class selector oldMethod | oldMethod := self installed at: breakMethod ifAbsent:[^self]. class := breakMethod methodClass. selector := breakMethod selector. (class>>selector) == breakMethod ifTrue:[ class methodDictionary at: selector put: oldMethod]. self installed removeKey: breakMethod! ! !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: 'testing' stamp: 'emm 5/30/2002 09:22'! methodHasBreakpoint: aMethod ^self installed includesKey: aMethod! ! !BreakpointManager class methodsFor: 'private' stamp: 'emm 5/30/2002 09:36'! 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 | oldSource := aClass sourceCodeAt: aSymbol. methodNode := aClass compilerClass new compile: oldSource in: aClass notifying: nil ifFail: [self error: '[breakpoint] unable to install breakpoint']. breakOnlyMethodNode := aClass compilerClass new compile: 'temporaryMethodSelectorForBreakpoint self break. ^self' in: aClass notifying: nil ifFail: [self error: '[breakpoint] unable to install breakpoint']. sendBreakMessageNode := breakOnlyMethodNode block statements first. methodNode block statements addFirst: sendBreakMessageNode. ^methodNode printString ! ! !BreakpointManager class methodsFor: 'private' stamp: 'md 10/9/2008 20:14'! compilePrototype: aSymbol in: aClass "Compile and return a new method containing a break statement" | source node method | source := self breakpointMethodSourceFor: aSymbol in: aClass. node := aClass compilerClass new compile: source in: aClass notifying: nil ifFail: [self error: '[breakpoint] unable to install breakpoint']. node isNil ifTrue: [^nil]. method := node generate: (aClass>>aSymbol) trailer. ^method! ! !BreakpointManager class methodsFor: 'private' stamp: 'emm 4/24/2002 23:24'! installed Installed isNil ifTrue:[Installed := IdentityDictionary new]. ^Installed! ! CodeHolder subclass: #Browser instanceVariableNames: 'systemOrganizer classOrganizer metaClassOrganizer systemCategoryListIndex classListIndex messageCategoryListIndex messageListIndex editSelection metaClassIndicated' classVariableNames: 'RecentClasses' poolDictionaries: '' category: 'Tools-Browser'! !Browser commentStamp: '' prior: 0! I represent a query path into the class descriptions, the software of the system.! !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: '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: '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: '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: '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: 'accessing'! editSelection ^editSelection! ! !Browser methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:26'! editSelection: aSelection "Set the editSelection as requested." editSelection := aSelection. self changed: #editSelection.! ! !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: 'accessing' stamp: 'rbb 3/1/2005 10:26'! request: prompt initialAnswer: initialAnswer ^ UIManager default request: prompt initialAnswer: initialAnswer ! ! !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: '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: '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: '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: '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: '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: '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: '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: '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: 'class functions' stamp: 'AlainPlantec 9/23/2011 12:25'! 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 := [ClassBuilder new 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: '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: 'class functions' stamp: 'MarcusDenker 3/26/2010 16:48'! 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 evaluate: defString notifying: aController logged: true. (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: '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: '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: '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: '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: '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: '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: '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: '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: '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: 'class functions' stamp: 'AlainPlantec 9/23/2011 12:25'! 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 := [ClassBuilder new 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: '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: 'class list'! 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: 'class list'! classListIndex "Answer the index of the current class selection." ^classListIndex! ! !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: 'class list' stamp: 'StephaneDucasse 5/28/2011 13:31'! 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: [ ^ Beeper beep ]. 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: 'class list' stamp: 'sr 10/29/1999 20:28'! selectClass: classNotMeta self classListIndex: (self classList indexOf: classNotMeta name)! ! !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: '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: 'code pane' stamp: 'AlainPlantec 1/7/2010 21:06'! codePaneMenu: aMenu shifted: shifted super codePaneMenu: aMenu shifted: shifted. ^ aMenu! ! !Browser methodsFor: 'code pane' stamp: 'sd 11/20/2005 21:26'! 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 = ClassOrganizer allCategory 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: '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: '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: '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: '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: '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: 'drag and drop' stamp: 'sd 11/20/2005 21:26'! changeCategoryForClass: class srcSystemCategory: srcSystemCategorySel atListMorph: dstListMorph internal: internal copy: copyFlag "only move semantic" | newClassCategory success | self flag: #stringSymbolProblem. success := copyFlag not ifFalse: [^ 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: 'drag and drop' stamp: 'nk 4/22/2004 18:00'! 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 == ClassOrganizer allCategory 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: '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: '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: 'panda 4/28/2000 16:18'! dragTransferTypeForMorph: dragSource ^(dragSource isKindOf: PluggableListMorph) ifTrue: [dragSource getListSelector]! ! !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: 'drag and drop' stamp: 'sd 11/20/2005 21:26'! dstMessageCategoryDstListMorph: dstListMorph | dropItem | ^dstListMorph getListSelector == #messageCategoryList ifTrue: [dropItem := dstListMorph potentialDropItem. dropItem ifNotNil: [dropItem asSymbol]] ifFalse: [self selectedMessageCategoryName ifNil: [ Categorizer default ]]! ! !Browser methodsFor: 'drag and drop' stamp: 'sd 11/20/2005 21:26'! 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 not ifTrue: ["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: '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: '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: '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: '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: 'initialization' stamp: 'rr 6/21/2005 13:24'! addMorphicSwitchesTo: window at: aLayoutFrame window addMorph: self buildMorphicSwitches fullFrame: aLayoutFrame. ! ! !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: '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: '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: '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: '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: '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: 'initialization' stamp: 'sw 1/13/2000 16:45'! defaultBrowserTitle ^ 'System Browser'! ! !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: 'initialization' stamp: 'sw 9/22/1999 17:13'! methodCategoryChanged self changed: #messageCategoryList. self changed: #messageList. self changed: #annotation. self messageListIndex: 0! ! !Browser methodsFor: 'initialization' stamp: 'StephaneDucasse 12/19/2012 16:23'! 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) topOffset: switchHeight). window setUpdatablePanesFrom: #(messageCategoryList messageList). ^ window! ! !Browser methodsFor: 'initialization' stamp: 'MarcusDenker 11/2/2012 15:04'! 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. "The method SystemWindow>>addMorph:fullFrame: checks scrollBarsOnRight, then adds the morph at the back if true, otherwise it is added in front. But flopout hScrollbars need the lowerpanes to be behind the upper ones in the draw order. Hence the value of scrollBarsOnRight affects the order in which the lowerpanes are added. " window theme settings scrollBarsOnRight ifFalse: [self addLowerPanesTo: window at: (0@hSepFrac corner: 1@1) with: editString]. 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). window theme settings scrollBarsOnRight ifTrue: [self addLowerPanesTo: window at: (0@hSepFrac corner: 1@1) with: editString]. window setUpdatablePanesFrom: #(systemCategoryList classList messageCategoryList messageList). ^ window! ! !Browser methodsFor: 'initialization' stamp: 'IgorStasenko 12/20/2012 14:39'! openAsMorphMessageEditing: editString "Create a pluggable version a Browser that shows just one message" | window mySingletonMessageList verticalOffset nominalFractions | window := (SystemWindow labelled: 'later') model: self. mySingletonMessageList := PluggableListMorph on: self list: #messageListSingleton selected: #indexIsOne changeSelected: #indexIsOne: menu: #messageListMenu:shifted: keystroke: #messageListKey:from:. mySingletonMessageList enableDragNDrop: true. verticalOffset := 25. nominalFractions := 0@0 corner: 1@0. window addMorph: mySingletonMessageList fullFrame: ( nominalFractions asLayoutFrame bottomOffset: verticalOffset). verticalOffset := self addOptionalAnnotationsTo: window at: nominalFractions plus: verticalOffset. verticalOffset := self addOptionalButtonsTo: window at: nominalFractions plus: verticalOffset. window addMorph: (self buildMorphicCodePaneWith: editString) fullFrame: (LayoutFrame identity topOffset: verticalOffset ). ^ window! ! !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: '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: '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: '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: 'alain.plantec 5/30/2008 10:08'! openMessageEditString: aString "Create a pluggable version of the views for a Browser that just shows one message." ^ self openAsMorphMessageEditing: aString! ! !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: '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: '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: '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: 'initialization' stamp: 'sw 11/8/1999 13:36'! systemCatSingletonKey: aChar from: aView ^ self messageListKey: aChar from: aView! ! !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: 'message category functions' stamp: 'MarcusDenker 10/28/2010 13:51'! 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: ClassOrganizer nullCategory; add: ClassOrganizer default. 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 asSortedCollection. 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: '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: 'message category functions'! 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: '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: 'message category functions' stamp: 'sd 11/20/2005 21:26'! categoryOfCurrentMethod "Determine the method category associated with the receiver at the current moment, or nil if none" | aCategory | ^ super categoryOfCurrentMethod ifNil: [(aCategory := self messageCategoryListSelection) == ClassOrganizer allCategory ifTrue: [nil] ifFalse: [aCategory]]! ! !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 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: '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: '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: 'message category functions' stamp: 'nk 4/23/2004 09:18'! removeEmptyCategories self okToChange ifFalse: [^ self]. self selectedClassOrMetaClass organization removeEmptyCategories. self changed: #messageCategoryList ! ! !Browser methodsFor: 'message category functions' stamp: 'sd 9/17/2011 17:52'! 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 removeCategory: messageCategoryName. self messageCategoryListIndex: 0. self changed: #classSelectionChanged]. self changed: #messageCategoryList. ! ! !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 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: 'message category list' stamp: 'sd 11/20/2005 21:26'! 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: ClassOrganizer default) do: [:sel | | found | found := (organizers collect: [ :org | org categoryOfElement: sel]) detect: [:ea | ea ~= ClassOrganizer default and: [ ea ~= nil]] ifNone: []. found ifNotNil: [organizer classify: sel under: found]]. self changed: #messageCategoryList! ! !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: '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: 'message category list'! messageCategoryListIndex "Answer the index of the selected message category." ^messageCategoryListIndex! ! !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 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: 'message category list' stamp: 'nice 1/5/2010 15:59'! 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 ~= ClassOrganizer default and: [thisCat notNil]) ifTrue: [self classOrMetaClassOrganizer classify: sel under: thisCat. self changed: #messageCategoryList. ^ true]]. ^ false! ! !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: 'message category list' stamp: 'sd 11/20/2005 21:26'! 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 ~= ClassOrganizer allCategory]) 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: 'message category list'! selectedMessageCategoryName "Answer the name of the selected message category, if any. Answer nil otherwise." messageCategoryListIndex = 0 ifTrue: [^nil]. ^self messageCategoryList at: messageCategoryListIndex! ! !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: '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: 'message functions' stamp: 'lr 7/3/2009 20:59'! 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 = ClassOrganizer 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: '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: '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: '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: 'message functions' stamp: 'StephaneDucasse 5/28/2011 13:44'! 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 browseAllCallsOn: messageName]! ! !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: 'message functions' stamp: 'MarcusDenker 10/13/2012 18:05'! 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: #( - ('Copy up or copy down...' copyUpOrCopyDown) - ('More...' unshiftedYellowButtonActivity)). ^ aMenu ! ! !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: 'message list'! messageListIndex "Answer the index of the selected message selector into the currently selected message category." ^messageListIndex! ! !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: 'message list' stamp: 'sd 11/20/2005 21:26'! messageListSingleton | name | name := self selectedMessageName. ^ name ifNil: [Array new] ifNotNil: [Array with: name]! ! !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: 'message list' stamp: 'md 2/20/2006 15:01'! selectedMessage "Answer a copy of the source code for the selected message." | class selector method | contents == nil ifFalse: [^ contents copy]. self showingDecompile ifTrue: [^ self decompiledSourceIntoContents]. class := self selectedClassOrMetaClass. selector := self selectedMessageName. method := class compiledMethodAt: selector ifAbsent: [^ '']. "method deleted while in another project" currentCompiledMethod := method. ^ contents := (self showingDocumentation ifFalse: [ self sourceStringPrettifiedAndDiffed ] ifTrue: [ self commentContents ]) copy asText makeSelectorBoldIn: class! ! !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: '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: 'metaclass' stamp: 'di 1/14/98 12:25'! classCommentIndicated "Answer true iff we're viewing the class comment." ^ editSelection == #editComment ! ! !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: '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: '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: '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: '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: '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: '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: '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: 'metaclass'! selectedClassOrMetaClassName "Answer the selected class name or metaclass name." ^self selectedClassOrMetaClass name! ! !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: '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 functions' stamp: 'brp 8/4/2003 21:38'! alphabetizeSystemCategories self okToChange ifFalse: [^ false]. systemOrganizer sortCategories. self systemCategoryListIndex: 0. self changed: #systemCategoryList. ! ! !Browser methodsFor: 'system category functions'! buildSystemCategoryBrowser "Create and schedule a new system category browser." self buildSystemCategoryBrowserEditString: nil! ! !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: '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: 'system category functions' stamp: 'tk 4/2/98 13:43'! classNotFound self changed: #flash.! ! !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 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: 'system category functions' stamp: 'BenjaminVanRyseghem 6/26/2012 23:52'! findClass "Search for a class from a pattern or from the recent list" | pattern foundClassOrTrait recentList | self okToChange ifFalse: [^ self classNotFound]. recentList := RecentClasses select: [ :n | Smalltalk globals includesKey: n ]. foundClassOrTrait := SearchFacade classSearch chooseFromOwner: self dependents first. foundClassOrTrait ifNil: [^ self classNotFound]. self selectCategoryForClass: foundClassOrTrait. self selectClass: foundClassOrTrait ! ! !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: '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: '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: '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: '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: 'system category list' stamp: 'tk 5/4/1998 15:46'! indexIsOne "When used as a singleton list, index is always one" ^ 1! ! !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: 'system category list' stamp: 'stp 01/13/2000 12:25'! selectCategoryForClass: theClass self systemCategoryListIndex: (self systemCategoryList indexOf: theClass category) ! ! !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: 'system category list'! selectedSystemCategoryName "Answer the name of the selected system category or nil." systemCategoryListIndex = 0 ifTrue: [^nil]. ^self systemCategoryList at: systemCategoryListIndex! ! !Browser methodsFor: 'system category list'! systemCategoryList "Answer the class categories modelled by the receiver." ^systemOrganizer categories! ! !Browser methodsFor: 'system category list'! systemCategoryListIndex "Answer the index of the selected class category." ^systemCategoryListIndex! ! !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: '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: '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: 'traits' stamp: 'jb 7/1/2011 10:40'! 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 evaluatorClass evaluate: defString notifying: aController logged: true. ^(trait isKindOf: TraitBehavior) ifTrue: [ self changed: #classList. self classListIndex: (self classList indexOf: trait baseTrait name). self clearUserEditFlag; editClass. true] ifFalse: [ false ] ! ! !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: 'traits' stamp: 'al 4/24/2004 11:48'! newTrait self classListIndex: 0. self editClass. editSelection := #newTrait. self contentsChanged! ! !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: '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: 'user interface' stamp: 'hpt 9/30/2004 20:51'! addModelItemsToWindowMenu: aMenu "Add model-related items to the window menu" super addModelItemsToWindowMenu: aMenu. SystemBrowser addRegistryMenuItemsTo: aMenu inAccountOf: self.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Browser class instanceVariableNames: ''! !Browser class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'FernandoOlivero 4/12/2011 09:49'! taskbarIcon "Answer the icon for the receiver in a task bar." ^ self theme smallSystemBrowserIcon! ! !Browser class methodsFor: 'cleanup' stamp: 'MarcusDenker 4/17/2011 21:46'! cleanUp self flushCaches.! ! !Browser class methodsFor: 'groups registration' stamp: 'BenjaminVanRyseghem 1/30/2012 16:45'! addGroupForClasses: aCollection named: aName " Nautilus adds this method for compatibility even if Browser can't manage groups "! ! !Browser class methodsFor: 'groups registration' stamp: 'BenjaminVanRyseghem 1/30/2012 16:45'! addGroupForPackage: aPackage " Nautilus adds this method for compatibility even if Browser can't manage groups "! ! !Browser class methodsFor: 'initialization' stamp: 'MarcusDenker 4/17/2011 21:46'! flushCaches RecentClasses := OrderedCollection new.! ! !Browser class methodsFor: 'initialization' stamp: 'MarcusDenker 4/17/2011 21:46'! initialize "Browser initialize" self flushCaches. self registerInAppRegistry ! ! !Browser class methodsFor: 'initialization' stamp: 'hpt 8/5/2004 19:41'! registerInAppRegistry "Register the receiver in the SystemBrowser AppRegistry" SystemBrowser register: self.! ! !Browser class methodsFor: 'initialization' stamp: 'AlainPlantec 10/17/2009 16:42'! unload "Unload the receiver from global registries" SystemBrowser unregister: self.! ! !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: 'sd 11/20/2005 21:28'! fullOnClass: aClass selector: aSelector "Open a new full browser set to class." | brow classToUse | classToUse := SystemBrowser default. brow := classToUse new. brow setClass: aClass selector: aSelector. ^ classToUse openBrowserView: (brow openEditString: nil) label: brow labelString! ! !Browser class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 2/8/2013 16:14'! fullOnClass: class selector: selector highlight: autoSelectString self fullOnClass: class selector: selector! ! !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: 'di 10/18/1999 22:03'! new ^super new systemOrganizer: SystemOrganization! ! !Browser class methodsFor: 'instance creation' stamp: 'CamilloBruni 8/1/2012 16:12'! newOnCategory: aCategory "Browse the system category of the given name." "Browser newOnCategory: 'Interface-Browser'" | newBrowser catList | newBrowser := self new. catList := newBrowser systemCategoryList. newBrowser systemCategoryListIndex: (catList indexOf: aCategory asSymbol ifAbsent: [^ self inform: 'No such category']). ^ self openBrowserView: (newBrowser openSystemCatEditString: nil) label: 'Classes in category ', aCategory ! ! !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: '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: '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: 'instance creation' stamp: 'md 3/10/2006 21:46'! open ^self openBrowser ! ! !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: '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: 'nk 6/2/2004 12:55'! systemOrganizer: anOrganizer ^(super new) systemOrganizer: anOrganizer; yourself! ! !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 ! ! PluggableTextMorph subclass: #BrowserCommentTextMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tools-Browser'! !BrowserCommentTextMorph commentStamp: '' prior: 0! 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: 'displaying' stamp: 'IgorStasenko 12/19/2012 17:23'! defaultLayoutFrame ^ (0@0.75 corner: 1@1) asLayoutFrame. ! ! !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: '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: 'initialize-release' stamp: 'AlainPlantec 8/26/2011 17:53'! initialize super initialize. self styled: false ! ! !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: []). ! ! !BrowserCommentTextMorph methodsFor: 'updating' stamp: 'AlainPlantec 8/26/2011 19:08'! update: anAspect super update: anAspect. anAspect == #editSelection ifFalse: [ ^self ]. self hideOrShowPane! ! Object subclass: #BrowserSystemSettings instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Settings-Tools'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BrowserSystemSettings class instanceVariableNames: ''! !BrowserSystemSettings class methodsFor: 'settings' stamp: 'AlainPlantec 5/31/2010 09:23'! defaultBrowserSettingOn: aBuilder (aBuilder pickOne: #defaultBrowser) order: -1; parent: #codeBrowsing; target: SystemBrowser; getSelector: #default; setSelector: #default:; label: 'Default browser' translated; domainValues: SystemBrowser registeredClasses! ! GenericUrl subclass: #BrowserUrl instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Network-Url'! !BrowserUrl commentStamp: '' prior: 0! URLs that instruct a browser to do something.! !BrowserUrl methodsFor: 'downloading' stamp: 'ls 8/4/1998 20:42'! hasContents ^true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BrowserUrl class instanceVariableNames: ''! !BrowserUrl class methodsFor: 'constants' stamp: 'SeanDeNigris 1/29/2011 19:33'! schemeName ^ 'browser'! ! AbstractTool subclass: #BuilderManifest instanceVariableNames: 'manifestClass' classVariableNames: '' poolDictionaries: '' category: 'Manifest-Core'! !BuilderManifest commentStamp: '' prior: 0! A ManifestBuilder is used to create, read and write a Manifest Instance Variables manifestClass: manifestClass - xxxxx ! !BuilderManifest methodsFor: 'accessing'! manifest ^ manifestClass! ! !BuilderManifest methodsFor: 'accessing' stamp: 'SimonAllier 8/21/2012 14:52'! manifestClass: aClass manifestClass := aClass ! ! !BuilderManifest methodsFor: 'accessing' stamp: 'SimonAllier 1/30/2013 16:46'! manifestOf: elem | packageName | packageName := self packageNameOf: elem. manifestClass := self class allManifestClasses detect: [:each | each category = packageName ] ifNone: [ nil ]. ^ manifestClass ! ! !BuilderManifest methodsFor: 'adding/removing' stamp: 'SimonAllier 8/1/2012 15:10'! addAllFalsePositive: fp of: ruleId version: versionId | selector | selector := self selectorFalsePositiveOf: ruleId version: versionId. self addAllItem: fp selector: selector. (self containsToDo: fp onRule: ruleId version: versionId) ifTrue: [self removeToDo: fp of: ruleId version: versionId]. ! ! !BuilderManifest methodsFor: 'adding/removing' stamp: 'SimonAllier 2/8/2013 13:33'! addAllToDo: aSet of: ruleId version: versionId | selector | selector := self selectorToDoOf: ruleId version: versionId. self addAllItem: aSet selector: selector. ! ! !BuilderManifest methodsFor: 'adding/removing' stamp: 'SimonAllier 8/1/2012 15:14'! addFalsePositive: fp of: ruleId version: versionId | selector | selector := self selectorFalsePositiveOf: ruleId version: versionId. self addItem: fp selector: selector. (self containsToDo: fp onRule: ruleId version: versionId) ifTrue: [self removeToDo: fp of: ruleId version: versionId]. ! ! !BuilderManifest methodsFor: 'adding/removing' stamp: 'SimonAllier 8/1/2012 13:31'! addFalsePositive: fp withComment: aString of: ruleId version: versionId | selector | selector := self selectorFalsePositiveOf: ruleId version: versionId. self addItem: fp wihtComment: aString selector: selector. (self containsToDo: fp onRule: ruleId version: versionId) ifTrue: [self removeToDo: fp of: ruleId version: versionId]. ! ! !BuilderManifest methodsFor: 'adding/removing' stamp: 'SimonAllier 7/26/2012 16:03'! addRejectClass: aClass | falsePositives | falsePositives := manifestClass rejectClasses asOrderedCollection . ((self unwrap: falsePositives) anySatisfy: [:each | each = aClass]) ifTrue:[ ^ self]. falsePositives add: {aClass asRingDefinition arrayStringForManifest. DateAndTime current asString}.. manifestClass class compile: (self class rejectClassesTag, Character cr asString, '^ ', (self buildArrayString: falsePositives)) classified: 'meta data' ! ! !BuilderManifest methodsFor: 'adding/removing'! addRejectRule: ruleId | nfp | nfp := manifestClass rejectRules asSet. nfp add: ruleId. nfp := nfp asArray. manifestClass class compile: (self class rejectRulesTag, Character cr asString, '^ ', nfp asString) classified: 'meta data' ! ! !BuilderManifest methodsFor: 'adding/removing' stamp: 'SimonAllier 8/1/2012 15:14'! addToDo: fp of: ruleId version: versionId | selector | selector := self selectorToDoOf: ruleId version: versionId. self addItem: fp selector: selector. (self containsFalsePositive: fp onRule: ruleId version: versionId) ifTrue: [self removeFalsePositive: fp of: ruleId version: versionId ]! ! !BuilderManifest methodsFor: 'adding/removing' stamp: 'SimonAllier 8/1/2012 13:31'! addToDo: fp withComment: aString of: ruleId version: versionId | selector | selector := self selectorToDoOf: ruleId version: versionId. self addItem: fp wihtComment: aString selector: selector. (self containsFalsePositive: fp onRule: ruleId version: versionId) ifTrue: [self removeFalsePositive: fp of: ruleId version: versionId ]! ! !BuilderManifest methodsFor: 'adding/removing' stamp: 'SimonAllier 8/1/2012 15:14'! addTruePositive: fp of: ruleId version: versionId | selector | selector := self selectorTruePositiveOf: ruleId version: versionId. self addItem: fp selector: selector. (self containsToDo: fp onRule: ruleId version: versionId) ifTrue: [self removeToDo: fp of: ruleId version: versionId]. (self containsFalsePositive: fp onRule: ruleId version: versionId) ifTrue: [self removeFalsePositive: fp of: ruleId version: versionId ] ! ! !BuilderManifest methodsFor: 'adding/removing' stamp: 'SimonAllier 8/1/2012 15:53'! cleanUp | tagfp | tagfp := self class falsePositiveBeginningTag. manifestClass class methodDict do: [:method | ((method selector asString beginsWith: tagfp) or: [method selector asString beginsWith: tagfp]) ifTrue: [self removeObsoleteFalsePositiveOf: method]] ! ! !BuilderManifest methodsFor: 'adding/removing' stamp: 'SimonAllier 8/1/2012 15:16'! removeAllFalsePositive: aSet of: ruleId version: versionId | selector | selector := self selectorFalsePositiveOf:ruleId version: versionId. self removeAllItem: aSet selector: selector. ! ! !BuilderManifest methodsFor: 'adding/removing' stamp: 'SimonAllier 4/13/2012 17:13'! removeAllManifest self removeClasses: (self class allManifestClasses)! ! !BuilderManifest methodsFor: 'adding/removing' stamp: 'SimonAllier 8/1/2012 15:17'! removeAllToDo: fp of: ruleId version: versionId | selector | selector := self selectorToDoOf:ruleId version: versionId. self removeAllItem: fp selector: selector. ! ! !BuilderManifest methodsFor: 'adding/removing' stamp: 'SimonAllier 8/1/2012 15:17'! removeFalsePositive: fp of: ruleId version: versionId | selector | selector := self selectorFalsePositiveOf:ruleId version: versionId. self removeItem: fp selector: selector. ! ! !BuilderManifest methodsFor: 'adding/removing' stamp: 'SimonAllier 4/13/2012 17:08'! removeManifestOf: aItem ( self manifestOf: aItem ) ifNotNil: [ :manifest | self removeClass: manifest ]! ! !BuilderManifest methodsFor: 'adding/removing' stamp: 'SimonAllier 7/26/2012 16:12'! removeRejectClass: aClass | classes | classes := manifestClass rejectClasses asOrderedCollection . classes := classes reject: [:each | ((Smalltalk at: (each first first)) manifestReadOn: (each first at:2)) = aClass asRingDefinition ]. manifestClass class compile: (self class rejectClassesTag, Character cr asString, '^ ', (self buildArrayString: classes)) classified: 'meta data' ! ! !BuilderManifest methodsFor: 'adding/removing'! removeRejectRule: ruleId | nfp | nfp := manifestClass rejectRules asOrderedCollection. nfp remove: ruleId ifAbsent: [^ self]. nfp := nfp asArray. manifestClass class compile: (self class rejectRulesTag, Character cr asString, '^ ', nfp asString) classified: 'meta data' ! ! !BuilderManifest methodsFor: 'adding/removing' stamp: 'SimonAllier 8/1/2012 15:17'! removeToDo: fp of: ruleId version: versionId | selector | selector := self selectorToDoOf:ruleId version: versionId. self removeItem: fp selector: selector. ! ! !BuilderManifest methodsFor: 'adding/removing' stamp: 'SimonAllier 5/29/2012 11:19'! resetFalsePositiveOf: ruleId version: versionId self installFalsePositiveOf: ruleId version: versionId. ! ! !BuilderManifest methodsFor: 'adding/removing' stamp: 'SimonAllier 5/29/2012 11:21'! resetToDoOf: ruleId version: versionId self installToDoOf: ruleId version: versionId. ! ! !BuilderManifest methodsFor: 'comparing' stamp: 'SimonAllier 5/22/2012 17:10'! = aObject ^ aObject class = self class and: [manifestClass = aObject manifest ]! ! !BuilderManifest methodsFor: 'comparing' stamp: 'SimonAllier 5/23/2012 15:27'! hash self flag: 'fct a revoir'. ^ manifestClass hash! ! !BuilderManifest methodsFor: 'manifest' stamp: 'SimonAllier 7/26/2012 16:13'! commentOfFalsePositive: aItem onRule: ruleId version: versionId | ringobject critic critics| (self hasFalsePositiveOf: ruleId version: versionId) ifFalse: [^ self]. ringobject := aItem asRingDefinition. critics := manifestClass perform: (self selectorFalsePositiveOf: ruleId version: versionId). critic := critics detect: [:each | ((Smalltalk at: (each first first)) manifestReadOn: (each first at:2)) = ringobject ] ifNone: [^ '']. ^ (critic size = 3) ifTrue: [(critic at: 3) asString] ifFalse: [''] ! ! !BuilderManifest methodsFor: 'manifest' stamp: 'SimonAllier 8/1/2012 17:34'! commentOfToDo: aItem onRule: ruleId version: versionId | ringobject critic critics| (self hasToDoOf: ruleId version: versionId) ifFalse: [^ self]. ringobject := aItem asRingDefinition. critics := manifestClass perform: (self selectorToDoOf: ruleId version: versionId). critic := critics detect: [:each | ((Smalltalk at: (each first first)) manifestReadOn: (each first at:2))= ringobject ] ifNone: [^ '']. ^ (critic size = 3) ifTrue: [(critic at: 3) asString] ifFalse: [''] ! ! !BuilderManifest methodsFor: 'manifest'! containsFalsePositive: aItem onRule: ruleId version: versionId ^ (self hasFalsePositiveOf: ruleId version: versionId) and: [(self falsePositiveOf: ruleId version: versionId) anySatisfy: [:fp| fp = aItem]] ! ! !BuilderManifest methodsFor: 'manifest'! containsRejectedClass: aClass ^ self rejectClasses anySatisfy: [:cl| cl = aClass]! ! !BuilderManifest methodsFor: 'manifest'! containsRejectedRule: aRuleId ^ self rejectRules anySatisfy: [:fp| fp = aRuleId]! ! !BuilderManifest methodsFor: 'manifest'! containsToDo: aItem onRule: ruleId version: versionId ^ (self hasToDoOf: ruleId version: versionId) and: [(self toDoOf: ruleId version: versionId) anySatisfy: [:fp| fp = aItem]] ! ! !BuilderManifest methodsFor: 'manifest' stamp: 'SimonAllier 3/29/2012 13:01'! containsTruePositive: aItem onRule: ruleId version: versionId ^ (self hasTruePositiveOf: ruleId version: versionId) and: [(self truePositiveOf: ruleId version: versionId) anySatisfy: [:fp| fp = aItem]] ! ! !BuilderManifest methodsFor: 'manifest' stamp: 'SimonAllier 1/31/2013 11:16'! createManifestNamed: packageName manifestClass := Object subclass: (self class manifestTag, packageName onlyLetters) asSymbol instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: packageName. manifestClass class compile: (self class rejectClassesTag, Character cr asString, '^ #()') classified: 'meta data'. manifestClass class compile: (self class rejectRulesTag, Character cr asString, '^ #()') classified: 'meta data'. ^ manifestClass! ! !BuilderManifest methodsFor: 'manifest' stamp: 'SimonAllier 1/30/2013 16:47'! createManifestOf: elem self createManifestNamed: (self packageNameOf: elem).! ! !BuilderManifest methodsFor: 'manifest' stamp: 'SimonAllier 7/26/2012 16:14'! dateOfFalsePositive: aItem onRule: ruleId version: versionId | ringobject dateAndTime critics| (self hasFalsePositiveOf: ruleId version: versionId) ifFalse: [^ self]. ringobject := aItem asRingDefinition. critics := manifestClass perform: (self selectorFalsePositiveOf: ruleId version: versionId). dateAndTime := (critics detect: [:each | ((Smalltalk at: (each first first)) manifestReadOn: (each first at:2)) = ringobject ]) at: 2. ^ dateAndTime asDateAndTime ! ! !BuilderManifest methodsFor: 'manifest' stamp: 'SimonAllier 8/1/2012 17:35'! dateOfToDo: aItem onRule: ruleId version: versionId | ringobject dateAndTime critics| (self hasFalsePositiveOf: ruleId version: versionId) ifFalse: [^ self]. ringobject := aItem asRingDefinition. critics := manifestClass perform: (self selectorToDoOf: ruleId version: versionId). dateAndTime := (critics detect: [:each | ((Smalltalk at: (each first first)) manifestReadOn: (each first at:2)) = ringobject ]) at: 2. ^ dateAndTime asDateAndTime ! ! !BuilderManifest methodsFor: 'manifest' stamp: 'SimonAllier 5/29/2012 14:03'! dateOfTruePositive: aItem onRule: ruleId version: versionId | ringobject dateAndTime critics| (self hasFalsePositiveOf: ruleId version: versionId) ifFalse: [^ self]. ringobject := aItem asRingDefinition. critics := manifestClass perform: (self selectorTruePositiveOf: ruleId version: versionId). dateAndTime := (critics detect: [:each | (Object readFrom: (each first)) = ringobject ]) at: 2. ^ dateAndTime asDateAndTime ! ! !BuilderManifest methodsFor: 'manifest' stamp: 'SimonAllier 5/29/2012 14:41'! falsePositiveOf: ruleId version: versionId ^ self unwrap: ( manifestClass perform: (self selectorFalsePositiveOf: ruleId version: versionId))! ! !BuilderManifest methodsFor: 'manifest'! hasFalsePositiveOf: ruleId version: versionId ^ manifestClass respondsTo: (self selectorFalsePositiveOf: ruleId version: versionId) ! ! !BuilderManifest methodsFor: 'manifest'! hasToDoOf: ruleId version: versionId ^ manifestClass respondsTo: (self selectorToDoOf: ruleId version: versionId) ! ! !BuilderManifest methodsFor: 'manifest'! hasTruePositiveOf: ruleId version: versionId ^ manifestClass respondsTo: (self selectorTruePositiveOf: ruleId version: versionId) ! ! !BuilderManifest methodsFor: 'manifest'! installFalsePositiveOf: ruleId version: versionId "self installFalsePositiveForRule: 1 " manifestClass class compile: ((self selectorFalsePositiveOf: ruleId version: versionId) asString, '^ #()') classified: 'meta data'! ! !BuilderManifest methodsFor: 'manifest'! installToDoOf: ruleId version: versionId manifestClass class compile: ((self selectorToDoOf: ruleId version: versionId) asString, '^ #()') classified: 'meta data'! ! !BuilderManifest methodsFor: 'manifest'! installTruePositiveOf: ruleId version: versionId "self installFalsePositiveForRule: 1 " manifestClass class compile: ((self selectorTruePositiveOf: ruleId version: versionId) asString, '^ #()') classified: 'meta data'! ! !BuilderManifest methodsFor: 'manifest' stamp: 'SimonAllier 1/25/2013 13:32'! isFalsePositive: aItem onRule: ruleId version: versionId | class | class := aItem isCompiledMethod ifTrue: [aItem methodClass] ifFalse: [aItem]. ^ ((self containsFalsePositive: aItem onRule: ruleId version: versionId) or: [(self containsRejectedRule: ruleId) or: [self containsRejectedClass: class]])! ! !BuilderManifest methodsFor: 'manifest'! rejectClasses ^ self unwrap: (manifestClass rejectClasses) ! ! !BuilderManifest methodsFor: 'manifest'! rejectRules ^ (manifestClass respondsTo: #rejectRules) ifTrue: [manifestClass rejectRules] ifFalse: [ #() ] ! ! !BuilderManifest methodsFor: 'manifest' stamp: 'SimonAllier 5/29/2012 14:04'! toDoOf: ruleId version: versionId ^ self unwrap: ( manifestClass perform: (self selectorToDoOf: ruleId version: versionId))! ! !BuilderManifest methodsFor: 'manifest' stamp: 'SimonAllier 5/29/2012 14:04'! truePositiveOf: ruleId version: versionId ^ self unwrap: ( manifestClass perform: (self selectorTruePositiveOf: ruleId version: versionId))! ! !BuilderManifest methodsFor: 'printing' stamp: 'SimonAllier 5/23/2012 15:19'! printOn: aStream aStream nextPutAll: 'ManifestBuilder of '; nextPutAll: manifestClass name! ! !BuilderManifest methodsFor: 'private' stamp: 'SimonAllier 8/1/2012 15:10'! addAllItem: aSet selector: selector | set newSet arrayString | set := (manifestClass perform: selector) asOrderedCollection . newSet := aSet \ (self unwrap: set). newSet isEmpty ifTrue: [^ self]. set addAll: (newSet collect: [:fp | {fp asRingDefinition arrayStringForManifest. DateAndTime current asString}]). arrayString := self buildArrayString: set. manifestClass class compile: (selector asString, Character cr asString, '^ ',arrayString) classified: 'meta data'! ! !BuilderManifest methodsFor: 'private' stamp: 'SimonAllier 8/1/2012 15:14'! addItem: fp selector: selector self addAllItem: {fp} selector: selector! ! !BuilderManifest methodsFor: 'private' stamp: 'SimonAllier 8/1/2012 13:31'! addItem: fp wihtComment: aString selector: selector | set unwrapSet arrayString critic | set := (manifestClass perform: selector) asOrderedCollection . unwrapSet := self unwrap: set. (unwrapSet anySatisfy: [:each | each = fp]) ifTrue:[ critic := set at: (unwrapSet indexOf: fp). set removeIndex: (unwrapSet indexOf: fp). set add: { critic at: 1. critic at: 2. aString}] ifFalse: [set add: {fp asRingDefinition storeString. DateAndTime current asString. aString}]. arrayString := self buildArrayString: set. manifestClass class compile: (selector asString, Character cr asString, '^ ',arrayString) classified: 'meta data'! ! !BuilderManifest methodsFor: 'private' stamp: 'Sd 11/30/2012 16:45'! buildArrayString: aCollection ^ String streamContents: [:stream | stream << '#('. aCollection do: [:each | stream nextPutAll: '#('. stream nextPutAll: each first printString. stream nextPutAll: ' '. stream nextPutAll: (each at: 2) asSymbol printString. (each size = 3) ifTrue: [ stream nextPutAll: ' '. stream nextPutAll: (each at: 3) printString] . stream nextPutAll: ') '.]. stream << ')']! ! !BuilderManifest methodsFor: 'private' stamp: 'SimonAllier 1/22/2013 17:25'! isObsoleteManifest |methodDico| methodDico := manifestClass class methodDictionary. ^methodDico isEmpty or: [methodDico anySatisfy: [:method | |selector| selector := method selector. (#(#rejectClass. #rejectRules) includes: selector) ifTrue: [false] ifFalse: [ (manifestClass perform: selector) anySatisfy: [ :each | (each first first) = (Character value: 40)]]] ]! ! !BuilderManifest methodsFor: 'private' stamp: 'SimonAllier 1/21/2013 14:49'! packageNameOf: elem elem isCompiledMethod ifTrue: [MCWorkingCopy managersForClass: (elem methodClass) selector: (elem selector) do: [: package | ^ package packageName ]] "(RPackageOrganizer default packageOf: elem ) name" ifFalse: [MCWorkingCopy managersForClass: elem do: [: package | ^ package packageName ]] "(RPackageOrganizer default packageDefiningOrExtendingMethod: elem ) name"! ! !BuilderManifest methodsFor: 'private' stamp: 'SimonAllier 8/1/2012 15:16'! removeAllItem: aSet selector: selector | set arrayString | set := (manifestClass perform: selector) asOrderedCollection . set := set reject: [:each | |tmp| tmp := (Smalltalk at: (each first first)) manifestReadOn: (each first at:2). aSet anySatisfy: [:fp | tmp = fp asRingDefinition ]]. arrayString := self buildArrayString: set. manifestClass class compile: (selector asString, Character cr asString, '^ ',arrayString) classified: 'meta data' ! ! !BuilderManifest methodsFor: 'private' stamp: 'SimonAllier 8/1/2012 15:17'! removeItem: fp selector: selector self removeAllItem: {fp} selector: selector! ! !BuilderManifest methodsFor: 'private' stamp: 'SimonAllier 7/26/2012 16:12'! removeObsoleteFalsePositiveOf: aMethod | set arrayString | set := (manifestClass perform: aMethod selector) asOrderedCollection. set := set select: [ :each |((Smalltalk at: (each first first)) manifestReadOn: (each first at:2)) isDefined ]. arrayString := self buildArrayString: set. manifestClass class compile: aMethod selector asString , Character cr asString , '^ ' , arrayString classified: 'meta data'! ! !BuilderManifest methodsFor: 'private' stamp: 'SimonAllier 4/13/2012 17:02'! selectorFalsePositiveOf: ruleId version: versionId ^ (self class falsePositiveBeginningTag, ruleId , self class falsePositiveMiddleTag, versionId asString, self class falsePositiveEndTag) asSymbol.! ! !BuilderManifest methodsFor: 'private' stamp: 'SimonAllier 4/13/2012 17:02'! selectorToDoOf: ruleId version: versionId ^ (self class toDoBeginningTag, ruleId , self class toDoMiddleTag, versionId asString, self class toDoEndTag) asSymbol.! ! !BuilderManifest methodsFor: 'private' stamp: 'SimonAllier 4/13/2012 17:02'! selectorTruePositiveOf: ruleId version: versionId ^ (self class falsePositiveBeginningTag, ruleId , self class falsePositiveMiddleTag, versionId asString, self class truePositiveEndTag) asSymbol.! ! !BuilderManifest methodsFor: 'private' stamp: 'SimonAllier 9/11/2012 15:43'! unwrap: aCollection | unwrapCollection rgobject | unwrapCollection := OrderedCollection new. aCollection do: [ :each | " (each first first) = (Character value: 40) ifFalse: [" rgobject := (Smalltalk at: (each first first)) manifestReadOn: (each first at:2). (rgobject isClass and: [ rgobject realClass notNil ]) ifTrue: [ unwrapCollection add: rgobject realClass ]. (rgobject isMethod and: [ rgobject method notNil ]) ifTrue: [ unwrapCollection add: rgobject method ] ]. ^ unwrapCollection! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! BuilderManifest class instanceVariableNames: ''! !BuilderManifest class methodsFor: 'instance creation' stamp: 'SimonAllier 2/1/2013 11:38'! hasManifestFor: aItem ^ (self new manifestOf: aItem) isNil not ! ! !BuilderManifest class methodsFor: 'instance creation' stamp: 'SimonAllier 2/1/2013 11:34'! hasPackageNamed: aPackageName ^ self allManifestClasses anySatisfy: [:each | each category = aPackageName ] ! ! !BuilderManifest class methodsFor: 'instance creation' stamp: 'SimonAllier 2/1/2013 12:53'! of: aItem | mb | mb := self new. (mb manifestOf: aItem) isNil ifTrue: [mb createManifestOf: aItem] ifFalse: [ mb isObsoleteManifest ifTrue: [ mb manifest theNonMetaClass removeFromSystem. mb createManifestOf: aItem]]. ^ mb ! ! !BuilderManifest class methodsFor: 'instance creation' stamp: 'SimonAllier 2/1/2013 12:53'! ofPackageNamed: aPackageName | mb manifestClass | mb := self new. manifestClass := self allManifestClasses detect: [:each | each category = aPackageName ] ifNone: [ nil ]. manifestClass isNil ifTrue: [mb createManifestNamed: aPackageName ] ifFalse:[ mb manifestClass: manifestClass]. ^ mb ! ! !BuilderManifest class methodsFor: 'utils'! allManifestClasses ^ Smalltalk allClasses select: [:class | class isManifest]! ! !BuilderManifest class methodsFor: 'utils'! falsePositiveBeginningTag "the string that identifies uniquely the beginning of a selector who give the set of false positive for a rule" ^ 'rule'! ! !BuilderManifest class methodsFor: 'utils'! falsePositiveEndTag "the string that identifies uniquely the end of a selector who give the set of false positive for a rule" ^ 'FalsePositive'! ! !BuilderManifest class methodsFor: 'utils'! falsePositiveMiddleTag "the string that identifies uniquely the middle of a selector who give the set of false positive for a rule" ^ 'V'! ! !BuilderManifest class methodsFor: 'utils'! manifestTag "the string that identifies uniquely the beginning of a Manifest class name" ^ 'Manifest'! ! !BuilderManifest class methodsFor: 'utils'! rejectClassesTag "the string that identifies uniquely the beginning of a selector who give the set of rejected classes" ^ 'rejectClasses'! ! !BuilderManifest class methodsFor: 'utils'! rejectRulesTag "the string that identifies uniquely the beginning of a selector who give the set of rejected rules" ^ 'rejectRules'! ! !BuilderManifest class methodsFor: 'utils'! toDoBeginningTag "the string that identifies uniquely the beginning of a selector who give the set of TODO for a rule" ^ 'rule'! ! !BuilderManifest class methodsFor: 'utils'! toDoEndTag "the string that identifies uniquely the end of a selector who give the set of TODO for a rule" ^ 'TODO'! ! !BuilderManifest class methodsFor: 'utils'! toDoMiddleTag "the string that identifies uniquely the middle of a selector who give the set of TODO for a rule" ^ 'V'! ! !BuilderManifest class methodsFor: 'utils'! truePositiveEndTag "the string that identifies uniquely the end of a selector who give the set of false positive for a rule" ^ 'TruePositive'! ! TestCase subclass: #BuilderManifestTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Manifest-Tests'! !BuilderManifestTest commentStamp: '' prior: 0! A ManifestBuilderTest is a class to test the behavior of ManifestBuilder! !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: '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: 'SimonAllier 2/1/2013 16:09'! testAddAllFalsePositive | manifestBuilder array| array := {MFClassA. MFClassB }. manifestBuilder := BuilderManifest 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: 'SimonAllier 2/1/2013 16:09'! testAddAllToDo | manifestBuilder array| array := {MFClassA. MFClassB }. manifestBuilder := BuilderManifest 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: 'SimonAllier 2/1/2013 16:09'! testAddClass | manifestBuilder| manifestBuilder := BuilderManifest 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: 'SimonAllier 2/1/2013 16:09'! testAddFalsePositive | manifestBuilder cl mth| cl := MFClassA. mth := MFClassA >> #method. manifestBuilder := BuilderManifest 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: 'SimonAllier 2/1/2013 16:09'! testAddRule | manifestBuilder| manifestBuilder := BuilderManifest 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: 'SimonAllier 2/1/2013 16:09'! testAddToDo | manifestBuilder cl mth| cl := MFClassA. mth := MFClassA >> #method. manifestBuilder := BuilderManifest 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: 'SimonAllier 2/1/2013 16:10'! testCleanUpFP | manifestBuilder | manifestBuilder := BuilderManifest 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: 'SimonAllier 2/1/2013 16:10'! testCleanUpTD | manifestBuilder | manifestBuilder := BuilderManifest 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: 'SimonAllier 2/1/2013 16:10'! testCommentOfFalsePositive | manifestBuilder comment | comment := 'foo bar'. manifestBuilder := BuilderManifest of: MFClassA . manifestBuilder installFalsePositiveOf: 'test' version: 0. manifestBuilder addFalsePositive: MFClassA of: 'test' version: 0. self assert: (manifestBuilder commentOfFalsePositive: MFClassA onRule: 'test' version: 0) = ''. manifestBuilder addFalsePositive: MFClassA withComment: comment of: 'test' version: 0. self assert: (manifestBuilder commentOfFalsePositive: MFClassA onRule: 'test' version: 0) = comment . ! ! !BuilderManifestTest methodsFor: 'tests' stamp: 'SimonAllier 2/1/2013 16:10'! testContainsFalsePositive | manifestBuilder | manifestBuilder := BuilderManifest 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: 'SimonAllier 2/1/2013 16:10'! testContainsToDo | manifestBuilder | manifestBuilder := BuilderManifest 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: 'SimonAllier 3/26/2012 10:10'! testCreationManifest | manifestBuilder cl | manifestBuilder := BuilderManifest 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: 'tests' stamp: 'SimonAllier 2/1/2013 16:10'! testCreationManifestOn | manifestBuilder cl | manifestBuilder := BuilderManifest new. cl := Smalltalk globals at: #ManifestManifestResourcesTests ifAbsent: [ nil ]. cl ifNotNil: [ cl removeFromChanges; removeFromSystemUnlogged ]. self assert: (manifestBuilder manifestOf: MFClassA ) isNil. self assert: (BuilderManifest of: MFClassA) notNil. self assert: (manifestBuilder manifestOf: MFClassA) notNil! ! !BuilderManifestTest methodsFor: 'tests' stamp: 'SimonAllier 2/1/2013 16:10'! testDateOfFalsePositive | manifestBuilder date1 date2 | manifestBuilder := BuilderManifest 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: 'SimonAllier 2/1/2013 16:10'! testInstallFalsePositive | manifestBuilder | manifestBuilder := BuilderManifest 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: 'SimonAllier 2/1/2013 16:10'! testInstallToDo | manifestBuilder | manifestBuilder := BuilderManifest 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: 'SimonAllier 2/1/2013 16:11'! testIsClassAManifest "self debug: #testIsClassAManifest" self deny: Point isManifest. BuilderManifest of: MFClassA. self assert: ( (Smalltalk at: #ManifestManifestResourcesTests) isManifest)! ! !BuilderManifestTest methodsFor: 'tests' stamp: 'SimonAllier 2/1/2013 16:11'! testIsFalsePositive | manifestBuilder cl mth| cl := MFClassA. mth := cl >> #method. manifestBuilder := BuilderManifest 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: 'SimonAllier 2/1/2013 16:11'! testResetFalsePositive | manifestBuilder array| array := {MFClassA. MFClassB }. manifestBuilder := BuilderManifest 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: 'tests' stamp: 'SimonAllier 2/1/2013 16:11'! testResetToDo | manifestBuilder array| array := {MFClassA. MFClassB }. manifestBuilder := BuilderManifest 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). ! ! AbstractBasicWidget subclass: #ButtonModel instanceVariableNames: 'actionHolder labelHolder stateHolder actionPerformedHolder askBeforeChangingHolder' classVariableNames: '' poolDictionaries: '' category: 'Spec-Widgets'! !ButtonModel commentStamp: '' prior: 0! A ButtonComposableModel is an applicative model which handle a basic button. self example! !ButtonModel methodsFor: 'focus' stamp: 'BenjaminVanRyseghem 2/8/2013 13:20'! eventKeyStrokeForNextFocus "String describing the keystroke to perform to jump to the next widget" ^ Character arrowRight asShortcut! ! !ButtonModel methodsFor: 'focus' stamp: 'BenjaminVanRyseghem 2/8/2013 13:21'! eventKeyStrokeForPreviousFocus "String describing the keystroke to perform to jump to the previous widget" ^ Character arrowLeft asShortcut! ! !ButtonModel methodsFor: 'initialization' stamp: 'EstebanLorenzano 2/18/2013 14:25'! initialize "Initialization code for ButtonComposableModel" super initialize. actionHolder := [] asValueHolder. labelHolder := '' asValueHolder. stateHolder := true asValueHolder. enabledHolder := true asValueHolder. helpHolder := nil asValueHolder. actionPerformedHolder := nil asValueHolder. askBeforeChangingHolder := false asValueHolder. labelHolder whenChangedDo: [ self changed: #label ]. stateHolder whenChangedDo: [ self changed: #state ]. enabledHolder whenChangedDo: [ self changed: #enabled ]. askBeforeChangingHolder whenChangedDo: [:newValue | self widget ifNotNil: [:widget | widget askBeforeChanging: newValue ]]. self on: Character space asShortcut do: [ self action ].! ! !ButtonModel methodsFor: 'morphic' stamp: 'BenjaminVanRyseghem 7/11/2012 17:12'! action self widget ifNotNil: [:m | m takeKeyboardFocus ]. actionHolder contents value. " Here I set a dummy value just to make the holder raise an event " actionPerformedHolder contents: nil.! ! !ButtonModel methodsFor: 'morphic' stamp: 'BenjaminVanRyseghem 7/11/2012 17:17'! label ^ labelHolder contents! ! !ButtonModel methodsFor: 'morphic' stamp: 'BenjaminVanRyseghem 7/11/2012 17:17'! state ^ stateHolder contents! ! !ButtonModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/12/2012 20:21'! action: aBlock "set the block performed when the button is clicked" actionHolder contents: aBlock! ! !ButtonModel methodsFor: 'protocol' stamp: 'EstebanLorenzano 2/18/2013 14:21'! askBeforeChanging ^ askBeforeChangingHolder contents! ! !ButtonModel methodsFor: 'protocol' stamp: 'AndreiChis 2/4/2013 10:53'! askBeforeChanging: aBoolean askBeforeChangingHolder contents: aBoolean! ! !ButtonModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/11/2012 17:16'! getAction "get the block performed when the button is clicked" ^ actionHolder contents! ! !ButtonModel methodsFor: 'protocol' stamp: 'SeanDeNigris 1/28/2013 15:45'! label: aStringOrImageMorph labelHolder contents: aStringOrImageMorph! ! !ButtonModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/12/2012 20:32'! state: aBoolean "set if the button is highlighted" ^ stateHolder contents: aBoolean! ! !ButtonModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/12/2012 20:21'! whenActionChangedDo: aBlock actionHolder whenChangedDo: aBlock! ! !ButtonModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/11/2012 17:12'! whenActionPerformedDo: aBlock "set a block to perform after that the button has been aclicked, and its action performed" actionPerformedHolder whenChangedDo: aBlock! ! !ButtonModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/12/2012 20:23'! whenLabelChangedDo: aBlock "set a block to perform after that the button has been aclicked, and its action performed" labelHolder whenChangedDo: aBlock! ! !ButtonModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/12/2012 20:23'! whenStateChangedDo: aBlock "set a block to perform after that the button has been aclicked, and its action performed" stateHolder whenChangedDo: aBlock! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ButtonModel class instanceVariableNames: ''! !ButtonModel class methodsFor: 'example' stamp: 'BenjaminVanRyseghem 4/24/2012 03:09'! example | b | b:= ButtonModel new. b openWithSpec. b label: 'Click me'.! ! !ButtonModel class methodsFor: 'specs' stamp: 'EstebanLorenzano 2/18/2013 14:23'! defaultSpec ^ {#ButtonSpec. #on:getState:action:label:menu:. #model. #state. #action. #label. #nil. #getEnabledSelector:. #enabled. #hResizing:. #spaceFill. #vResizing:. #spaceFill. #borderWidth:. #(model borderWidth). #borderColor:. #(model borderColor). #askBeforeChanging:. #(model askBeforeChanging). #setBalloonText:. { #model . #help}. #eventHandler:. { #EventHandler. #on:send:to:. #keyStroke. #keyStroke:fromMorph:. #model }}! ! !ButtonModel class methodsFor: 'specs'! title ^ 'Button'! ! TestCase subclass: #ButtonModelTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Spec-Tests'! !ButtonModelTest methodsFor: 'as yet unclassified' stamp: 'EstebanLorenzano 2/18/2013 14:33'! 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 ! ! AbstractSpec subclass: #ButtonSpec instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Spec-Core-Specs'! !ButtonSpec commentStamp: '' prior: 0! A ButtonSpec is a spec used to describe a button! !ButtonSpec methodsFor: 'private' stamp: 'BenjaminVanRyseghem 12/12/2012 15:20'! classSymbol ^ #Button! ! ArrayedCollection variableByteSubclass: #ByteArray instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Arrayed'! !ByteArray commentStamp: '' prior: 0! I represent an ArrayedCollection whose elements are integers between 0 and 255. ! !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: '*Fuel' stamp: 'MartinDias 3/28/2012 16:13'! crc16from: start to: end "Compute a 16 bit cyclic redundancy check on the specified interval." | crc | crc := 0. start to: end do: [:i | crc := (crc bitShift: -8) bitXor: ( #( 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) at: ((crc bitXor: (self byteAt: i)) bitAnd: 16rFF) + 1) ]. ^crc! ! !ByteArray methodsFor: '*Fuel' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^aGeneralMapper visitBytesObject: self! ! !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: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: '*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: '*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: '*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: '*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: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: '*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: '*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: '*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: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: '*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: '*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'! 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: '*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: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 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: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: '*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: '*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: '*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: '*Network-Kernel' stamp: 'mir 6/17/2007 23:12'! asSocketAddress ^SocketAddress fromOldByteAddress: self! ! !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: '*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: '*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: '*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: '*System-Hashing-Core' stamp: 'cmm 2/21/2006 00:05'! destroy 1 to: self size do: [ : x | self at: x put: 0 ]! ! !ByteArray methodsFor: 'accessing' stamp: 'ar 4/12/2005 17:35'! asWideString ^ WideString fromByteArray: self. ! ! !ByteArray methodsFor: 'accessing' stamp: 'sma 4/22/2000 17:47'! atAllPut: value "Fill the receiver with the given value" super atAllPut: value! ! !ByteArray methodsFor: 'accessing' stamp: 'ar 12/5/1998 14:52'! byteAt: index ^self at: index! ! !ByteArray methodsFor: 'accessing' stamp: 'ar 12/5/1998 14:52'! byteAt: index put: value ^self at: index put: value! ! !ByteArray methodsFor: 'accessing' stamp: 'ar 3/3/2001 16:17'! byteSize ^self size! ! !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: '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: 'converting' stamp: 'sma 5/12/2000 17:35'! asByteArray ^ self! ! !ByteArray methodsFor: 'converting'! 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: '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: '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: '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: '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: '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: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: '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/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: '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: '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: '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: '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: '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: '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: 'testing' stamp: 'StephaneDucasse 12/30/2010 14:29'! isLiteral "so that #(1 #[1 2 3] 5) prints itself" "" ^ self class == ByteArray! ! !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: 'private'! defaultElement ^0! ! !ByteArray methodsFor: 'private'! 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 class instanceVariableNames: ''! !ByteArray class methodsFor: '*NativeBoost-Core' stamp: 'IgorStasenko 8/3/2011 19:55'! asNBExternalType: gen ^ NBByteArrayPtr new! ! !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: '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! ! TestCase subclass: #ByteArrayTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Arrayed'! !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: '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 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: '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. ! ! AbstractMethodConverter subclass: #ByteCodeMethodConverter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tools-MethodConverters'! !ByteCodeMethodConverter commentStamp: '' prior: 0! A ByteCodeMessageConverter is a wrapper wich display the bytecode of the provided message! !ByteCodeMethodConverter methodsFor: 'private'! internalGetText ^ method symbolic asText! ! String variableByteSubclass: #ByteString instanceVariableNames: '' classVariableNames: 'NonAsciiMap' poolDictionaries: '' category: 'Collections-Strings'! !ByteString commentStamp: '' prior: 0! This class represents the array of 8 bit wide characters. ! !ByteString methodsFor: '*Fuel' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^aGeneralMapper visitHookPrimitive: self! ! !ByteString methodsFor: '*Fuel' stamp: 'MartinDias 12/30/2011 10:50'! serializeOn: anEncoder anEncoder encodeString: self! ! !ByteString methodsFor: '*Keymapping-Shortcuts' stamp: 'CamilloBruni 3/18/2011 23:17'! asShortcut self size > 1 ifTrue: [ self error: 'Shortcuts only take a single letter']. ^ KMSingleKeyShortcut from: self first! ! !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: '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: '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: 'ar 12/27/1999 13:44'! byteAt: index ^(self at: index) asciiValue! ! !ByteString methodsFor: 'accessing' stamp: 'ar 12/27/1999 13:44'! byteAt: index put: value self at: index put: value asCharacter. ^value! ! !ByteString methodsFor: 'accessing' stamp: 'ar 3/3/2001 16:17'! byteSize ^self size! ! !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: '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: '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: '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: 'comparing' stamp: 'JMM 10/30/2006 15:58'! findSubstring: key in: body startingAt: start matchTable: matchTable key isWideString ifTrue: [^super findSubstring: key in: body startingAt: start matchTable: matchTable]. ^self findSubstringViaPrimitive: key in: body startingAt: start matchTable: matchTable! ! !ByteString methodsFor: 'comparing' stamp: 'HenrikSperreJohansen 10/25/2010 15:32'! findSubstringViaPrimitive: 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. The algorithm below is not optimum -- it is intended to be translated to C which will go so fast that it wont matter." | index | key size = 0 ifTrue: [^ 0]. start to: body size - key size + 1 do: [:startIndex | index := 1. [(matchTable at: (body at: startIndex+index-1) asciiValue + 1) = (matchTable at: (key at: index) asciiValue + 1)] whileTrue: [index = key size ifTrue: [^ startIndex]. index := index+1]]. ^ 0 " ' ' findSubstring: 'abc' in: 'abcdefabcd' startingAt: 1 matchTable: CaseSensitiveOrder 1 ' ' findSubstring: 'abc' in: 'abcdefabcd' startingAt: 2 matchTable: CaseSensitiveOrder 7 ' ' findSubstring: 'abc' in: 'abcdefabcd' startingAt: 8 matchTable: CaseSensitiveOrder 0 ' ' findSubstring: 'abc' in: 'abcdefABcd' startingAt: 2 matchTable: CaseSensitiveOrder 0 ' ' findSubstring: 'abc' in: 'abcdefABcd' startingAt: 2 matchTable: CaseInsensitiveOrder 7 "! ! !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 methodsFor: 'converting' stamp: 'yo 8/28/2002 16:52'! asOctetString ^ self. ! ! !ByteString methodsFor: 'converting' stamp: 'CamilloBruni 9/7/2011 16:11'! convertFromCompoundText | readStream converter | readStream := self readStream. ^ self class new: self size streamContents: [ :writeStream| converter := CompoundTextConverter new. converter ifNil: [^ self]. [readStream atEnd] whileFalse: [ writeStream nextPut: (converter nextFromStream: readStream)]]. ! ! !ByteString methodsFor: 'converting' stamp: 'CamilloBruni 9/7/2011 16:11'! convertFromSystemString | readStream converter | readStream := self readStream. ^ self class new: self size streamContents: [ :writeStream| converter := LanguageEnvironment defaultSystemConverter. converter ifNil: [^ self]. [readStream atEnd] whileFalse: [ writeStream nextPut: (converter nextFromStream: readStream)]]. ! ! !ByteString methodsFor: 'testing' stamp: 'HenrikSperreJohansen 9/1/2009 00:44'! hasWideCharacterFrom: start to: stop "Only WideStrings contain these characters" ^false! ! !ByteString methodsFor: 'testing' stamp: 'HenrikSperreJohansen 1/26/2010 15:21'! isAsciiString ^(self class findFirstInString: self inSet: NonAsciiMap startingAt: 1) = 0! ! !ByteString methodsFor: 'testing' stamp: 'ar 4/10/2005 18:04'! isByteString "Answer whether the receiver is a ByteString" ^true! ! !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 class instanceVariableNames: ''! !ByteString class methodsFor: '*Fuel' stamp: 'MartinDias 12/30/2011 10:56'! materializeFrom: aDecoder ^ aDecoder nextEncodedString! ! !ByteString class methodsFor: 'contants' stamp: 'HenrikSperreJohansen 1/27/2010 17:50'! nonAsciiMap ^NonAsciiMap! ! !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: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'! 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: '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: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'! 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) ]! ! Symbol variableByteSubclass: #ByteSymbol instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Strings'! !ByteSymbol commentStamp: '' prior: 0! This class represents the symbols containing 8bit characters.! !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: 'ar 4/10/2005 22:10'! byteAt: index ^(self at: index) asciiValue! ! !ByteSymbol methodsFor: 'accessing' stamp: 'ar 4/10/2005 22:10'! byteAt: anInteger put: anObject "You cannot modify the receiver." self errorNoModification! ! !ByteSymbol methodsFor: 'accessing' stamp: 'ar 4/10/2005 22:11'! byteSize ^self size! ! !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: '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: 'accessing' stamp: 'ar 4/12/2005 17:51'! species "Answer the preferred class for reconstructing the receiver." ^ByteString ! ! !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: '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 methodsFor: 'converting' stamp: 'ar 4/10/2005 22:12'! asOctetString ^ self! ! !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: '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: '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: 'private' stamp: 'CamilloBruni 9/23/2012 23:17'! pvtAt: 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." self deprecated: 'use privateAt:put:' on: '2012-09-23' in: 'Pharo 2.0'. self privateAt: index put: aCharacter! ! !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 class instanceVariableNames: ''! !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'! findFirstInString: aString inSet: inclusionMap startingAt: start ^ByteString findFirstInString: aString inSet: inclusionMap startingAt: start! ! !ByteSymbol class methodsFor: 'primitives' stamp: 'ar 8/18/2005 13:46'! indexOfAscii: anInteger inString: aString startingAt: start ^ByteString indexOfAscii: anInteger inString: aString startingAt: start! ! !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:47'! translate: aString from: start to: stop table: table ^ByteString translate: aString from: start to: stop table: table! ! SymbolTest subclass: #ByteSymbolTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Strings'! !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 - 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 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 .! ! !ByteSymbolTest methodsFor: 'test - non-creation' stamp: 'StephaneDucasse 6/9/2012 22:54'! testNew "self debug: #testNew" self should: [ByteSymbol new: 5 ] raise: self defaultTestError. ! ! TextConverter subclass: #ByteTextConverter instanceVariableNames: '' classVariableNames: '' poolDictionaries: 'EventSensorConstants' category: 'Multilingual-TextConversion'! !ByteTextConverter commentStamp: 'michael.rueger 1/27/2009 18:00' prior: 0! A ByteTextConverter is the abstract class for text converters on single byte encodings.! !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 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:10'! unicodeToByte: unicodeChar ^unicodeChar charCode < 128 ifTrue: [unicodeChar] ifFalse: [self class unicodeToByteTable at: unicodeChar charCode ifAbsent: [0 asCharacter]]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ByteTextConverter class instanceVariableNames: 'byteToUnicode unicodeToByte'! !ByteTextConverter class methodsFor: '*Unicode-Initialization'! 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 ]) isNil ifTrue: [ stream print: nil; space ] ifFalse: [ stream << '16r' << (unicode printPaddedWith: $0 to: 4 base: 16); space ] ]. stream nextPut: $); cr ]! ! !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: 'SvenVanCaekenberghe 3/7/2012 21:49'! byteToUnicodeTable "Return the table mapping from my byte based encoding to unicode" ^ byteToUnicode! ! !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:50'! unicodeToByteTable "Return the table mapping from unicode to my byte based encoding" ^ unicodeToByte! ! !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! ! !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 ]! ! TestCase subclass: #ByteTextConverterTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Multilingual-Tests-TextConversion'! !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') = 'äöü'! ! !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: '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) .! ! Encoder subclass: #BytecodeEncoder instanceVariableNames: 'stream position rootNode blockExtentsToLocals' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Kernel'! !BytecodeEncoder commentStamp: '' prior: 0! 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: 'accessing' stamp: 'eem 5/14/2008 17:47'! methodStreamPosition ^stream position! ! !BytecodeEncoder methodsFor: 'accessing' stamp: 'eem 5/24/2008 11:56'! rootNode "^" ^rootNode! ! !BytecodeEncoder methodsFor: 'accessing' stamp: 'eem 5/24/2008 11:56'! rootNode: node "" rootNode := node! ! !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: '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 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/14/2008 18:22'! sizeBranchPopFalse: distance ^self sizeOpcodeSelector: #genBranchPopFalse: withArguments: {distance}! ! !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/14/2008 17:28'! sizeDup ^self sizeOpcodeSelector: #genDup withArguments: #()! ! !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/14/2008 17:40'! sizeJumpLong: distance ^self sizeOpcodeSelector: #genJumpLong: withArguments: {distance}! ! !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 17:28'! sizePop ^self sizeOpcodeSelector: #genPop withArguments: #()! ! !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 5/30/2008 16:36'! sizePushConsArray: numElements ^self sizeOpcodeSelector: #genPushConsArray: withArguments: {numElements}! ! !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:43'! sizePushLiteral: literalIndex ^self sizeOpcodeSelector: #genPushLiteral: withArguments: {literalIndex}! ! !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/24/2008 12:35'! sizePushNewArray: size ^self sizeOpcodeSelector: #genPushNewArray: withArguments: {size}! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 16:21'! sizePushReceiver ^self sizeOpcodeSelector: #genPushReceiver withArguments: #()! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/24/2008 22:59'! sizePushRemoteTemp: tempIndex inVectorAt: tempVectorIndex ^self sizeOpcodeSelector: #genPushRemoteTemp:inVectorAt: withArguments: {tempIndex. tempVectorIndex}! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 17:37'! sizePushSpecialLiteral: specialLiteral ^self sizeOpcodeSelector: #genPushSpecialLiteral: withArguments: {specialLiteral}! ! !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 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/14/2008 17:38'! sizeReturnSpecialLiteral: specialLiteral ^self sizeOpcodeSelector: #genReturnSpecialLiteral: withArguments: {specialLiteral}! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 17:34'! sizeReturnTop ^self sizeOpcodeSelector: #genReturnTop withArguments: #()! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/15/2008 09:06'! sizeReturnTopToCaller ^self sizeOpcodeSelector: #genReturnTopToCaller withArguments: #()! ! !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 5/14/2008 16:11'! sizeSendSuper: selectorLiteralIndex numArgs: nArgs ^self sizeOpcodeSelector: #genSendSuper:numArgs: withArguments: {selectorLiteralIndex. nArgs}! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 17:44'! sizeStoreInstVar: instVarIndex ^self sizeOpcodeSelector: #genStoreInstVar: withArguments: {instVarIndex}! ! !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 17:43'! sizeStoreLiteralVar: literalIndex ^self sizeOpcodeSelector: #genStoreLiteralVar: withArguments: {literalIndex}! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/15/2008 10:00'! sizeStorePopInstVar: instVarIndex ^self sizeOpcodeSelector: #genStorePopInstVar: withArguments: {instVarIndex}! ! !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/15/2008 10:20'! sizeStorePopLiteralVar: literalIndex ^self sizeOpcodeSelector: #genStorePopLiteralVar: withArguments: {literalIndex}! ! !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 5/14/2008 17:36'! sizeStorePopTemp: tempIndex ^self sizeOpcodeSelector: #genStorePopTemp: withArguments: {tempIndex}! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/24/2008 23:02'! sizeStoreRemoteTemp: tempIndex inVectorAt: tempVectorIndex ^self sizeOpcodeSelector: #genStoreRemoteTemp:inVectorAt: withArguments: {tempIndex. tempVectorIndex}! ! !BytecodeEncoder methodsFor: 'opcode sizing' stamp: 'eem 5/14/2008 17:45'! sizeStoreTemp: tempIndex ^self sizeOpcodeSelector: #genStoreTemp: withArguments: {tempIndex}! ! !BytecodeEncoder methodsFor: 'results' stamp: 'eem 6/5/2009 17:53'! printSchematicTempNamesOn: aStream blockExtents: blockExtents fromIndex: startIndex "Print the locals in the blockExtent startIndex, recursing to print any locals in nested blockExtents. Answer the index of the last blockExtent printed." | blockExtent subsequentIndex | blockExtent := blockExtents at: startIndex. blockExtent first > 0 ifTrue: [aStream nextPut: $[ ]. ((blockExtentsToLocals at: blockExtent) reject: [:local| local isRemote]) do: [:local| local isIndirectTempVector ifTrue: [aStream nextPut: $(. local remoteTemps do: [:remoteLocal| aStream nextPutAll: remoteLocal key] separatedBy: [aStream space]. aStream nextPut: $)] ifFalse: [aStream nextPutAll: local key]] separatedBy: [aStream space]. subsequentIndex := startIndex + 1. [subsequentIndex <= blockExtents size and: [(blockExtents at: subsequentIndex) last < blockExtent last]] whileTrue: [subsequentIndex := self printSchematicTempNamesOn: aStream blockExtents: blockExtents fromIndex: subsequentIndex]. blockExtent first > 0 ifTrue: [aStream nextPut: $] ]. ^subsequentIndex! ! !BytecodeEncoder methodsFor: 'results' stamp: 'nice 10/21/2009 00:02'! schematicTempNamesString "Answer the temp names for the current method node in a form that captures temp structure. The temps at each method and block scope level occurr space-separated, with any indirect temps enclosed in parentheses. Each block level is enclosed in square brackets. e.g. 'method level temps (indirect temp)[block args and temps (indirect)]' This representation can be reconstituted into a blockExtentsToTempsMap by a CompiledMethod that has been copied with teh schematicTempNamesString." blockExtentsToLocals ifNil: [self error: 'blockExtentsToLocals uninitialized. method not yet generated?']. ^String streamContents: [:aStream| self printSchematicTempNamesOn: aStream blockExtents: (blockExtentsToLocals keys asArray sort: [:range1 :range2| range1 first <= range2 first]) fromIndex: 1]! ! !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: '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: '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: 'temps' stamp: 'eem 9/8/2008 18:24'! 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) isNil ifTrue: [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 5/30/2008 14:35'! 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) isNil ifTrue: [aBlockNode nArgsSlot: (nArgs := 0)]. nArgs >= (CompiledMethod fullFrameSize - 1) ifTrue: [^self notify: 'Too many temporaries']. aBlockNode nArgsSlot: nArgs + 1. ^self bindTemp: name! ! !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: '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: '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: 'testing' stamp: 'eem 6/29/2009 11:11'! hasGeneratedMethod ^blockExtentsToLocals notNil! ! !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! ! EUCTextConverter subclass: #CNGBTextConverter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Multilingual-TextConversion'! !CNGBTextConverter commentStamp: '' prior: 0! 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 3/17/2004 00:41'! languageEnvironment ^ SimplifiedChineseEnvironment. ! ! !CNGBTextConverter methodsFor: 'private' stamp: 'yo 10/23/2002 14:42'! leadingChar ^ GB2312 leadingChar ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CNGBTextConverter class instanceVariableNames: ''! !CNGBTextConverter class methodsFor: 'utilities' stamp: 'yo 10/23/2002 14:42'! encodingNames ^ #('gb2312' ) copy ! ! ByteTextConverter subclass: #CP1250TextConverter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Multilingual-TextConversion'! !CP1250TextConverter commentStamp: '' prior: 0! Text converter for CP1250. Windows code page used in Eastern Europe.! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CP1250TextConverter class instanceVariableNames: ''! !CP1250TextConverter class methodsFor: 'accessing' stamp: 'pk 1/19/2005 14:35'! encodingNames ^ #('cp-1250') copy ! ! !CP1250TextConverter class methodsFor: 'accessing' stamp: 'michael.rueger 1/30/2009 11:02'! languageEnvironment ^Latin2Environment! ! !CP1250TextConverter class methodsFor: 'as yet unclassified'! initialize self initializeTables! ! !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 )! ! ByteTextConverter subclass: #CP1252TextConverter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Multilingual-TextConversion'! !CP1252TextConverter commentStamp: '' prior: 0! Text converter for CP1252. Windows code page used in Western Europe.! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CP1252TextConverter class instanceVariableNames: ''! !CP1252TextConverter class methodsFor: 'accessing' stamp: 'pmm 8/16/2010 10:59'! encodingNames ^ #('cp-1252') copy ! ! !CP1252TextConverter class methodsFor: 'accessing' stamp: 'pmm 8/16/2010 10:30'! languageEnvironment ^Latin9Environment! ! !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 )! ! !CP1252TextConverter class methodsFor: 'initialization' stamp: 'pmm 8/16/2010 10:58'! initialize self initializeTables! ! ByteTextConverter subclass: #CP1253TextConverter instanceVariableNames: '' classVariableNames: 'FromTable' poolDictionaries: '' category: 'Multilingual-TextConversion'! !CP1253TextConverter commentStamp: '' prior: 0! Text converter for CP1253. Windows code page used for Greek.! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CP1253TextConverter class instanceVariableNames: ''! !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 )! ! !CP1253TextConverter class methodsFor: 'accessing' stamp: 'yo 2/19/2004 10:11'! encodingNames ^ #('cp-1253') copy ! ! !CP1253TextConverter class methodsFor: 'accessing' stamp: 'michael.rueger 2/2/2009 18:49'! languageEnvironment ^GreekEnvironment! ! !CP1253TextConverter class methodsFor: 'as yet unclassified'! initialize self initializeTables! ! Model subclass: #CPUWatcher instanceVariableNames: 'tally watcher threshold' classVariableNames: 'CpuWatcherEnabled CurrentCPUWatcher' poolDictionaries: '' category: 'Tools-Process Browser'! !CPUWatcher commentStamp: 'VeronicaUquillas 6/11/2010 12:47' prior: 0! 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: 'accessing' stamp: 'nk 3/14/2001 07:56'! isMonitoring ^watcher notNil! ! !CPUWatcher methodsFor: 'accessing' stamp: 'IgorStasenko 3/6/2011 18:10'! processBrowser ^ Smalltalk tools processBrowser! ! !CPUWatcher methodsFor: 'accessing' stamp: 'nk 3/8/2001 18:36'! tally ^tally copy! ! !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: '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: 'accessing' stamp: 'nk 3/14/2001 08:26'! watcherProcess ^watcher! ! !CPUWatcher methodsFor: 'porcine capture' stamp: 'IgorStasenko 3/6/2011 18:10'! 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: 'porcine capture' stamp: 'sd 11/20/2005 21:27'! 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 | countAndProcess := tally sortedCounts first. (countAndProcess key / tally size > self threshold) ifTrue: [ | proc | proc := countAndProcess value. proc == Processor backgroundProcess ifTrue: [ ^self ]. "idle process? OK" self catchThePig: proc ]. ! ! !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: 'porcine capture' stamp: 'alain.plantec 5/30/2008 10:35'! openWindowForSuspendedProcess: aProcess WorldState addDeferredUIMessage: [ 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: 'process operations' stamp: 'nk 3/8/2001 17:27'! debugProcess: aProcess fromMenu: aMenuMorph aMenuMorph delete. self debugProcess: aProcess.! ! !CPUWatcher methodsFor: 'process operations' stamp: 'IgorStasenko 3/6/2011 18:11'! resumeProcess: aProcess fromMenu: aMenuMorph aMenuMorph delete. self processBrowser resumeProcess: aProcess.! ! !CPUWatcher methodsFor: 'process operations' stamp: 'IgorStasenko 3/6/2011 18:11'! terminateProcess: aProcess fromMenu: aMenuMorph aMenuMorph delete. self processBrowser terminateProcess: 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: 'startup-shutdown' stamp: 'nk 3/14/2001 08:07'! startMonitoring self monitorProcessPeriod: 20 sampleRate: 100! ! !CPUWatcher methodsFor: 'startup-shutdown' stamp: 'IgorStasenko 3/6/2011 18:11'! stopMonitoring watcher ifNotNil: [ self processBrowser terminateProcess: watcher. watcher := nil. ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CPUWatcher class instanceVariableNames: ''! !CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 3/8/2001 18:45'! current ^CurrentCPUWatcher ! ! !CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 3/14/2001 08:28'! currentWatcherProcess ^CurrentCPUWatcher ifNotNil: [ CurrentCPUWatcher watcherProcess ] ! ! !CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 3/6/2011 18:11'! dumpTallyOnTranscript self current ifNotNil: [ self processBrowser dumpTallyOnTranscript: self current tally ]! ! !CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 6/18/2003 07:15'! initialize "CPUWatcher initialize" Smalltalk addToStartUpList: self. Smalltalk addToShutDownList: self.! ! !CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 3/14/2001 08:06'! isMonitoring ^CurrentCPUWatcher notNil and: [ CurrentCPUWatcher isMonitoring ] ! ! !CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 6/18/2003 07:14'! shutDown self stopMonitoring.! ! !CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'nk 3/14/2001 08:17'! startMonitoring "CPUWatcher startMonitoring" ^self startMonitoringPeriod: 20 rate: 100 threshold: 0.8! ! !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: 'as yet unclassified' stamp: 'nk 6/18/2003 07:14'! startUp self monitorPreferenceChanged.! ! !CPUWatcher class methodsFor: 'as yet unclassified' stamp: 'sd 11/20/2005 21:28'! stopMonitoring "CPUWatcher stopMonitoring" CurrentCPUWatcher ifNotNil: [ CurrentCPUWatcher stopMonitoring. ]. CurrentCPUWatcher := nil. ! ! !CPUWatcher class methodsFor: 'setting' stamp: 'AlainPlantec 12/5/2009 19:42'! cpuWatcherEnabled ^ CpuWatcherEnabled ifNil: [CpuWatcherEnabled := false]! ! !CPUWatcher class methodsFor: 'setting' stamp: 'AlainPlantec 12/5/2009 19:44'! cpuWatcherEnabled: aBoolean CpuWatcherEnabled = aBoolean ifTrue: [^ self]. CpuWatcherEnabled := aBoolean. self monitorPreferenceChanged ! ! !CPUWatcher class methodsFor: 'setting' stamp: 'AlainPlantec 12/5/2009 19:43'! monitorPreferenceChanged self cpuWatcherEnabled ifTrue: [ self startMonitoring ] ifFalse: [ self stopMonitoring ]! ! Error subclass: #CRCError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compression-Streams'! !CRCError methodsFor: 'as yet unclassified' stamp: 'nk 3/7/2004 15:56'! isResumable ^true! ! Morph subclass: #CachingMorph instanceVariableNames: 'damageRecorder cacheCanvas' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Basic'! !CachingMorph commentStamp: '' prior: 0! 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: '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: 'caching' stamp: 'jm 11/13/97 16:31'! releaseCachedState super releaseCachedState. cacheCanvas := nil. ! ! !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: 'drawing'! drawOn: aCanvas submorphs isEmpty ifTrue: [^ super drawOn: aCanvas]. ! ! !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: 'drawing' stamp: 'ar 5/28/2000 17:12'! imageForm self updateCacheCanvas: Display getCanvas. ^ cacheCanvas form offset: self fullBounds topLeft ! ! !CachingMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:24'! defaultColor "answer the default color/fill style for the receiver" ^ Color veryLightGray! ! !CachingMorph methodsFor: 'initialization' stamp: 'MarcusDenker 12/11/2009 23:56'! initialize "initialize the state of the receiver" super initialize. damageRecorder := DamageRecorder new! ! AbstractEcryptorDecryptor subclass: #CaesarEcryptorDecryptor instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KeyChain'! !CaesarEcryptorDecryptor commentStamp: '' prior: 0! 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 )) ]]! ! Object subclass: #CalendarDayMorph instanceVariableNames: 'date bounds owner highlighted' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Widgets-Calendar'! !CalendarDayMorph commentStamp: '' prior: 0! 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: 'accessing' stamp: 'Jon 11/2/2011 21:18'! bounds ^ bounds! ! !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 21:18'! date: aDate date := aDate. ! ! !CalendarDayMorph methodsFor: 'accessing' stamp: 'Jon 11/2/2011 08:51'! highlighted ^highlighted! ! !CalendarDayMorph methodsFor: 'accessing' stamp: 'Jon 11/2/2011 08:51'! highlighted: aBoolean highlighted := aBoolean! ! !CalendarDayMorph methodsFor: 'accessing' stamp: 'Jon 11/2/2011 21:19'! owner ^ owner! ! !CalendarDayMorph methodsFor: 'accessing' stamp: 'Jon 11/2/2011 21:19'! owner: aCalendarChooserMorph owner := aCalendarChooserMorph! ! !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: 'initialize' stamp: 'StephaneDucasse 1/27/2013 12:42'! initialize super initialize. self highlighted: false! ! !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: 'printing' stamp: 'Jon 11/2/2011 08:19'! printOn: aStream aStream print: self class; nextPutAll: ' ('; print: self date; nextPut: $)! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CalendarDayMorph class instanceVariableNames: ''! !CalendarDayMorph class methodsFor: 'instance creation' stamp: 'Jon 11/2/2011 08:06'! on: aDate for: aCalendarChooserMorph ^self new date: aDate; owner: aCalendarChooserMorph; yourself. ! ! BorderedMorph subclass: #CalendarMorph instanceVariableNames: 'date days touchPoints announcer' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Widgets-Calendar'! !CalendarMorph commentStamp: '' prior: 0! 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: 'Jon 11/1/2011 20:57'! date ^date! ! !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: '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: '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: 'accessing' stamp: 'SeanDeNigris 1/22/2013 14:18'! weekdayFont ^ LogicalFont familyName: 'Bitmap DejaVu Sans' pointSize: 9.! ! !CalendarMorph methodsFor: 'announcing' stamp: 'SeanDeNigris 1/20/2013 21:13'! onChoiceSend: aSymbol to: anObject self announcer on: ChoseDate send: aSymbol to: anObject.! ! !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/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: '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: '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: 'event handling' stamp: 'SeanDeNigris 1/22/2013 14:50'! handleMonthNameTouched | newMonthName dayCount dialog | 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 month: newMonthName year: date year) daysInMonth. self date: (Date newDay: (date dayOfMonth min: dayCount) month: newMonthName year: date year). self changed. ! ! !CalendarMorph methodsFor: 'event handling' stamp: 'SeanDeNigris 1/26/2013 18:13'! handleNextMonthTouched self date: date onNextMonth. self changed. ! ! !CalendarMorph methodsFor: 'event handling' stamp: 'SeanDeNigris 1/26/2013 18:13'! handlePreviousMonthTouched self date: date onPreviousMonth. self changed. ! ! !CalendarMorph methodsFor: 'event handling' stamp: 'Jon 11/2/2011 09:21'! handleTodayTouched self date: Date today. self changed. ! ! !CalendarMorph methodsFor: 'event handling' stamp: 'SeanDeNigris 1/22/2013 14: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 month: date monthIndex year: newYear) daysInMonth. self date: (Date newDay: (date dayOfMonth min: dayCount) month: date monthIndex year: newYear). self changed.! ! !CalendarMorph methodsFor: 'event handling' stamp: 'Jon 11/2/2011 08:46'! handlesMouseDown: event ^true! ! !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 methodsFor: 'event handling' stamp: 'Jon 11/2/2011 08:52'! mouseMove: event self mouseDown: event! ! !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: 'initialize' stamp: 'Jon 11/3/2011 10:16'! defaultBounds "Answer the default bounds for the receiver." ^0 @ 0 corner: 200 @ 160! ! !CalendarMorph methodsFor: 'initialize' stamp: 'Jon 11/3/2011 10:16'! initialize super initialize. touchPoints := Dictionary new. ! ! !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: 'private' stamp: 'SeanDeNigris 1/20/2013 21:10'! announcer ^ announcer ifNil: [ announcer := Announcer new ].! ! !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: '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 class instanceVariableNames: ''! !CalendarMorph class methodsFor: 'instance creation' stamp: 'Jon 11/3/2011 10:11'! on: aDate ^self new "extent: 200 @ 160;" date: aDate; yourself. ! ! !CalendarMorph class methodsFor: 'instance creation' stamp: 'Jon 11/3/2011 09:59'! openOn: aDate ^(self on: aDate) openInWorld! ! FileStreamException subclass: #CannotDeleteFileException instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Files-Kernel'! Object subclass: #Canvas instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Support'! !Canvas commentStamp: '' prior: 0! 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: 'accessing' stamp: 'ar 6/22/1999 14:07'! clipRect "Return the currently active clipping rectangle" ^self subclassResponsibility! ! !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/12/2000 18:17'! contentsOfArea: aRectangle into: aForm "Return the contents of the given area" ^self subclassResponsibility! ! !Canvas methodsFor: 'accessing'! depth ^ Display depth ! ! !Canvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 14:15'! extent "Return the physical extent of the output device" ^self subclassResponsibility! ! !Canvas methodsFor: 'accessing' stamp: 'jm 6/2/1998 06:39'! form ^ Display ! ! !Canvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 14:11'! origin "Return the current origin for drawing operations" ^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: '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: 'converting' stamp: 'ar 8/8/2001 14:22'! asAlphaBlendingCanvas: alpha ^(AlphaBlendingCanvas on: self) alpha: alpha! ! !Canvas methodsFor: 'converting' stamp: 'ar 6/24/1999 17:46'! asShadowDrawingCanvas ^self asShadowDrawingCanvas: (Color black alpha: 0.5).! ! !Canvas methodsFor: 'converting' stamp: 'ar 8/8/2001 14:14'! asShadowDrawingCanvas: aColor ^(ShadowDrawingCanvas on: self) shadowColor: aColor! ! !Canvas methodsFor: 'copying' stamp: 'ls 3/20/2000 21:24'! copyClipRect: newClipRect ^ ClippingCanvas canvas: self clipRect: newClipRect ! ! !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' 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: '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' 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' 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: '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: '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' stamp: 'ar 6/17/1999 01:31'! paragraph: paragraph bounds: bounds color: c "Draw the given paragraph" ^self subclassResponsibility! ! !Canvas methodsFor: 'drawing' stamp: 'ar 2/5/1999 18:28'! render: anObject "Do some 3D operations with the object if possible"! ! !Canvas methodsFor: 'drawing-general' stamp: 'ar 5/29/1999 05:14'! draw: anObject ^anObject drawOn: self! ! !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: 'drawing-general'! fullDraw: anObject ^anObject fullDrawOn: self! ! !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-general' stamp: 'ar 12/30/2001 18:47'! roundCornersOf: aMorph during: aBlock ^self roundCornersOf: aMorph in: aMorph bounds during: aBlock! ! !Canvas methodsFor: 'drawing-general' stamp: 'ar 12/30/2001 18:47'! roundCornersOf: aMorph in: bounds during: aBlock ^aBlock value! ! !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: 'drawing-general' stamp: 'GaryChambers 9/8/2011 14:47'! roundShadowCornersOf: aMorph in: bounds during: aBlock ^aBlock value! ! !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-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-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-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 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-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: '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-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-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-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-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-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'! fillOval: r color: c borderWidth: borderWidth borderColor: borderColor "Fill the given oval." ^self subclassResponsibility! ! !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-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-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-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: '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-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: '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-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: '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-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-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-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: '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-rectangles' stamp: 'ar 6/18/1999 07:33'! frameRectangle: r color: c self frameRectangle: r width: 1 color: c. ! ! !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-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: '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: '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-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-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-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-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 03:00'! translateBy: delta during: aBlock "Set a translation only during the execution of aBlock." ^self subclassResponsibility! ! !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-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-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-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-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-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: '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: '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-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: '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: 'initialization' stamp: 'ar 2/9/1999 06:29'! flush! ! !Canvas methodsFor: 'initialization' stamp: 'di 9/22/1999 19:21'! reset "Reset the canvas." super initWithTarget:self class defaultTarget. ! ! !Canvas methodsFor: 'other' stamp: 'StephaneDucasse 2/9/2011 14:51'! flushDisplay "Empty hook method."! ! !Canvas methodsFor: 'other' stamp: 'StephaneDucasse 2/9/2011 14:51'! forceToScreen: rect "Empty hook method" ! ! !Canvas methodsFor: 'other'! translateBy:aPoint clippingTo:aRect during:aBlock ^aBlock value:(self copyOffset:aPoint clipRect:aRect).! ! !Canvas methodsFor: 'testing' stamp: 'di 8/12/2000 15:04'! doesRoundedCorners ^ true! ! !Canvas methodsFor: 'testing' stamp: 'ar 11/13/1998 13:19'! isBalloonCanvas ^false! ! !Canvas methodsFor: 'testing' stamp: 'IgorStasenko 7/18/2011 18:53'! isShadowDrawing ^false! ! !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: '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: '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: '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! ! ParseNode subclass: #CascadeNode instanceVariableNames: 'receiver messages' classVariableNames: '' poolDictionaries: '' category: 'Compiler-ParseNodes'! !CascadeNode commentStamp: '' prior: 0! The first message has the common receiver, the rest have receiver == nil, which signifies cascading.! !CascadeNode methodsFor: 'accessing' stamp: 'eem 9/10/2008 15:15'! messages ^messages! ! !CascadeNode methodsFor: 'accessing' stamp: 'tk 10/22/2000 16:55'! receiver ^receiver! ! !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: '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: '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'! receiver: receivingObject messages: msgs " Transcript show: 'abc'; cr; show: 'def' " receiver := receivingObject. messages := msgs! ! !CascadeNode methodsFor: 'printing'! printOn: aStream indent: level self printOn: aStream indent: level precedence: 0! ! !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: 'eem 6/2/2008 11:47'! printWithClosureAnalysisOn: aStream indent: level self printWithClosureAnalysisOn: aStream indent: level precedence: 0! ! !CascadeNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! printWithClosureAnalysisOn: aStream indent: level precedence: p p > 0 ifTrue: [aStream nextPut: $(]. messages first printWithClosureAnalysisReceiver: receiver on: aStream indent: level. 1 to: messages size do: [:i | (messages at: i) printWithClosureAnalysisOn: 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: 'visiting' stamp: 'eem 9/6/2009 12:33'! accept: aVisitor ^aVisitor visitCascadeNode: self! ! Object subclass: #Categorizer instanceVariableNames: 'categoryArray categoryStops elementArray' classVariableNames: 'Default NullCategory' poolDictionaries: '' category: 'Kernel-Classes'! !Categorizer commentStamp: 'StephaneDucasse 5/9/2010 20:11' prior: 0! 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: '*CodeImport' stamp: 'GuillermoPolito 5/5/2012 02:12'! importCodeFrom: aCodeImporter aCodeImporter importCategorizer: self.! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/5/2004 17:44'! addCategory: newCategory ^ self addCategory: newCategory before: nil ! ! !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: '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/7/2004 10:29'! categories "Answer an Array of categories (names)." categoryArray isNil ifTrue: [^ nil]. (categoryArray size = 1 and: [categoryArray first = Default & (elementArray size = 0)]) ifTrue: [^Array with: NullCategory]. ^categoryArray! ! !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: '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: 'nice 1/5/2010 20:01'! 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 asOrderedCollection. 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'! changeFromString: aString "Parse the argument, aString, and make this be the receiver's structure." | categorySpecs | categorySpecs := Scanner new scanTokens: aString. "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: 'NS 4/5/2004 17:44'! classify: element under: heading self classify: element under: heading suppressIfDefault: true! ! !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: 'NS 4/5/2004 17:44'! classifyAll: aCollection under: heading aCollection do: [:element | self classify: element under: heading]! ! !Categorizer methodsFor: 'accessing' stamp: 'NS 4/7/2004 10:20'! elementCategoryDict | dict firstIndex lastIndex | elementArray isNil ifTrue: [^ 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: '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/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 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'! 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: '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: 'accessing' stamp: 'NS 4/12/2004 20:50'! removeElement: element ^ self basicRemoveElement: element! ! !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: '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: 'NS 4/5/2004 17:44'! 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 asSortedCollection; asArray. self categories: newCategories! ! !Categorizer methodsFor: 'actions' stamp: 'StephaneDucasse 7/7/2010 18:58'! moveCategory: sourceCategory to: destinationCategory self classifyAll: (self listAtCategoryNamed: sourceCategory) under: destinationCategory. self removeCategory: sourceCategory.! ! !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: '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: 'private' stamp: 'jannik.laval 5/1/2010 16:01'! assertInvariant [elementArray size = categoryStops last] assert! ! !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: '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: 'private' stamp: 'NS 4/6/2004 13:52'! lastIndexOfCategoryNumber: anInteger anInteger > categoryStops size ifTrue: [^ nil]. ^ categoryStops at: anInteger! ! !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 class instanceVariableNames: ''! !Categorizer class methodsFor: 'class initialization' stamp: 'eem 1/7/2009 16:04'! allCategory "Return a symbol that represents the virtual all methods category." ^#'-- all --'! ! !Categorizer class methodsFor: 'class initialization' stamp: 'NS 4/5/2004 17:44'! default ^ Default! ! !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'! 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: '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! ! SystemAnnouncement subclass: #CategoryAdded instanceVariableNames: 'categoryName' classVariableNames: '' poolDictionaries: '' category: 'System-Announcements'! !CategoryAdded commentStamp: 'cyrilledelaunay 1/18/2011 12:29' prior: 0! 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 instanceVariableNames: ''! !CategoryAdded class methodsFor: 'instance creation' stamp: 'GuillermoPolito 8/1/2012 17:57'! categoryName: aCategoryName ^self new categoryName: aCategoryName; yourself! ! SystemAnnouncement subclass: #CategoryRemoved instanceVariableNames: 'categoryName' classVariableNames: '' poolDictionaries: '' category: 'System-Announcements'! !CategoryRemoved commentStamp: 'cyrilledelaunay 1/18/2011 12:28' prior: 0! 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 instanceVariableNames: ''! !CategoryRemoved class methodsFor: 'instance creation' stamp: 'GuillermoPolito 8/2/2012 00:02'! categoryName: aCategoryName ^self new categoryName: aCategoryName; yourself! ! SystemAnnouncement subclass: #CategoryRenamed instanceVariableNames: 'from to newCategoryName oldCategoryName' classVariableNames: '' poolDictionaries: '' category: 'System-Announcements'! !CategoryRenamed commentStamp: 'cyrilledelaunay 1/18/2011 12:26' prior: 0! This announcement will be emited when renaming a category using: => SystemOrganizer >> renameCategory:toBe:! !CategoryRenamed methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:05'! newCategoryName ^newCategoryName! ! !CategoryRenamed methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:05'! newCategoryName: aCategoryName newCategoryName := aCategoryName! ! !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 instanceVariableNames: ''! !CategoryRenamed class methodsFor: 'instance creation' stamp: 'GuillermoPolito 8/2/2012 00:05'! classCategoryRenamedFrom: anOldCategoryName to: aNewCategoryName ^self new newCategoryName: aNewCategoryName; oldCategoryName: anOldCategoryName; yourself! ! AbstractCategoryWidget subclass: #CategoryWidget instanceVariableNames: 'categoriesList categoriesGroup categoriesSelection categories' classVariableNames: '' poolDictionaries: '' category: 'Nautilus-Widgets'! !CategoryWidget commentStamp: '' prior: 0! CategoryWidget is the basic implementation of a wiget managing categories! !CategoryWidget methodsFor: 'icon'! thereIsNoIconsOnCategories! ! !CategoryWidget methodsFor: 'initialize-release'! initialize super initialize. categoriesSelection := Dictionary new.! ! !CategoryWidget methodsFor: 'initialize-release'! model: aModel super model: aModel. self selectedCategory ifNotNil: [:cat | categoriesSelection at: cat put: true ]! ! !CategoryWidget methodsFor: 'item creation' stamp: 'EstebanLorenzano 2/6/2013 16:56'! 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; model: self; getIndexSelector: #selectedCategoryIndex; setIndexSelector: #selectedCategoryIndex:; getSelectionListSelector: #categorySelectionAt:; setSelectionListSelector: #categorySelectionAt:put:; getMenuSelector: #categoriesMenu:shifted:; beMultipleSelection; getListElementSelector: #getCategoryItem:; changed ! ! !CategoryWidget methodsFor: 'protocol'! categoriesSelection ^ categoriesSelection! ! !CategoryWidget methodsFor: 'protocol'! getCategories ^ categories ifNil: [ categories := self loadCategories ].! ! !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: 'protocol' stamp: 'BenjaminVanRyseghem 3/23/2012 18:54'! label: aString "categoriesGroup label: aString"! ! !CategoryWidget methodsFor: 'protocol'! loadCategories | class | class := self model selectedClass. class ifNil: [ ^ #() ]. ^ self model showGroups ifTrue: [ self loadGroupsCategoriesFor: class ] ifFalse: [ self loadPackagesCategoriesFor: class ]! ! !CategoryWidget methodsFor: 'protocol'! resetCategoryCache categories := nil! ! !CategoryWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/27/2012 00:34'! resetSelection self categoriesSelection removeAll! ! !CategoryWidget methodsFor: 'protocol'! searchedElement: index categoriesList searchedElement: index! ! !CategoryWidget methodsFor: 'protocol'! 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'! takeKeyboardFocus categoriesList takeKeyboardFocus! ! !CategoryWidget methodsFor: 'protocol'! vScrollValue ^ categoriesList scrollValue y! ! !CategoryWidget methodsFor: 'protocol'! vScrollValue: aNumber ^ categoriesList vScrollValue: aNumber! ! !CategoryWidget methodsFor: 'selection'! categorySelectionAt: anIndex | elt | elt := self getCategories at: anIndex ifAbsent: [ nil ]. ^ categoriesSelection at: elt ifAbsent: [ 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: 'selection'! resetCategoriesListSelection categoriesSelection removeAll! ! !CategoryWidget methodsFor: 'selection'! selectedCategoryIndex ^ self getCategories indexOf: self selectedCategory ifAbsent: [ 0 ]! ! !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: 'private'! categoriesLabel ^ self showInstance ifTrue: ['Instance protocols:' asText] ifFalse: ['Class protocols:' asText allBold ]! ! !CategoryWidget methodsFor: 'private'! categoryListSize ^ self getCategories size! ! !CategoryWidget methodsFor: 'private'! 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: 'private'! deselectProtocol: aString categoriesSelection at: aString put: false! ! !CategoryWidget methodsFor: 'private'! getCategoryItem: anIndex ^ self getCategories at: anIndex! ! !CategoryWidget methodsFor: 'private'! hasFocus ^ categoriesList hasKeyboardFocus! ! !CategoryWidget methodsFor: 'private'! loadCategoriesWithProtocols: protocols forClass: class | package result tmp | package := self model selectedPackage. result := OrderedCollection with: self model allLabel. tmp := #(). tmp := protocols select: [ :each | | item | each first = $* ifTrue: [ item := each allButFirst asLowercase. item = package name asLowercase or: [ (item beginsWith: package name asLowercase) and: [ ((item at: package name size + 1) = $-) not ]]] ifFalse: [ false ]]. result addAll: tmp sort. tmp := protocols reject: [ :e | tmp includes: e ]. result addAll: tmp sort. ^ result! ! !CategoryWidget methodsFor: 'private'! loadGroupsCategoriesFor: class | env | env := model browsedEnvironment. ^ env isSystem ifTrue: [ self loadGroupsCategoriesInSytemEnvironmentFor: class ] ifFalse: [ self loadGroupsCategoriesInARestrictedEnvironment: env for: class ]! ! !CategoryWidget methodsFor: 'private'! loadGroupsCategoriesInARestrictedEnvironment: env for: class | group | group := self model selectedGroup. ^ self loadCategoriesWithProtocols: ((group protocolsFor: class ) intersection: ( env protocolsFor: class )) forClass: class! ! !CategoryWidget methodsFor: 'private'! loadGroupsCategoriesInSytemEnvironmentFor: class | group | group := self model selectedGroup. ^ self loadCategoriesWithProtocols: (group protocolsFor: class ) forClass: class! ! !CategoryWidget methodsFor: 'private'! loadPackagesCategoriesFor: class | env | env := self model browsedEnvironment. ^env isSystem ifTrue: [ self loadPackagesCategoriesInSystemEnvironmentFor: class ] ifFalse: [ self loadPackagesCategoriesInARestrictedEnvironment: env for: class ]! ! !CategoryWidget methodsFor: 'private'! loadPackagesCategoriesInARestrictedEnvironment: env for: class | group | group := self model selectedGroup. ^ self loadCategoriesWithProtocols: (model browsedEnvironment protocolsFor: class) forClass: class! ! !CategoryWidget methodsFor: 'private'! loadPackagesCategoriesInSystemEnvironmentFor: class | group | group := self model selectedGroup. ^ self loadCategoriesWithProtocols: class protocols forClass: class! ! !CategoryWidget methodsFor: 'private'! selectProtocol: aString categoriesSelection at: aString put: true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CategoryWidget class instanceVariableNames: ''! !CategoryWidget class methodsFor: 'menu' stamp: 'EstebanLorenzano 2/6/2013 15:33'! 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, m' if: Nautilus useOldStyleKeys not; keyText: 'r' if: Nautilus useOldStyleKeys; action: [ target renameCategory ]; order: 1300; enabledBlock: [ target enableCategorySingleSelection ]. (aBuilder item: #'Remove...') keyText: 'x, m' if: Nautilus useOldStyleKeys not; keyText: 'x' if: Nautilus useOldStyleKeys; action: [ target removeCategories ]; order: 1400; icon: (target iconClass iconNamed: #removeIcon); withSeparatorAfter. (aBuilder item: #'Add in group...') keyText: 'n, e, m' if: Nautilus useOldStyleKeys not; action: [ target addProtocolsInGroup ]; order: 1500. (aBuilder item: #'File Out') action: [ target fileOutCategories ]; order: 1600.! ! !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'.! ! CodeHolder subclass: #ChangeList instanceVariableNames: 'changeList list listIndex listSelections file lostMethodPointer' classVariableNames: '' poolDictionaries: '' category: 'Tools-Changes'! !ChangeList commentStamp: 'StephaneDucasse 7/23/2010 21:17' prior: 0! 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: '*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: 'accessing'! changeList ^ changeList! ! !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: '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'! file ^file! ! !ChangeList methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:26'! setLostMethodPointer: sourcePointer lostMethodPointer := sourcePointer! ! !ChangeList methodsFor: 'accessing' stamp: 'sw 10/19/1999 15:11'! showsVersions ^ false! ! !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: '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: '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: 'initialization-release' 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: '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: '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: 'initialization-release' stamp: 'sw 8/15/2002 22:34'! wantsPrettyDiffOption "Answer whether pretty-diffs are meaningful for this tool" ^ true! ! !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: '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: 'menu actions' stamp: 'StephaneDucasse 7/23/2010 22:00'! browseVersions | change class browser | listIndex = 0 ifTrue: [^ nil ]. change := changeList at: listIndex. change classIncludesSelector ifFalse: [ ^nil ]. browser := super browseVersions. browser ifNotNil: [ browser addedChangeRecord: change ]. ^browser! ! !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: '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: '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: '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: '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: 'menu actions' stamp: 'StephaneDucasse 11/20/2011 15:32'! destroyCurrentCodeOfSelections "Actually remove from the system any in-memory methods with class and selector identical to items current selected. This may seem rather arcane but believe me it has its great uses, when trying to split out code. To use effectively, first file out a change set that you wish to split off. Then open a ChangeList browser on that fileout. Now look through the methods, and select any of them which you want to remove completely from the system, then issue this command. For those methods where you have made changes to pre-existing versions, of course, you won't want to remove them from the system, so use this mechanism with care!!" | aClass aChange aList | aList := OrderedCollection new. 1 to: changeList size do: [:index | (listSelections at: index) ifTrue: [aChange := changeList at: index. aChange isMethodDefinedInImage ifTrue: [aList add: {aClass. aChange methodSelector}]]]. aList size > 0 ifTrue: [(self confirm: 'Warning!! This will actually remove ', aList size printString, ' method(s) from the system!!') ifFalse: [^ self]]. aList do: [:aPair | self traceCr: 'Removed: ', aPair first printString, '.', aPair second. aPair first removeSelector: aPair second]! ! !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: '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: '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: '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: '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:15'! 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 parserClass new 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: '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: '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: '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 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: 'sd 11/20/2005 21:26'! selectAll listIndex := 0. listSelections atAllPut: true. self changed: #allSelections! ! !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: 'menu actions' stamp: 'nice 1/5/2010 15:59'! selectConflicts: changeSetOrList "Selects all method definitions for which there is ALSO an entry in the specified changeSet or changList" | systemChanges | 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: '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: '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: '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: '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: 'StephaneDucasse 7/23/2010 22:42'! selectNewMethods "Selects all method definitions for which there is no counterpart method in the current image" Cursor read showWhile: [ | change class | 1 to: changeList size do: [:i | change := changeList at: i. listSelections at: i put: change isMethodNotDefinedInImage]]. self changed: #allSelections! ! !ChangeList methodsFor: 'menu actions' stamp: 'jb 7/1/2011 10:40'! 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 evaluatorClass evaluate: '[:aChangeRecord | ', code, ']'. self selectSuchThat: block! ! !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: 'menu actions' stamp: 'StephaneDucasse 11/14/2010 22:51'! 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 := Scanner new scanTokens: change string. ((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: 'StephaneDucasse 7/23/2010 22:50'! 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: [ | class change |1 to: changeList size do: [:i | change := changeList at: i. listSelections at: i put: change isUnchangedMethod]]. self changed: #allSelections! ! !ChangeList methodsFor: 'scanning' stamp: 'EstebanLorenzano 8/17/2012 16:41'! 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 := Scanner new scanTokens: item. 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: 'scanning' stamp: 'StephaneDucasse 7/23/2010 21:04'! 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]) parserClass new parseSelector: method) isNil ifTrue: ['unparsableSelector'] ifFalse: [selector]) , (stamp isEmpty ifTrue: [''] ifFalse: ['; ' , stamp])]! ! !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: '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: '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 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: 'viewing access' stamp: 'HenrikSperreJohansen 8/4/2010 12:15'! 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 := Scanner new scanTokens: aChange string. ((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: '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: 'viewing access' stamp: 'sd 11/20/2005 21:26'! 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 == nil]) ifTrue: [^ later]. earlier := (changeList at: listIndex + 1) text. ^ TextDiffBuilder buildDisplayPatchFrom: earlier to: later inClass: class prettyDiffs: self showingPrettyDiffs! ! !ChangeList methodsFor: 'viewing access'! list ^ list! ! !ChangeList methodsFor: 'viewing access'! listIndex ^ listIndex! ! !ChangeList methodsFor: 'viewing access'! listSelectionAt: index ^ listSelections at: index! ! !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: '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: 'viewing access' stamp: 'nk 2/26/2004 13:50'! selectedClass ^(self selectedClassOrMetaClass ifNil: [ ^nil ]) theNonMetaClass ! ! !ChangeList methodsFor: 'viewing access' stamp: 'sd 11/20/2005 21:26'! selectedClassOrMetaClass | c | ^ (c := self currentChange) ifNotNil: [c methodClass]! ! !ChangeList methodsFor: 'viewing access' stamp: 'sd 11/20/2005 21:26'! selectedMessageName | c | ^ (c := self currentChange) ifNotNil: [c methodSelector]! ! !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: 'viewing access' stamp: 'sw 1/25/1999 14:45'! undiffedContents ^ listIndex = 0 ifTrue: [''] ifFalse: [(changeList at: listIndex) text]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ChangeList class instanceVariableNames: ''! !ChangeList class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'FernandoOlivero 4/12/2011 09:39'! taskbarIcon "Answer the icon for the receiver in a task bar." ^ self theme smallSaveIcon! ! !ChangeList class methodsFor: '*Tools-FileList' stamp: 'IgorStasenko 3/6/2011 18:14'! browseChangesFile: fullName "Browse the selected file in fileIn format." fullName ifNotNil: [self browseStream: (FileStream readOnlyFileNamed: fullName)] ifNil: [Beeper beep]! ! !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: 'IgorStasenko 3/6/2011 18:14'! browseCompressedChangesFile: fullName "Browse the selected file in fileIn format." | unzipped stream | fullName ifNil: [^Beeper beep]. 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: '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: '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 ]! ! !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: '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: '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: 'initialization' stamp: 'GabrielOmarCotelli 6/4/2009 20:38'! unload FileServices unregisterFileReader: self ! ! !ChangeList class methodsFor: 'initialize-release' stamp: 'GabrielOmarCotelli 6/4/2009 20:38'! initialize FileServices registerFileReader: self! ! !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: '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: 'menu' stamp: 'EstebanLorenzano 1/31/2013 18:28'! 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: #'Destroy current methods of selections') help: 'Remove (*destroy*) the in-image counterparts of all selected methods'; target: target; selector: #destroyCurrentCodeOfSelections; withSeparatorAfter. (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: '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: '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: '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: '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: '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: 'StephaneDucasse 5/28/2011 13:32'! 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 isNil ifTrue: [^ self]. self browseRecent: end - pos on: origChangesFile! ! !ChangeList class methodsFor: 'public access' stamp: 'nb 6/17/2003 12:25'! browseRecentLogOnPath: fullName "figure out where the last snapshot or quit was, then browse the recent entries." fullName ifNotNil: [self browseRecentLogOn: (FileStream readOnlyFileNamed: fullName)] ifNil: [Beeper beep] ! ! !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: 'tool registry' stamp: 'IgorStasenko 2/20/2011 14:41'! registerToolsOn: registry registry register: self as: #changeList ! ! !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 ! ! Object subclass: #ChangeRecord instanceVariableNames: 'file position type class category meta stamp' classVariableNames: '' poolDictionaries: '' category: 'System-Changes'! !ChangeRecord commentStamp: '' prior: 0! 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: '*RecentSubmissions-Core' stamp: 'BenjaminVanRyseghem 5/6/2011 17:39'! <= anotherOne self stamp ifNil: [ ^ false ]. anotherOne stamp ifNil: [ ^ true ]. ^ self timeStamp <= anotherOne timeStamp ! ! !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: '*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-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: '*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: '*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'! category ^category! ! !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: 'access' stamp: 'sumim 9/1/2003 18:27'! fileIndex ^ (SourceFiles collect: [ :sf | sf name]) indexOf: file name ifAbsent: [^ nil]. ! ! !ChangeRecord methodsFor: 'access' stamp: 'nk 1/7/2004 10:28'! fileName ^(file ifNotNil: [ file name ]) ifNil: [ '' ]! ! !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'! isMetaClassChange ^meta! ! !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'! methodClassName ^class! ! !ChangeRecord methodsFor: 'access' stamp: 'lr 3/14/2010 21:13'! methodSelector ^ type == #method ifTrue: [ (Smalltalk globals at: class ifAbsent: [ Object ]) parserClass new parseSelector: self string ]! ! !ChangeRecord methodsFor: 'access' stamp: 'sumim 9/2/2003 14:07'! position ^ position! ! !ChangeRecord methodsFor: 'access' stamp: 'sumim 9/2/2003 13:33'! prior | currFile preamble prevPos tokens prevFileIndex | currFile := file readOnlyCopy. currFile position: (0 max: position - 150). [currFile position < (position - 1)] whileTrue: [preamble := currFile nextChunk]. currFile close. prevPos := nil. (preamble findString: 'methodsFor:' startingAt: 1) > 0 ifTrue: [tokens := Scanner new scanTokens: preamble] ifFalse: [tokens := Array new]. ((tokens size between: 7 and: 8) and: [(tokens at: tokens size - 5) == #methodsFor:]) ifTrue: [ (tokens at: tokens size - 3) == #stamp: ifTrue: [ prevPos := tokens last. prevFileIndex := SourceFiles fileIndexFromSourcePointer: prevPos. prevPos := SourceFiles filePositionFromSourcePointer: prevPos] ifFalse: [ prevPos := tokens at: tokens size - 2. prevFileIndex := tokens last]. (prevPos = 0 or: [prevFileIndex = 0]) ifTrue: [prevPos := nil]]. prevPos ifNil: [^ nil]. ^ {prevFileIndex. prevPos. SourceFiles sourcePointerFromFileIndex: prevFileIndex andPosition: prevPos}! ! !ChangeRecord methodsFor: 'access' stamp: '6/6/97 08:56 dhhi'! stamp ^ stamp! ! !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: '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: 'nice 1/5/2010 15:59'! 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. TimeStamp date: date time: time] on: Error do: [:ex | ex return: (TimeStamp fromSeconds: 0)]] ifFalse: [TimeStamp fromSeconds: 0]! ! !ChangeRecord methodsFor: 'access'! type ^ type! ! !ChangeRecord methodsFor: 'initialization'! file: f position: p type: t file := f. position := p. type := t! ! !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: 'initialization' stamp: 'PavelKrivanek 11/15/2012 14:23'! 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 aSelector 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 evaluatorClass evaluate: s ] ]. "This expression break the recentMessageSet because it hijacks compiled methods to represent classComment. In the future we should redo a complete changeset metamodel based on classDefinition, classComment and other. type == #classComment ifTrue: [ | cls | (cls := Smalltalk globals at: class asSymbol) comment: self text stamp: stamp. RecentMessageSet noteMethodSubmission: #Comment forClass: cls ]" ]! ! !ChangeRecord methodsFor: 'testing' stamp: 'StephaneDucasse 7/23/2010 21:59'! classIncludesSelector | aClass | ^ (aClass := self methodClass) notNil and: [aClass includesSelector: self methodSelector]! ! !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: '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: 'testing' stamp: 'StephaneDucasse 7/23/2010 22:52'! isUnchangedMethod ^ self isMethodDefinedInImage and: [self string withBlanksCondensed = (self methodClass sourceCodeAt: self methodSelector) asString withBlanksCondensed ]! ! Object subclass: #ChangeSet instanceVariableNames: 'name preamble postscript changeRecords structures superclasses' classVariableNames: 'AllChangeSets DefaultChangeSetDirectoryName MustCheckForSlips PreviousSet' poolDictionaries: '' category: 'System-Changes'! !ChangeSet commentStamp: 'VeronicaUquillas 6/11/2010 12:36' prior: 0! ChangeSets keep track of the changes made to a system, so they can be written on a file as source code (a "fileOut"). This implementation of ChangeSet is capable of remembering and manipulating methods for which the classes are not present in the system. However at the present time, this capability is not used in normal rearranging and fileOuts, but only for invoking and revoking associated with isolation layers. For isolated projects (see Project class comment), the changeSet binding is semi-permanent. Every project exists in an isolation layer defined by its closest enclosing parent (or itself) that is isolated. If a project is not isolated, then changes reported to its designated changeSet must also be reported to the permanent changeSet for that layer, designated in the isolated project. This ensures that that outer project will be able to revert all changes upon exit. Note that only certain changes may be reverted. Classes may not be added, removed, renamed or reshaped except in the layer in which they are defined because these operations on non-local classes are not revertable. If a Squeak Project is established as being isolated, then its associated changeSet will be declared to be revertable. In this case all changes stored can be reverted. The changeSet associated with an isolated project is tied to that project, and cannot be edited in a changeSorter. ------ name - a String used to name the changeSet, and thus any associated project or fileOut. preamble and postscript: two strings that serve as prefix (useful for documentation) and suffix (useful for doits) to the fileout of the changeSet. revertable - a Boolean If this variable is true, then all of the changes recorded by this changeSet can be reverted. changeRecords - Dictionary {class name -> a ClassChangeRecord}. These classChangeRecords (qv) remember all of the system changes. structures - Dictionary {#Rectangle -> #( 'origin' 'corner')}. Of the names of the instances variables before any changes for all classes in classChanges, and all of their superclasses. In the same format used in SmartRefStream. Inst var names are strings. superclasses - Dictionary {#Rectangle -> #Object}. Of all classes in classChanges, and all of their superclasses. Structures and superclasses save the instance variable names of this class and all of its superclasses. Later we can tell how it changed and write a conversion method. The conversion method is used when old format objects are brought in from the disk from ImageSegment files (.extSeg) or SmartRefStream files (.obj .morph .bo .sp). NOTE: It should be fairly simple, by adding a bit more information to the classChangeRecords, to reconstruct the information now stored in 'structures' and 'superclasses'. This would be a welcome simplification. ! !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: 'accessing' stamp: 'di 4/1/2000 12:00'! classRemoves ^ changeRecords keys select: [:className | (changeRecords at: className) isClassRemoval]! ! !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: 'accessing' stamp: 'sw 6/29/1999 14:44'! hasPostscript ^ postscript notNil! ! !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: 'accessing' stamp: 'di 3/29/2000 16:22'! methodInfoFromRemoval: classAndSelector ^ (self changeRecorderFor: classAndSelector first) infoFromRemoval: classAndSelector last! ! !ChangeSet methodsFor: 'accessing' stamp: 'CamilloBruni 8/1/2012 16:11'! name "The name of this changeSet. If name is nil, we've got garbage. Help to identify." ^ name isNil ifTrue: [ '' ] ifFalse: [ name ]! ! !ChangeSet methodsFor: 'accessing'! name: anObject name := anObject! ! !ChangeSet methodsFor: 'accessing' stamp: 'ar 7/16/2005 18:04'! postscriptHasDependents ^false! ! !ChangeSet methodsFor: 'accessing' stamp: 'StephaneDucasse 5/13/2010 11:33'! printOn: aStream super printOn: aStream. aStream nextPutAll: ' named ', self name! ! !ChangeSet methodsFor: 'accessing' stamp: 'sw 6/29/1999 14:48'! removePostscript postscript := nil! ! !ChangeSet methodsFor: 'accessing' stamp: 'tk 6/8/1999 22:25'! structures ^structures! ! !ChangeSet methodsFor: 'accessing' stamp: 'tk 6/8/1999 22:25'! superclasses ^superclasses! ! !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: 'change logging' stamp: 'VeronicaUquillas 6/11/2010 11:37'! 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. self noteClassStructure: oldClass! ! !ChangeSet methodsFor: 'change logging' stamp: 'GuillermoPolito 8/3/2012 13:24'! classAdded: anEvent self addClass: anEvent classAdded! ! !ChangeSet methodsFor: 'change logging' stamp: 'GuillermoPolito 8/3/2012 13:24'! classCommented: anEvent self commentClass: anEvent classCommented! ! !ChangeSet methodsFor: 'change logging' stamp: 'GuillermoPolito 8/3/2012 13:25'! classModified: anEvent self changeClass: anEvent newClassDefinition from: anEvent oldClassDefinition! ! !ChangeSet methodsFor: 'change logging' stamp: 'GuillermoPolito 8/3/2012 13:25'! classRecategorized: anEvent self changeClass: anEvent classRecategorized from: anEvent classRecategorized! ! !ChangeSet methodsFor: 'change logging' stamp: 'GuillermoPolito 8/3/2012 13:25'! classRemoved: anEvent self noteRemovalOf: anEvent classRemoved.! ! !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:26'! classReorganized: anEvent self reorganizeClass: anEvent classReorganized! ! !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: '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: 'change logging' stamp: 'GuillermoPolito 8/3/2012 14:14'! methodRecategorized: anEvent self reorganizeClass: anEvent methodClass! ! !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: '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: '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: 'change logging' stamp: 'VeronicaUquillas 6/11/2010 11:37'! 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. self noteClassStructure: class. 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: '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: '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: '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: '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: 'class changes' stamp: 'nk 6/26/2002 12:30'! containsClass: aClass ^ self changedClasses includes: aClass! ! !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: 'class changes' stamp: 'lr 3/14/2010 21:13'! noteClassForgotten: className "Remove from structures if class is not a superclass of some other one we are remembering" structures ifNil: [ ^ self ]. Smalltalk globals at: className ifPresent: [ :cls | cls subclasses do: [ :sub | (structures includesKey: sub) ifTrue: [ ^ self ] ] ]. "No delete" structures removeKey: className ifAbsent: [ ]! ! !ChangeSet methodsFor: 'class changes' stamp: 'dvf 9/27/2005 19:05'! noteClassStructure: aClass "Save the instance variable names of this class and all of its superclasses. Later we can tell how it changed and write a conversion method. The conversion method is used when old format objects are brought in from the disk from ImageSegment files (.extSeg) or SmartRefStream files (.obj .morph .bo .sp)." | clsName | aClass isBehavior ifFalse: [^ self]. structures ifNil: [structures := Dictionary new. superclasses := Dictionary new]. clsName := (aClass name asLowercase beginsWith: 'anobsolete') ifTrue: [(aClass name copyFrom: 11 to: aClass name size) asSymbol] ifFalse: [aClass name]. (structures includesKey: clsName) ifFalse: [ structures at: clsName put: ((Array with: aClass classVersion), (aClass allInstVarNames)). superclasses at: clsName put: aClass superclass name]. "up the superclass chain" aClass superclass ifNotNil: [self noteClassStructure: aClass superclass]. ! ! !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: 'class changes'! reorganizeClass: class "Include indication that a class was reorganized." self atClass: class add: #reorganize! ! !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: 'filein/out' stamp: 'MarcusDenker 8/25/2010 21:02'! assurePostscriptExists "Make sure there is a StringHolder holding the postscript. " "NOTE: FileIn recognizes the postscript by the line with Postscript: on it" postscript isNil ifTrue: [ 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: '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: 'filein/out' stamp: 'MiguelCoba 7/25/2009 02:16'! checkForAlienAuthorship "Check to see if there are any methods in the receiver that have author full name other than that of the current author, and open a browser on all found" | aList fullName | (fullName := Author fullNamePerSe) ifNil: [^ self inform: 'No author full name set in this image']. (aList := self methodsWithInitialsOtherThan: fullName) size > 0 ifFalse: [^ self inform: 'All methods in "', self name, '" have authoring stamps which start with "', fullName, '"'] ifTrue: [self systemNavigation browseMessageList: aList name: 'methods in "', self name, '" whose authoring stamps do not start with "', fullName, '"']! ! !ChangeSet methodsFor: 'filein/out' stamp: 'MiguelCoba 7/25/2009 02:17'! checkForAnyAlienAuthorship "Check to see if there are any versions of any methods in the receiver that have author full name other than that of the current author, and open a browser on all found" | aList fullName | (fullName := Author fullNamePerSe) ifNil: [^ self inform: 'No author full name set in this image']. (aList := self methodsWithAnyInitialsOtherThan: fullName) size > 0 ifFalse: [^ self inform: 'All versions of all methods in "', self name, '" have authoring stamps which start with "', fullName, '"'] ifTrue: [self systemNavigation browseMessageList: aList name: 'methods in "', self name, '" with any authoring stamps not starting with "', fullName, '"']! ! !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: '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: '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: '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: 'filein/out' stamp: 'nk 10/15/2003 09:55'! defaultChangeSetDirectory ^self class defaultChangeSetDirectory! ! !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: '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: '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: '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: '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: '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: '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: '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: 'filein/out' stamp: 'ar 7/16/2005 18:03'! postscript: aString "Answer the string representing the postscript. " postscript := aString! ! !ChangeSet methodsFor: 'filein/out' stamp: 'ar 7/16/2005 18:03'! postscriptString "Answer the string representing the postscript. " ^self postscript! ! !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: '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: 'ar 7/16/2005 18:00'! preamble: aString "Establish aString as the new contents of the preamble. " preamble := aString! ! !ChangeSet methodsFor: 'filein/out' stamp: 'ar 7/16/2005 18:00'! preambleString "Answer the string representing the preamble" ^self preamble! ! !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: '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: 'initialization' stamp: 'di 4/1/2000 12:00'! clear "Reset the receiver to be empty. " changeRecords := Dictionary new. preamble := nil. postscript := nil! ! !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: '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: '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: 'initialization' stamp: 'CamilloBruni 8/1/2012 16:18'! wither "The receiver is to be clobbered. Clear it out." self clear. name := nil! ! !ChangeSet methodsFor: 'method changes' stamp: 'sw 12/28/2000 18:08'! adoptSelector: aSelector forClass: aClass "Adopt the given selector/class combination as a change in the receiver" self noteNewMethod: (aClass methodDictionary at: aSelector) forClass: aClass selector: aSelector priorMethod: nil! ! !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: '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: '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: 'method changes' stamp: 'StephaneDucasse 8/1/2011 17:15'! messageListForChangesWhich: aBlock ifNone: ifEmptyBlock | answer | answer := self changedMessageList select: [ :each | aBlock value: each actualClass value: each selector ]. answer isEmpty ifTrue: [^ifEmptyBlock value]. ^answer ! ! !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: '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: '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: 'moving changes' stamp: 'lr 3/14/2010 21:13'! 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" | cls | (self changeRecorderFor: className) assimilateAllChangesIn: (otherChangeSet changeRecorderFor: className). (cls := Smalltalk globals classNamed: className) ifNotNil: [ self absorbStructureOfClass: cls from: otherChangeSet ]! ! !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: 'CamilloBruni 8/1/2012 15:57'! absorbStructureOfClass: aClass from: otherChangeSet "Absorb into the receiver all the structure and superclass info in the other change set. Used to write conversion methods." | sup next | otherChangeSet structures ifNil: [^ self]. (otherChangeSet structures includesKey: aClass name) ifFalse: [^ self]. structures ifNil: [structures := Dictionary new. superclasses := Dictionary new]. sup := aClass name. [(structures includesKey: sup) ifTrue: ["use what is here" true] ifFalse: [self flag: #noteToDan. "emergency workaround -- a case arose where the otherChangeSet's structures did not have the key, and it gummed up the works." (otherChangeSet structures includesKey: sup) ifTrue: [structures at: sup put: (otherChangeSet structures at: sup)]. next := otherChangeSet superclasses at: sup. superclasses at: sup put: next. (sup := next) = 'nil'] ] whileFalse. ! ! !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: '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: 'moving changes' stamp: 'di 4/4/2000 11:49'! expungeEmptyClassChangeEntries changeRecords keysAndValuesRemove: [:className :classRecord | classRecord hasNoChanges]! ! !ChangeSet methodsFor: 'moving changes' stamp: 'di 4/4/2000 12:40'! 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. " Old code... aChangeSet changedClassNames do: [:className | (cls := Smalltalk classNamed: className) ~~ nil ifTrue: [itsMethodChanges := aChangeSet methodChanges at: className ifAbsent: [Dictionary new]. itsMethodChanges associationsDo: [:assoc | self forgetChange: assoc value forSelector: assoc key class: cls]. myClassChange := self classChangeAt: className. myClassChange size > 0 ifTrue: [(aChangeSet classChangeAt: className) do: [:aChange | myClassChange remove: aChange ifAbsent: []]]. self noteClassForgotten: className]]. aChangeSet classRemoves do: [:className | (recorder := changeRecords at: className ifAbsent: []) ifNotNil: [recorder forgetClassRemoval]]. self expungeEmptyClassChangeEntries " ! ! !ChangeSet methodsFor: 'moving changes' stamp: 'di 4/4/2000 12:04'! forgetChangesForClass: className in: otherChangeSet "See forgetAllChangesFoundIn:. Used in culling changeSets." (self changeRecorderFor: className) forgetChangesIn: (otherChangeSet changeRecorderFor: className). self noteClassForgotten: className ! ! !ChangeSet methodsFor: 'moving changes' stamp: 'sw 3/5/1999 19:27'! hasPreamble ^ preamble notNil! ! !ChangeSet methodsFor: 'moving changes' stamp: 'nice 1/5/2010 15:59'! methodsWithAnyInitialsOtherThan: myInits "Return a collection of method refs whose author appears to be different from the given one, even historically" | slips | slips := Set 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: [ (aClass changeRecordsAt: mAssoc key) do: [ :chg | | aTimeStamp | aTimeStamp := chg stamp. (aTimeStamp notNil and: [(aTimeStamp beginsWith: myInits) not]) ifTrue: [slips add: aClass name , ' ' , mAssoc key]]]]]]. ^ slips! ! !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: '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: '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: 'moving changes' stamp: 'yo 8/30/2002 13:59'! 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: []. self noteClassForgotten: cname.! ! !ChangeSet methodsFor: 'moving changes' stamp: 'sw 3/5/1999 19:32'! removePreamble preamble := nil! ! !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: 'testing' stamp: 'StephaneDucasse 3/30/2010 23:02'! isNumbered "Answer whether a change set is numbered" ^ self name startsWithDigit! ! !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: 'testing' stamp: 'sw 8/3/1998 16:25'! okayToRemove ^ self okayToRemoveInforming: true! ! !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: '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 methodsFor: 'private' stamp: 'di 3/28/2000 14:40'! atClass: class add: changeType (self changeRecorderFor: class) noteChangeType: changeType fromClass: class! ! !ChangeSet methodsFor: 'private' stamp: 'di 4/1/2000 12:00'! atClass: class includes: changeType ^(changeRecords at: class name ifAbsent: [^false]) includesChangeType: changeType! ! !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: '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: '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: 'private' stamp: 'di 4/1/2000 12:00'! oldNameFor: class ^ (changeRecords at: class name) priorName! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ChangeSet class instanceVariableNames: 'current'! !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: '*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: '*System-FileRegistry' stamp: 'ar 7/15/2005 21:36'! services ^ Array with: self serviceFileIntoNewChangeSet! ! !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: 'current changeset' stamp: 'StephaneDucasse 12/19/2012 10:49'! current "return the current changeset assure first that we have a named changeset." current isMoribund ifTrue: [self newChanges: (self assuredChangeSetNamed: 'Unnamed') withOld: current] . ^ current! ! !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: '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: 'current changeset' stamp: 'sd 5/22/2003 22:18'! noChanges "Initialize the system ChangeSet." current initialize! ! !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: '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: 'defaults' stamp: 'dgd 9/6/2003 19:56'! defaultName ^ self uniqueNameLike: 'Unnamed' translated! ! !ChangeSet class methodsFor: 'defaults' stamp: 'StephaneDucasse 6/11/2012 18:04'! 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 ensureDirectory ]. choice = 3 ifTrue: [dir := UIManager default chooseDirectory. directoryPath := dir ifNil: [''] ifNotNil: [dir pathName]]]. self defaultChangeSetDirectory: directoryPath. ^ dir! ! !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: 'enumerating' stamp: 'ar 7/15/2005 21:20'! allChangeSetNames ^ self allChangeSets collect: [:c | c name]! ! !ChangeSet class methodsFor: 'enumerating' stamp: 'ar 7/15/2005 21:10'! allChangeSets "Return the list of all current ChangeSets" ^ AllChangeSets! ! !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: 'enumerating' stamp: 'ar 7/15/2005 21:17'! allChangeSets: aCollection "Return the list of all current ChangeSets" AllChangeSets := aCollection.! ! !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: '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: '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: '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: '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: '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: '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: '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: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: '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: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: 'filein/out' stamp: 'MarianoMartinezPeck 9/3/2012 12:39'! 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 select: [:each | (each inheritsFrom: SharedPool) not ])). ^ listInOrder ! ! !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: '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: 'filein/out' stamp: 'MarianoMartinezPeck 9/3/2012 12:35'! traitsOrder: aCollection "Arrange the traits in the collection, first who don't depend on others." | all 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: 'initialization' stamp: 'MarcusDenker 8/25/2010 21:02'! initialize "ChangeSet initialize" AllChangeSets isNil ifTrue: [ AllChangeSets := OrderedCollection new ]. self gatherChangeSets. FileServices registerFileReader: self! ! !ChangeSet class methodsFor: 'instance creation' stamp: 'di 4/6/2001 09:43'! basicNewNamed: aName ^ (self basicNew name: aName) initialize! ! !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: 'EstebanLorenzano 8/17/2012 16:40'! 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 := Scanner new scanTokens: item. 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: '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: '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: 'scanning' stamp: 'StephaneDucasse 5/28/2011 13:32'! scanVersionsOf: method class: class meta: meta category: cat selector: selector | position prevPos prevFileIndex preamble tokens sourceFilesCopy stamp changeList file | changeList := OrderedCollection new. position := method filePosition. sourceFilesCopy := SourceFiles collect:[:x | x ifNotNil:[x readOnlyCopy]]. method fileIndex = 0 ifTrue: [^ nil]. file := sourceFilesCopy at: method fileIndex. [position notNil & file notNil] whileTrue:[ file position: (0 max: position-150). "Skip back to before the preamble" preamble := method getPreambleFrom: file at: (0 max: position - 3). "Preamble is likely a linked method preamble, if we're in a changes file (not the sources file). Try to parse it for prior source position and file index" prevPos := nil. stamp := ''. (preamble findString: 'methodsFor:' startingAt: 1) > 0 ifTrue: [tokens := Scanner new scanTokens: preamble] ifFalse: [tokens := Array new "ie cant be back ref"]. ((tokens size between: 7 and: 8) and: [(tokens at: tokens size-5) = #methodsFor:]) ifTrue:[ (tokens at: tokens size-3) = #stamp: ifTrue:[ "New format gives change stamp and unified prior pointer" stamp := tokens at: tokens size-2. prevPos := tokens last. prevFileIndex := sourceFilesCopy fileIndexFromSourcePointer: prevPos. prevPos := sourceFilesCopy filePositionFromSourcePointer: prevPos. ] ifFalse: ["Old format gives no stamp; prior pointer in two parts" prevPos := tokens at: tokens size-2. prevFileIndex := tokens last. ]. (prevPos = 0 or: [prevFileIndex = 0]) ifTrue: [prevPos := nil] ]. ((tokens size between: 5 and: 6) and: [(tokens at: tokens size-3) = #methodsFor:]) ifTrue:[ (tokens at: tokens size-1) = #stamp: ifTrue: [ "New format gives change stamp and unified prior pointer" stamp := tokens at: tokens size. ] ]. changeList add: (ChangeRecord new file: file position: position type: #method class: class name category: cat meta: meta stamp: stamp). position := prevPos. prevPos notNil ifTrue:[file := sourceFilesCopy at: prevFileIndex]. ]. sourceFilesCopy do: [:x | x ifNotNil:[x close]]. ^changeList! ! !ChangeSet class methodsFor: 'services' stamp: 'StephaneDucasse 3/23/2010 21:27'! assuredChangeSetNamed: aName "Answer a change set of the given name. If one already exists, answer that, else create a new one and answer it." | existing | ^ (existing := self named: aName) ifNotNil: [existing] ifNil: [self basicNewChangeSet: aName]! ! !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: '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: '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: '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: '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: 'services' stamp: 'GuillermoPolito 5/5/2012 23:11'! 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. PreviousSet := oldChanges name. "so a Bumper update can find it" 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. "Transcript cr; show: 'File ', aName, ' successfully filed in to change set ', newName"]. aStream close] ensure: [self newChanges: oldChanges]. PreviousSet := nil. ^ newSet! ! !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: 'StephaneDucasse 6/11/2012 18:04'! defaultChangeSetDirectoryName ^ DefaultChangeSetDirectoryName ifNil: [DefaultChangeSetDirectoryName := '.']! ! !ChangeSet class methodsFor: 'settings' stamp: 'AlainPlantec 12/18/2009 14:14'! defaultChangeSetDirectoryName: aName DefaultChangeSetDirectoryName := aName! ! !ChangeSet class methodsFor: 'settings' stamp: 'AlainPlantec 12/7/2009 10:58'! mustCheckForSlips ^ MustCheckForSlips ifNil: [MustCheckForSlips := true]! ! !ChangeSet class methodsFor: 'settings' stamp: 'AlainPlantec 12/7/2009 10:58'! mustCheckForSlips: aBoolean MustCheckForSlips := aBoolean! ! !ChangeSet class methodsFor: 'system-events' stamp: 'GuillermoPolito 7/31/2012 11:59'! registerInterestToSystemAnnouncer self newChanges: self current.! ! TestCase subclass: #ChangeSetClassChangesTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Bugs'! !ChangeSetClassChangesTest commentStamp: 'dtl 2/19/2005 13:21' prior: 0! 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: '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: '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: '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'! 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: '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! ! ComposableModel subclass: #ChangeSorterApplication instanceVariableNames: 'model changesListModel classesListModel methodsListModel textModel prettyPrint showDiff prettyButton diffButton' classVariableNames: '' poolDictionaries: '' category: 'Spec-Tools-ChangeSorter'! !ChangeSorterApplication commentStamp: '' prior: 0! A ChangeSorterApplication is spec version of the dual sorter. ChangeSorterApplication new openWithSpec! !ChangeSorterApplication methodsFor: 'accessing'! changesListModel ^ changesListModel! ! !ChangeSorterApplication methodsFor: 'accessing'! classesListModel ^ classesListModel! ! !ChangeSorterApplication methodsFor: 'accessing'! methodsListModel ^ methodsListModel! ! !ChangeSorterApplication methodsFor: 'accessing'! model ^ model! ! !ChangeSorterApplication methodsFor: 'accessing'! textModel ^ textModel! ! !ChangeSorterApplication methodsFor: 'initialization' stamp: 'StephaneDucasse 12/18/2012 17:14'! initialize "Initialization code for ChangeSorterApplication" prettyPrint := false. showDiff := false. model := ChangeSorterModel new. SystemAnnouncer uniqueInstance weak on: CurrentChangeSetChanged do: [:each | self updateTitle]. super initialize. self initializeAnnouncements. ! ! !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: '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: 'initialization' stamp: 'BenjaminVanRyseghem 2/8/2013 14:08'! initializeWidgets self instantiateModels: #( methodsListModel ListComposableModel classesListModel ListComposableModel changesListModel ListComposableModel 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: '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: '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: 'initialization' stamp: 'StephaneDucasse 5/17/2012 19:32'! registerSelectorActions methodsListModel whenSelectedItemChanged: [:selector | self updateTextContents ]! ! !ChangeSorterApplication methodsFor: 'initialization'! setFocus self focusOrder add: changesListModel; add: classesListModel; add: methodsListModel; add: textModel.! ! !ChangeSorterApplication methodsFor: 'menu' stamp: 'EstebanLorenzano 1/31/2013 19:25'! 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 title: 'Change Set'; target: self. aMenu addAllFromPragma: 'changeSorterChangeSetList1Menu' target: self.! ! !ChangeSorterApplication methodsFor: 'menu' stamp: 'EstebanLorenzano 1/31/2013 19:25'! 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: 'menu' stamp: 'EstebanLorenzano 1/31/2013 14:36'! 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" self changeSetMenu1: aMenu shifted: isShifted. self changeSetMenu2: aMenu shifted: isShifted. ^ aMenu! ! !ChangeSorterApplication methodsFor: 'menu' stamp: 'EstebanLorenzano 1/31/2013 19:25'! 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' stamp: 'EstebanLorenzano 1/31/2013 19:25'! 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 target: self. aMenu addAllFromPragma:'changeSorterMessageListMenu' target: self. ^aMenu! ! !ChangeSorterApplication methodsFor: 'menu - change set'! addPreamble self model addPreambleTo: self selectedChangeSet. changesListModel setSelectedItem: self selectedChangeSet! ! !ChangeSorterApplication methodsFor: 'menu - change set'! 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 - change set'! editPostscript self selectedChangeSet editPostscript! ! !ChangeSorterApplication methodsFor: 'menu - change set'! fileOut self selectedChangeSet fileOut! ! !ChangeSorterApplication methodsFor: 'menu - change set'! findChangeSet | set | set := self model findChangeSetIn: self changeSets. changesListModel setSelectedItem: set.! ! !ChangeSorterApplication methodsFor: 'menu - change set'! newSet | aSet | self okToChange ifFalse: [ ^ self ]. aSet := self model createNewSet. aSet ifNotNil: [ self updateChangesList. changesListModel setSelectedItem: aSet ]! ! !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 - change set'! 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: 'menu - change set'! removePostscript self model removePostscriptFrom: self selectedChangeSet. changesListModel setSelectedItem: self selectedChangeSet! ! !ChangeSorterApplication methodsFor: 'menu - change set'! removePreamble self selectedChangeSet removePreamble. changesListModel setSelectedItem: self selectedChangeSet! ! !ChangeSorterApplication methodsFor: 'menu - change set'! rename | set | set := self model rename: self selectedChangeSet. changesListModel updateList; setSelectedItem: set! ! !ChangeSorterApplication methodsFor: 'menu - change set'! setCurrentChangeSet self model setCurrentChangeSet: self selectedChangeSet.! ! !ChangeSorterApplication methodsFor: 'menu - class'! fileOutClass self model fileOutClass: self selectedClass from: self selectedChangeSet! ! !ChangeSorterApplication methodsFor: 'menu - class'! 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: 'menu - class'! 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'! browseImplementorsOfMessages self model browseMessagesFrom: self selectedSelector! ! !ChangeSorterApplication methodsFor: 'menu - message'! 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: 'menu - message'! browseSendersOfMessages self model browseSendersOfMessagesFrom: self selectedSelector! ! !ChangeSorterApplication methodsFor: 'menu - message'! 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: 'menu - message'! 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 - message'! 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: 'menu - message'! 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: 'protocol' stamp: 'BenjaminVanRyseghem 12/19/2012 20:39'! changeSets ^ self changesListModel listItems! ! !ChangeSorterApplication methodsFor: 'protocol'! changesMenu: aBlock changesListModel menu: aBlock! ! !ChangeSorterApplication methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 2/8/2013 14:09'! changesModelOn: aShortcut do: aBlock changesListModel on: aShortcut do: aBlock! ! !ChangeSorterApplication methodsFor: 'protocol'! classesMenu: aBlock classesListModel menu: aBlock! ! !ChangeSorterApplication methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 2/8/2013 14:13'! classesOn: aShortcut do: aBlock classesListModel on:aShortcut do: aBlock! ! !ChangeSorterApplication methodsFor: 'protocol'! currentText ^ textModel getText! ! !ChangeSorterApplication methodsFor: 'protocol'! methodsMenu: aBlock methodsListModel menu: aBlock! ! !ChangeSorterApplication methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 2/8/2013 14:13'! methodsOn: aShortcut do: aBlock methodsListModel on: aShortcut do: aBlock! ! !ChangeSorterApplication methodsFor: 'protocol'! selectedChangeSet ^ changesListModel selectedItem! ! !ChangeSorterApplication methodsFor: 'protocol'! selectedChangeSetIndex ^ changesListModel selectedIndex! ! !ChangeSorterApplication methodsFor: 'protocol'! selectedClass ^ classesListModel selectedItem! ! !ChangeSorterApplication methodsFor: 'protocol'! selectedClassIndex ^ classesListModel selectedIndex! ! !ChangeSorterApplication methodsFor: 'protocol'! selectedSelector ^ methodsListModel selectedItem! ! !ChangeSorterApplication methodsFor: 'protocol'! selectorsMenu: aBlock methodsListModel menu: aBlock! ! !ChangeSorterApplication methodsFor: 'protocol'! setSelectedChangeSet: aChangeSet ^ changesListModel setSelectedItem: aChangeSet! ! !ChangeSorterApplication methodsFor: 'protocol'! setSelectedChangeSetIndex: anIndex ^ changesListModel setSelectedIndex: anIndex! ! !ChangeSorterApplication methodsFor: 'protocol'! setSelectedClass: aClass ^ classesListModel setSelectedItem: aClass! ! !ChangeSorterApplication methodsFor: 'protocol'! setSelectedClassIndex: anIndex ^ classesListModel setSelectedIndex: anIndex! ! !ChangeSorterApplication methodsFor: 'protocol' stamp: 'StephaneDucasse 11/2/2012 14:44'! title ^ super title, ' on: ', self model currentChangeSet name. ! ! !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: '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'! updateClassesListAndMessagesList | sel | sel := methodsListModel selectedItem. self updateClassesList. methodsListModel setSelectedItem: sel. self updateMessagesList.! ! !ChangeSorterApplication methodsFor: 'protocol'! 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-events' stamp: 'StephaneDucasse 5/17/2012 19:31'! whenChangesListChanges: aBlock changesListModel whenListChanged: aBlock! ! !ChangeSorterApplication methodsFor: 'shortcuts'! 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: 'shortcuts'! classShortcuts: event from: aMorph self selectedClass ifNotNil:[ event keyString = '' ifTrue: [ ^ self browseMethodFull ]. event keyString = '' ifTrue: [ ^ self forgetClass ]. event keyString = '' ifTrue: [ ^ self removeClass ]].! ! !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: 'shortcuts'! 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: 'shortcuts' stamp: 'BenjaminVanRyseghem 2/8/2013 14:01'! registerChangeSetShortcuts: aWidget aWidget on: $b command do: [ self selectedChangeSet ifNotNil:[ self browseChangeSet ]]. aWidget on: $b shift command do: [ self selectedChangeSet ifNotNil:[ self openChangeSetBrowser ]]. aWidget on: $m command do: [ self selectedChangeSet ifNotNil:[ self setCurrentChangeSet ]]. aWidget on: $n command do: [ self selectedChangeSet ifNotNil:[ self newSet ]]. aWidget on: $o command do: [ self selectedChangeSet ifNotNil:[ self fileOut ]]. aWidget on: $r command do: [ self selectedChangeSet ifNotNil:[ self rename ]]. aWidget on: $p command do: [ self selectedChangeSet ifNotNil:[ self addPreamble ]]. aWidget on: $x command do: [ self selectedChangeSet ifNotNil:[ self remove ]]. aWidget on: $f command do: [ self findChangeSet ]. ! ! !ChangeSorterApplication methodsFor: 'shortcuts' stamp: 'BenjaminVanRyseghem 2/8/2013 14:08'! registerClassShortcuts: aWidget aWidget on: $b command do: [ self selectedClass ifNotNil:[ self browseMethodFull ]]. aWidget on: $d command do: [ self selectedClass ifNotNil:[ self forgetClass ]]. aWidget on: $x command do: [ self selectedClass ifNotNil:[ self removeClass ]].! ! !ChangeSorterApplication methodsFor: 'shortcuts' stamp: 'BenjaminVanRyseghem 2/8/2013 14:07'! registerMethodShortcuts: aWidget aWidget on: $b command do: [ self selectedSelector ifNotNil:[ self browseMethodFull ]]. aWidget on: $d command do: [ self selectedSelector ifNotNil:[ self forgetMessage ]]. aWidget on: $m command do: [ self selectedSelector ifNotNil:[ self browseImplementorsOfMessages ]]. aWidget on: $n command do: [ self selectedSelector ifNotNil:[ self browseSendersOfMessages ]]. aWidget on: $v command do: [ self selectedSelector ifNotNil:[ self browseVersions ]]. aWidget on: $x command do: [ self selectedSelector ifNotNil:[ self removeMessage ]].! ! !ChangeSorterApplication methodsFor: 'private'! defaultTitle ^ 'Change Sorter'! ! !ChangeSorterApplication methodsFor: 'private'! forceChangesListRefresh | sel | sel := self selectedChangeSet. changesListModel items: self model allChanges. changesListModel setSelectedItem: sel.! ! !ChangeSorterApplication methodsFor: 'private'! 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 class instanceVariableNames: ''! !ChangeSorterApplication class methodsFor: 'menu' stamp: 'EstebanLorenzano 1/31/2013 18:29'! 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: 'EstebanLorenzano 1/31/2013 18:29'! 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: 'EstebanLorenzano 1/31/2013 18:29'! 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. ! ! !ChangeSorterApplication class methodsFor: 'menu' stamp: 'EstebanLorenzano 1/31/2013 18:30'! 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: '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: 'tools-registry' stamp: 'StephaneDucasse 7/4/2012 19:48'! registerToolsOn: registry "Add ourselves to registry. See [Smalltalk tools]" registry register: self as: #changeSorter! ! AbstractTool subclass: #ChangeSorterModel instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Spec-Tools-ChangeSorter'! !ChangeSorterModel commentStamp: '' prior: 0! A ChangeSorterModel is a model used by Change Sorter UIs for computation! !ChangeSorterModel methodsFor: 'change set'! addPreambleTo: aChangeSet aChangeSet assurePreambleExists! ! !ChangeSorterModel methodsFor: 'change set'! copyAllChangesFrom: source to: destination destination assimilateAllChangesFoundIn: source! ! !ChangeSorterModel methodsFor: 'change set'! createNewSet ^ ChangeSet newChangeSet.! ! !ChangeSorterModel methodsFor: 'change set' stamp: 'StephaneDucasse 11/2/2012 14:17'! currentChangeSet ^ ChangeSet current ! ! !ChangeSorterModel methodsFor: 'change set'! 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: [ ^ Beeper beep ]. 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'! 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: 'change set'! 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'! 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: [ ^ Beeper beep ]. (ChangeSet named: newName) ifNotNil: [ ^ UIManager default inform: 'Sorry that name is already used' ]. aChangeSet name: newName. ^ aChangeSet! ! !ChangeSorterModel methodsFor: 'change set' stamp: 'StephaneDucasse 11/2/2012 16:37'! setCurrentChangeSet: aChangeSet ChangeSet newChanges: aChangeSet. ! ! !ChangeSorterModel methodsFor: 'change set'! 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: 'change set'! substractFrom: source to: destination source forgetAllChangesFoundIn: destination.! ! !ChangeSorterModel methodsFor: 'class'! copyClass: aClass from: source to: destination destination absorbClass: aClass name 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: 'class'! removeClass: class from: changeSet changeSet removeClassChanges: class.! ! !ChangeSorterModel methodsFor: 'environment'! allChanges ^ ChangeSet allChangeSets reverse! ! !ChangeSorterModel methodsFor: 'message'! copySelector: selector inClass: class from: source to: destination destination absorbMethod: selector class: class from:source! ! !ChangeSorterModel methodsFor: 'message'! fileOutSelector: selector from: aClass aClass fileOutMethod: selector! ! !ChangeSorterModel methodsFor: 'message'! forgetSelector: selector inClass: aClass fromChangeSet: aChangeSet aChangeSet removeSelectorChanges: selector class: aClass! ! !ChangeSorterModel methodsFor: 'text'! buildChangeSetDescriptionFor: changeSet ^ changeSet ifNil: [ '' ] ifNotNil: [ changeSet preambleString ifNil: ['']]! ! !ChangeSorterModel methodsFor: 'text'! 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'! buildSelectorDescriptionFor: changeSet class: class selector: selector prettyPrint: prettyPrint showDiff: showDiff | changeType code | changeType := changeSet atSelector: selector class: class name. 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 prettyPrinterClass format: code in: class notifying: nil ]. showDiff ifTrue: [ code := self diffFromPriorSourceFor: code ]. ^ code asText makeSelectorBoldIn: class! ! !ChangeSorterModel methodsFor: 'text'! setContentsOfChangeSet: changeSet forClass: class andSelector: selector prettyPrint: prettyPrint showDiff: showDiff "return the source code that shows in the bottom pane" | strm changeType code | class ifNil: [ "Only the change set is currently selected" ^ self buildChangeSetDescriptionFor: changeSet ]. selector isNil ifTrue: [ "class is selected but not the selector" ^ self buildClassDescriptionFor: changeSet class: class ] ifFalse: [ "a class and a selector are selected" ^ self buildSelectorDescriptionFor: changeSet class: class selector: selector prettyPrint: prettyPrint showDiff: showDiff ]! ! ComposableModel subclass: #ChangesBrowser instanceVariableNames: 'acceptButton cancelButton pickList textArea' classVariableNames: '' poolDictionaries: '' category: 'NautilusRefactoring-Utilities'! !ChangesBrowser commentStamp: '' prior: 0! A ChangesBrowser is a browser used to browse a composite change wich gather all the wanted changes! !ChangesBrowser methodsFor: 'accessing'! acceptButton ^ acceptButton! ! !ChangesBrowser methodsFor: 'accessing'! cancelButton ^ cancelButton! ! !ChangesBrowser methodsFor: 'accessing'! pickList ^ pickList! ! !ChangesBrowser methodsFor: 'accessing'! textArea ^ textArea! ! !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: 'BenjaminVanRyseghem 6/11/2012 10:52'! initializeCancelButton cancelButton state: true; enabled: true; action: [ self cancel ]; label: 'Cancel'! ! !ChangesBrowser methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 2/22/2013 00:18'! initializePickList pickList labelClickable: false; defaultValue: true; blockToPerformOnWrappers: [:wrapper | wrapper on: WidgetBuilt send: #registerWidget: to: self ]; displayBlock: [ :item | item nameToDisplay ]! ! !ChangesBrowser methodsFor: 'initialization' stamp: 'CamilloBruni 10/9/2012 13:56'! initializePresenter pickList whenListChanged: [ pickList setSelectedIndex: 1; takeKeyboardFocus ]; whenSelectedItemChanged: [ :item | textArea text: (self buildDiffFor: item) ]! ! !ChangesBrowser methodsFor: 'initialization' stamp: 'CamilloBruni 2/23/2013 18:37'! initializeTextArea textArea enabled: false; "make sure we can cycle over the text field" on: Character tab shift do: [ self giveFocusToNextFrom: textArea ]; on: Character tab do: [ self giveFocusToPreviousFrom: textArea ].! ! !ChangesBrowser methodsFor: 'initialization' stamp: 'CamilloBruni 2/23/2013 18:36'! initializeWidgets self instantiateModels: #( cancelButton ButtonModel acceptButton ButtonModel pickList PickListModel textArea TextModel ). self initializeAcceptButton. self initializeCancelButton. self initializePickList. self initializeTextArea. self setFocus. self on: $s command do: [ self accept ]; on: Character escape do: [ self cancel ]! ! !ChangesBrowser methodsFor: 'initialization' stamp: 'CamilloBruni 10/8/2012 22:13'! setFocus self focusOrder add: pickList; add: textArea; add: acceptButton; add: cancelButton.! ! !ChangesBrowser methodsFor: 'initialization' stamp: 'CamilloBruni 10/8/2012 00:38'! setShortcuts self pickList attachKeymapCategory: #ChangesBrowserGlobalShortcuts targetting: self! ! !ChangesBrowser methodsFor: 'protocol'! accept self okToChange ifFalse: [ ^self ]. self pickedChanges do: [:change | RBRefactoryChangeManager instance performChange: change ]. window delete! ! !ChangesBrowser methodsFor: 'protocol'! buildDiffFor: aChange ^ aChange ifNil: [ '' ] ifNotNil: [ TextDiffBuilder buildDisplayPatchFrom: aChange oldVersionTextToDisplay to: aChange textToDisplay ].! ! !ChangesBrowser methodsFor: 'protocol'! cancel window delete! ! !ChangesBrowser methodsFor: 'protocol'! change: aCompositeChange pickList items: (aCompositeChange whatToDisplayIn: self)! ! !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: 'private' stamp: 'BenjaminVanRyseghem 2/22/2013 00:29'! labelClicked: anAnnouncement | wrapper index | wrapper := anAnnouncement source. index := pickList indexFor: wrapper model. pickList selectedIndex = index ifTrue: [ index := 0 ]. pickList setSelectedIndex: index.! ! !ChangesBrowser methodsFor: 'private' stamp: 'BenjaminVanRyseghem 2/6/2013 19:06'! pickedChanges ^ pickList selectedItems! ! !ChangesBrowser methodsFor: 'private' stamp: 'BenjaminVanRyseghem 2/22/2013 00:24'! registerWidget: anAnnouncement | widget | widget := anAnnouncement widget. widget announcer on: LabelClicked send: #labelClicked: to: self! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ChangesBrowser class instanceVariableNames: ''! !ChangesBrowser class methodsFor: 'instance creation'! changes: aCollection ^ self new changes: aCollection; yourself! ! !ChangesBrowser class methodsFor: 'shortcuts' stamp: 'CamilloBruni 10/8/2012 00:32'! buildShortcutsOn: aBuilder (aBuilder shortcut: #close) category: #ChangesBrowserGlobalShortcuts default: Character escape asShortcut 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: 'CamilloBruni 10/8/2012 21:47'! defaultSpec ^ SpecLayout composed newColumn: [:c | c add: #pickList; addSplitter; add: #textArea; newRow: [:r | r add: #acceptButton; add: #cancelButton] height: 25 ]! ! !ChangesBrowser class methodsFor: 'specs'! title ^ 'Changes Browser'! ! Object subclass: #ChangesLog instanceVariableNames: 'startupStamp' classVariableNames: 'DefaultInstance' poolDictionaries: '' category: 'System-Support'! !ChangesLog commentStamp: '' prior: 0! 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: 'accessing' stamp: 'GuillermoPolito 7/2/2012 12:25'! recordStartupStamp startupStamp := '----STARTUP----', Time dateAndTimeNow printString, ' as ', Smalltalk imagePath. ! ! !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:49'! logClassRenamed: annoucement annoucement classRenamed acceptsLoggingOfCompilation ifTrue: [ self logChange: '(Smalltalk globals at: #', annoucement oldName, ') rename: #', annoucement newName. ]. ! ! !ChangesLog methodsFor: 'event-listening' stamp: 'GuillermoPolito 8/3/2012 14:43'! logExpressionEvaluated: announcement self logChange: announcement expressionEvaluated.! ! !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: '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: 'logging' stamp: 'GuillermoPolito 7/2/2012 12:21'! logChange: aStringOrText "Write the argument, aString, onto the changes file." | aString changesFile | (SourceFiles isNil or: [(SourceFiles at: 2) == nil]) ifTrue: [^ 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: 'private' stamp: 'GuillermoPolito 7/2/2012 12:23'! assureStartupStampLogged "If there is a startup stamp not yet actually logged to disk, do it now." | changesFile | startupStamp ifNil: [^ self]. (SourceFiles isNil or: [(changesFile := SourceFiles at: 2) == nil]) ifTrue: [^ self]. changesFile isReadOnly ifTrue:[^self]. changesFile setToEnd; cr; cr. changesFile nextChunkPut: startupStamp asString; cr. startupStamp := nil. self forceChangesToDisk.! ! !ChangesLog methodsFor: 'private' stamp: 'GuillermoPolito 7/2/2012 12:23'! 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) ifTrue: [ changesFile flush. changesFile close. changesFile open: changesFile name forWrite: true. changesFile setToEnd. ]. ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ChangesLog class instanceVariableNames: ''! !ChangesLog class methodsFor: 'accessing' stamp: 'CamilleTeruel 7/30/2012 00:45'! default ^DefaultInstance ifNil: [ DefaultInstance := self new. DefaultInstance registerToAnnouncements ].! ! !ChangesLog class methodsFor: 'accessing' stamp: 'EstebanLorenzano 8/3/2012 14:07'! reset SystemAnnouncer uniqueInstance unsubscribe: DefaultInstance. DefaultInstance := nil.! ! Magnitude subclass: #Character instanceVariableNames: 'value' classVariableNames: 'CharacterTable DigitValues' poolDictionaries: '' category: 'Kernel-BasicObjects'! !Character commentStamp: 'ar 4/9/2005 22:35' prior: 0! 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: '*Collections-Abstract-splitjoin' stamp: 'onierstrasz 4/10/2009 22:51'! join: aSequenceableCollection ^ self asString join: aSequenceableCollection ! ! !Character methodsFor: '*Fuel' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^aGeneralMapper visitCharacter: self! ! !Character methodsFor: '*Fuel' stamp: 'MartinDias 12/30/2011 10:51'! serializeOn: anEncoder anEncoder encodeByte: value! ! !Character methodsFor: '*Keymapping-Shortcuts' stamp: 'CamilloBruni 3/18/2011 23:13'! alt ^ KMModifier alt + self! ! !Character methodsFor: '*Keymapping-Shortcuts' stamp: 'CamilloBruni 3/18/2011 23:16'! asShortcut ^ KMSingleKeyShortcut from: self! ! !Character methodsFor: '*Keymapping-Shortcuts' stamp: 'GuillermoPolito 5/31/2011 18:25'! command ^ KMModifier command + self! ! !Character methodsFor: '*Keymapping-Shortcuts' stamp: 'CamilloBruni 3/18/2011 22:57'! ctrl ^ KMModifier ctrl + self! ! !Character methodsFor: '*Keymapping-Shortcuts' stamp: 'CamilloBruni 3/18/2011 22:57'! shift ^ KMModifier shift + self! ! !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:02'! macRomanToUnicode "Convert the receiver from MacRoman Unicode." ^MacRomanTextConverter new unicodeToByte: self! ! !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: '*NECompletion' stamp: 'EstebanLorenzano 2/4/2013 18:37'! isCompletionCharacter ^ self isAlphaNumeric or: [ self = $: ]! ! !Character methodsFor: '*Text-Core' stamp: 'tk 9/4/2000 12:05'! asText ^ self asString asText! ! !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: 'accessing'! asciiValue "Answer the value of the receiver that represents its ascii encoding." ^value! ! !Character methodsFor: 'accessing' stamp: 'yo 12/29/2002 10:11'! charCode ^ (value bitAnd: 16r3FFFFF). ! ! !Character methodsFor: 'accessing' stamp: 'CamilloBruni 8/31/2011 12:22'! characterSet ^ EncodedCharSet charsetAt: self leadingChar! ! !Character methodsFor: 'accessing' stamp: 'CamilloBruni 8/31/2011 12:41'! codePoint "Just for ANSI Compliance" ^value! ! !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: '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: 'accessing' stamp: 'yo 12/29/2002 10:14'! leadingChar ^ (value bitAnd: (16r3FC00000)) bitShift: -22. ! ! !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: 'comparing'! < aCharacter "Answer true if the receiver's value < aCharacter's value." ^self asciiValue < aCharacter asciiValue! ! !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: 'comparing'! > aCharacter "Answer true if the receiver's value > aCharacter's value." ^self asciiValue > aCharacter asciiValue! ! !Character methodsFor: 'comparing'! hash "Hash is reimplemented because = is implemented." ^value! ! !Character methodsFor: 'converting' stamp: 'CamilloBruni 9/5/2011 20:06'! asCharacter "Answer the receiver itself." ^ 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: 'converting' stamp: 'CamilloBruni 9/5/2011 20:06'! asInteger "Answer the value of the receiver." ^ value! ! !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: 'converting' stamp: 'sma 3/11/2000 17:21'! asString ^ String with: self! ! !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: 'converting' stamp: 'CamilloBruni 9/5/2011 20:07'! asUnicode | table charset v | self leadingChar = 0 ifTrue: [^ value]. charset := self characterSet. charset isCharset ifFalse: [^ self charCode]. table := charset ucsTable. table isNil ifTrue: [^ 16rFFFD]. v := table at: self charCode + 1. v = -1 ifTrue: [^ 16rFFFD]. ^ v. ! ! !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: '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:16'! lowercase ^ self asLowercase! ! !Character methodsFor: 'converting'! to: other "Answer with a collection in ascii order -- $a to: $z" ^ (self asciiValue to: other asciiValue) collect: [:ascii | Character value: ascii]! ! !Character methodsFor: 'converting' stamp: 'CamilloBruni 8/31/2011 12:16'! uppercase ^ self asUppercase! ! !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: '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: '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: 'copying' stamp: 'tk 1/7/1999 16:50'! veryDeepCopyWith: deepCopier "Return self. I can't be copied."! ! !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: '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: '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: '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: '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: 'testing' stamp: 'CamilloBruni 8/31/2011 12:23'! canBeGlobalVarInitial ^ self characterSet canBeGlobalVarInitial: self. ! ! !Character methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2011 12:23'! canBeNonGlobalVarInitial ^ self characterSet canBeNonGlobalVarInitial: self. ! ! !Character methodsFor: 'testing'! isAlphaNumeric "Answer whether the receiver is a letter or a digit." ^self isLetter or: [self isDigit]! ! !Character methodsFor: 'testing' stamp: 'yo 8/28/2002 13:42'! isCharacter ^ true. ! ! !Character methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2011 12:23'! isDigit ^ self characterSet isDigit: self. ! ! !Character methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2011 12:23'! isLetter ^ self characterSet isLetter: self. ! ! !Character methodsFor: 'testing'! isLiteral ^true! ! !Character methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2011 12:23'! isLowercase ^ self characterSet isLowercase: self. ! ! !Character methodsFor: 'testing' stamp: 'yo 8/27/2002 15:18'! isOctetCharacter ^ value < 256. ! ! !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: 'testing'! 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: 'testing' stamp: 'di 4/3/1999 00:38'! isSpecial "Answer whether the receiver is one of the special characters" ^'+-/\*~<>=@,%|&?!!' includes: self! ! !Character methodsFor: 'testing' stamp: 'CamilloBruni 8/31/2011 12:23'! isUppercase ^ self characterSet isUppercase: self. ! ! !Character methodsFor: 'testing'! isVowel "Answer whether the receiver is one of the vowels, AEIOU, in upper or lower case." ^'AEIOU' includes: self asUppercase! ! !Character methodsFor: 'testing' stamp: 'ul 11/23/2010 13:28'! shouldBePrintedAsLiteral ^value between: 33 and: 255! ! !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: 'private' stamp: 'ar 4/9/2005 22:18'! setValue: newValue value ifNotNil:[^self error:'Characters are immutable']. value := newValue.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Character class instanceVariableNames: ''! !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:20'! arrowDown ^ self value: 31! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:20'! arrowLeft ^ self value: 28! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:20'! arrowRight ^ self value: 29! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:20'! arrowUp ^ self value: 30! ! !Character class methodsFor: 'accessing untypeable characters'! backspace "Answer the Character representing a backspace." ^self value: 8! ! !Character class methodsFor: 'accessing untypeable characters'! cr "Answer the Character representing a carriage return." ^self value: 13! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:19'! delete ^ self value: 127! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:21'! end ^ self value: 4! ! !Character class methodsFor: 'accessing untypeable characters'! enter "Answer the Character representing enter." ^self value: 3! ! !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: '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: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:21'! home ^ self value: 1! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:19'! insert ^ self value: 5! ! !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'! linefeed "Answer the Character representing a linefeed." ^self value: 10! ! !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'! newPage "Answer the Character representing a form feed." ^self value: 12! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'CamilloBruni 10/20/2012 23:51'! null ^ self value: 0! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:20'! pageDown ^ self value: 12! ! !Character class methodsFor: 'accessing untypeable characters' stamp: 'NS 7/11/2000 09:21'! pageUp ^ self value: 11! ! !Character class methodsFor: 'accessing untypeable characters'! space "Answer the Character representing a space." ^self value: 32! ! !Character class methodsFor: 'accessing untypeable characters'! tab "Answer the Character representing a tab." ^self value: 9! ! !Character class methodsFor: 'constants' stamp: 'rhi 9/8/2000 14:57'! alphabet "($a to: $z) as: String" ^ 'abcdefghijklmnopqrstuvwxyz' copy! ! !Character class methodsFor: 'constants'! characterTable "Answer the class variable in which unique Characters are stored." ^CharacterTable! ! !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: '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: '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: '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: 'StephaneDucasse 3/28/2010 17:41'! codePoint: anInteger "Just for ANSI Compliance" ^self value: anInteger ! ! !Character class methodsFor: 'instance creation'! 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: '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: 'instance creation'! new "Creating new characters is not allowed." self error: 'cannot create new characters'! ! !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: '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: 'private' stamp: 'lr 11/21/2005 17:24'! constantNameFor: aCharacter ^ self constantNames detect: [ :each | (self perform: each) = aCharacter ] ifNone: [ nil ].! ! !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).! ! Rectangle subclass: #CharacterBlock instanceVariableNames: 'stringIndex text textLine' classVariableNames: '' poolDictionaries: 'TextConstants' category: 'Text-Scanning'! !CharacterBlock commentStamp: 'StephaneDucasse 5/18/2010 16:00' prior: 0! 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: 'accessing'! stringIndex "Answer the position of the receiver in the string it indexes." ^stringIndex! ! !CharacterBlock methodsFor: 'accessing' stamp: 'di 12/2/97 14:33'! textLine ^ textLine! ! !CharacterBlock methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! textLine: aLine textLine := aLine! ! !CharacterBlock methodsFor: 'comparing'! < aCharacterBlock "Answer whether the string index of the receiver precedes that of aCharacterBlock." ^stringIndex < aCharacterBlock stringIndex! ! !CharacterBlock methodsFor: 'comparing'! <= aCharacterBlock "Answer whether the string index of the receiver does not come after that of aCharacterBlock." ^(self > aCharacterBlock) not! ! !CharacterBlock methodsFor: 'comparing'! = aCharacterBlock self species = aCharacterBlock species ifTrue: [^stringIndex = aCharacterBlock stringIndex] ifFalse: [^false]! ! !CharacterBlock methodsFor: 'comparing'! > aCharacterBlock "Answer whether the string index of the receiver comes after that of aCharacterBlock." ^aCharacterBlock < self! ! !CharacterBlock methodsFor: 'comparing'! >= 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'! max: aCharacterBlock aCharacterBlock ifNil:[^self]. ^aCharacterBlock > self ifTrue:[ aCharacterBlock] ifFalse:[self].! ! !CharacterBlock methodsFor: 'comparing' stamp: 'th 9/17/2002 11:54'! min: aCharacterBlock aCharacterBlock ifNil:[^self]. ^aCharacterBlock < self ifTrue:[ aCharacterBlock] ifFalse:[self].! ! !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: '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: '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! ! CharacterScanner subclass: #CharacterBlockScanner instanceVariableNames: 'characterPoint characterIndex lastCharacter lastCharacterExtent lastSpaceOrTabExtent nextLeftMargin specialWidth' classVariableNames: '' poolDictionaries: '' category: 'Text-Scanning'! !CharacterBlockScanner commentStamp: '' prior: 0! My instances are used to scan text to compute the CharacterBlock for a character specified by its index in the text or its proximity to the cursor location.! !CharacterBlockScanner methodsFor: 'scanning' stamp: 'nk 11/22/2004 14:32'! characterBlockAtPoint: aPoint index: index in: textLine "This method is the Morphic characterBlock finder. It combines MVC's characterBlockAtPoint:, -ForIndex:, and buildCharcterBlock:in:" | runLength lineStop done 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]. (text isEmpty or: [(characterPoint y < line top or: [characterPoint x < line left]) or: [characterIndex notNil and: [characterIndex < line first]]]) ifTrue: [^ (CharacterBlock new stringIndex: line first text: text topLeft: line leftMargin@line top extent: 0 @ textStyle lineGrid) textLine: line]. destX := leftMargin := line leftMarginForAlignment: alignment. destY := line top. runLength := text runLengthFor: line first. characterIndex ifNotNil: [lineStop := characterIndex "scanning for index"] ifNil: [lineStop := line last "scanning for point"]. runStopIndex := lastIndex + (runLength - 1) min: lineStop. lastCharacterExtent := 0 @ line lineHeight. spaceCount := 0. done := false. [done] whileFalse: [stopCondition := self scanCharactersFrom: lastIndex to: runStopIndex in: text string rightX: characterPoint x stopConditions: stopConditions kern: kern. "see setStopConditions for stopping conditions for character block operations." self lastCharacterExtentSetX: (specialWidth ifNil: [font widthOf: (text at: lastIndex)] ifNotNil: [specialWidth]). (self perform: stopCondition) ifTrue: [characterIndex ifNil: [ "Result for characterBlockAtPoint: " (stopCondition ~~ #cr and: [ lastIndex == line last and: [ aPoint x > ((characterPoint x) + (lastCharacterExtent x / 2)) ]]) ifTrue: [ "Correct for right half of last character in line" ^ (CharacterBlock new stringIndex: lastIndex + 1 text: text topLeft: characterPoint + (lastCharacterExtent x @ 0) + (font descentKern @ 0) extent: 0 @ lastCharacterExtent y) textLine: line ]. ^ (CharacterBlock new stringIndex: lastIndex text: text topLeft: characterPoint + (font descentKern @ 0) extent: lastCharacterExtent - (font baseKern @ 0)) textLine: line] ifNotNil: ["Result for characterBlockForIndex: " ^ (CharacterBlock new stringIndex: characterIndex text: text topLeft: characterPoint + ((font descentKern) - kern @ 0) extent: lastCharacterExtent) textLine: line]]]! ! !CharacterBlockScanner methodsFor: 'scanning' stamp: 'lr 7/4/2009 10:42'! indentationLevel: anInteger super indentationLevel: anInteger. nextLeftMargin := leftMargin. indentationLevel timesRepeat: [ nextLeftMargin := textStyle nextTabXFrom: nextLeftMargin leftMargin: leftMargin rightMargin: rightMargin ]! ! !CharacterBlockScanner methodsFor: 'scanning' stamp: 'lr 7/4/2009 10:42'! placeEmbeddedObject: anchoredMorph "Workaround: The following should really use #textAnchorType" anchoredMorph relativeTextAnchorPosition ifNotNil: [ ^ true ]. (super placeEmbeddedObject: anchoredMorph) ifFalse: [ ^ false ]. specialWidth := anchoredMorph width. ^ true! ! !CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'nice 11/30/2009 23:04'! 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. lastCharacter := nil. 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]. self lastCharacterExtentSetX: 0. ^ true ]. lastCharacter := CR. characterPoint := destX @ destY. self lastCharacterExtentSetX: rightMargin - destX. ^ true! ! !CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'tween 4/6/2007 12:49'! crossedX "Text display has wrapping. The scanner just found a character past the x location of the cursor. We know that the cursor is pointing at a character or before one." | leadingTab currentX | characterIndex == nil ifFalse: [ "If the last character of the last line is a space, and it crosses the right margin, then locating the character block after it is impossible without this hack." characterIndex > text size ifTrue: [ lastIndex := characterIndex. characterPoint := (nextLeftMargin ifNil: [leftMargin]) @ (destY + line lineHeight). ^true]]. characterPoint x <= (destX + (lastCharacterExtent x // 2)) ifTrue: [lastCharacter := (text at: lastIndex). characterPoint := destX @ destY. ^true]. lastIndex >= line last ifTrue: [lastCharacter := (text at: line last). characterPoint := destX @ destY. ^true]. "Pointing past middle of a character, return the next character." lastIndex := lastIndex + 1. lastCharacter := text at: lastIndex. currentX := destX + lastCharacterExtent x + kern. self lastCharacterExtentSetX: (font widthOf: lastCharacter). characterPoint := currentX @ destY. lastCharacter = Space ifFalse: [^ true]. "Yukky if next character is space or tab." alignment = Justified ifTrue: [self lastCharacterExtentSetX: (lastCharacterExtent x + (line justifiedPadFor: (spaceCount + 1) font: font)). ^ true]. true ifTrue: [^ true]. "NOTE: I find no value to the following code, and so have defeated it - DI" "See tabForDisplay for illumination on the following awfulness." leadingTab := true. line first to: lastIndex - 1 do: [:index | (text at: index) ~= Tab ifTrue: [leadingTab := false]]. (alignment ~= Justified or: [leadingTab]) ifTrue: [self lastCharacterExtentSetX: (textStyle nextTabXFrom: currentX leftMargin: leftMargin rightMargin: rightMargin) - currentX] ifFalse: [self lastCharacterExtentSetX: (((currentX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount))) - currentX) max: 0)]. ^ true! ! !CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'lr 7/4/2009 10:42'! 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). characterIndex ~~ nil ifTrue: [ lineStop := characterIndex "scanning for index" ] ifFalse: [ lineStop := line last "scanning for point" ]. (runStopIndex := lastIndex + (runLength - 1)) > lineStop ifTrue: [ runStopIndex := lineStop ]. self setStopConditions. ^ false ]. lastCharacter := text at: lastIndex. characterPoint := destX @ destY. ((lastCharacter = Space and: [ alignment = Justified ]) or: [ lastCharacter = Tab and: [ lastSpaceOrTabExtent notNil ] ]) ifTrue: [ lastCharacterExtent := lastSpaceOrTabExtent ]. 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: [ self characterPointSetX: destX - lastCharacterExtent x. ^ 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. lastCharacter := nil. self lastCharacterExtentSetX: 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. lastCharacter := nil. self lastCharacterExtentSetX: 0. ^ true ]. "just off end of line without crossing x" lastIndex := lastIndex + 1. ^ true! ! !CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'tween 4/6/2007 12:50'! paddedSpace "When the line is justified, the spaces will not be the same as the font's space character. A padding of extra space must be considered in trying to find which character the cursor is pointing at. Answer whether the scanning has crossed the cursor." | pad | pad := 0. spaceCount := spaceCount + 1. pad := line justifiedPadFor: spaceCount font: font. lastSpaceOrTabExtent := lastCharacterExtent copy. self lastSpaceOrTabExtentSetX: spaceWidth + pad. (destX + lastSpaceOrTabExtent x) >= characterPoint x ifTrue: [lastCharacterExtent := lastSpaceOrTabExtent copy. ^self crossedX]. lastIndex := lastIndex + 1. destX := destX + lastSpaceOrTabExtent x. ^ false ! ! !CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'lr 7/4/2009 10:42'! setFont specialWidth := nil. super setFont! ! !CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'ar 10/18/2004 14:30'! setStopConditions "Set the font and the stop conditions for the current run." self setFont. self setConditionArray: (alignment = Justified ifTrue: [#paddedSpace]). ! ! !CharacterBlockScanner methodsFor: 'stop conditions' stamp: 'nice 4/19/2011 00:20'! tab | currentX | currentX := (alignment = Justified and: [ self leadingTab not ]) ifTrue: [ "imbedded tabs in justified text are weird" destX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX ] ifFalse: [ textStyle nextTabXFrom: destX leftMargin: leftMargin rightMargin: rightMargin ]. lastSpaceOrTabExtent := lastCharacterExtent copy. self lastSpaceOrTabExtentSetX: (currentX - destX max: 0). currentX >= characterPoint x ifTrue: [ lastCharacterExtent := lastSpaceOrTabExtent copy. ^ self crossedX ]. destX := currentX. lastIndex := lastIndex + 1. ^ false! ! !CharacterBlockScanner methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! characterPointSetX: xVal characterPoint := xVal @ characterPoint y! ! !CharacterBlockScanner methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! lastCharacterExtentSetX: xVal lastCharacterExtent := xVal @ lastCharacterExtent y! ! !CharacterBlockScanner methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! lastSpaceOrTabExtentSetX: xVal lastSpaceOrTabExtent := xVal @ lastSpaceOrTabExtent y! ! Object subclass: #CharacterScanner instanceVariableNames: 'destX lastIndex xTable destY stopConditions text textStyle alignment leftMargin rightMargin font line runStopIndex spaceCount spaceWidth emphasisCode kern indentationLevel wantsColumnBreaks pendingKernX' classVariableNames: 'DefaultStopConditions NilCondition PaddedSpaceCondition SpaceCondition' poolDictionaries: 'TextConstants' category: 'Text-Scanning'! !CharacterScanner commentStamp: '' prior: 0! My instances hold the state associated with scanning text. My subclasses scan characters for specified purposes, such as computing a CharacterBlock or placing characters into Forms.! !CharacterScanner methodsFor: 'initialize' stamp: 'MarcusDenker 11/20/2012 10:04'! initialize super initialize. destX := destY := leftMargin := 0. wantsColumnBreaks := false.! ! !CharacterScanner methodsFor: 'initialize' stamp: 'ul 3/8/2010 04:44'! initializeStringMeasurer stopConditions := TextStopConditions new ! ! !CharacterScanner methodsFor: 'initialize' stamp: 'lr 7/4/2009 10:42'! wantsColumnBreaks: aBoolean wantsColumnBreaks := aBoolean! ! !CharacterScanner methodsFor: 'scanner methods' stamp: 'tween 4/6/2007 11:16'! columnBreak pendingKernX := 0. ^true! ! !CharacterScanner methodsFor: 'scanner methods' stamp: 'yo 12/18/2002 12:32'! isBreakableAtIndex: index ^ (EncodedCharSet at: ((text at: index) leadingChar + 1)) isBreakableAt: index in: text. ! ! !CharacterScanner methodsFor: 'scanner methods' stamp: 'MarcusDenker 7/9/2012 21:43'! scanJapaneseCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta | ascii encoding f nextDestX maxAscii startEncoding | lastIndex := startIndex. lastIndex > stopIndex ifTrue: [ lastIndex := stopIndex. ^ stops endOfRun ]. startEncoding := (sourceString at: startIndex) leadingChar. font ifNil: [ font := (TextSharedInformation at: #DefaultMultiStyle) fontArray at: 1 ]. (font isFontSet) ifTrue: [ maxAscii := font maxAsciiFor: startEncoding. f := font fontArray at: startEncoding + 1. "xTable := f xTable. maxAscii := xTable size - 2." spaceWidth := f widthOf: Space ] ifFalse: [ maxAscii := font maxAscii ]. [ lastIndex <= stopIndex ] whileTrue: [ encoding := (sourceString at: lastIndex) leadingChar. encoding ~= startEncoding ifTrue: [ lastIndex := lastIndex - 1. ^ stops endOfRun ]. ascii := (sourceString at: lastIndex) charCode. ascii > maxAscii ifTrue: [ ascii := maxAscii ]. (encoding = 0 and: [ascii < stops size and: [ (stopConditions at: ascii + 1) ~~ nil ]]) ifTrue: [ ^ stops at: ascii + 1 ]. nextDestX := destX + (font widthOf: (sourceString at: lastIndex)). nextDestX > rightX ifTrue: [ ^ stops crossedX ]. destX := nextDestX + kernDelta. "destX printString displayAt: 0@(lastIndex*20)." lastIndex := lastIndex + 1 ]. lastIndex := stopIndex. ^ stops endOfRun! ! !CharacterScanner methodsFor: 'scanner methods' stamp: 'MarcusDenker 7/9/2012 21:43'! scanMultiCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta | ascii encoding f nextDestX maxAscii startEncoding | lastIndex := startIndex. lastIndex > stopIndex ifTrue: [ lastIndex := stopIndex. ^ stops endOfRun ]. startEncoding := (sourceString at: startIndex) leadingChar. font ifNil: [ font := (TextSharedInformation at: #DefaultMultiStyle) fontArray at: 1 ]. font isFontSet ifTrue: [ maxAscii := font maxAsciiFor: startEncoding. f := font fontArray at: startEncoding + 1. spaceWidth := f widthOf: Space ] ifFalse: [ maxAscii := font maxAscii ]. [ lastIndex <= stopIndex ] whileTrue: [ encoding := (sourceString at: lastIndex) leadingChar. encoding ~= startEncoding ifTrue: [ lastIndex := lastIndex - 1. ^ stops endOfRun ]. ascii := (sourceString at: lastIndex) charCode. ascii > maxAscii ifTrue: [ ascii := maxAscii ]. (encoding = 0 and: [ascii < stops size and: [ (stopConditions at: ascii + 1) ~~ nil ]]) ifTrue: [ ^ stops at: ascii + 1 ]. nextDestX := destX + (font widthOf: (sourceString at: lastIndex)). nextDestX > rightX ifTrue: [ ^ stops crossedX ]. destX := nextDestX + kernDelta. "destX printString displayAt: 0@(lastIndex*20)." lastIndex := lastIndex + 1 ]. lastIndex := stopIndex. ^ stops endOfRun! ! !CharacterScanner methodsFor: 'scanner methods' stamp: 'tween 4/6/2007 09:59'! setFont | priorFont | "Set the font and other emphasis." priorFont := font. text == nil ifFalse:[ emphasisCode := 0. kern := 0. indentationLevel := 0. alignment := textStyle alignment. font := nil. (text attributesAt: lastIndex forStyle: textStyle) do: [:att | att emphasizeScanner: self]]. font == nil ifTrue: [self setFont: textStyle defaultFontIndex]. font := font emphasized: emphasisCode. priorFont ifNotNil: [ font = priorFont ifTrue:[ "font is the same, perhaps the color has changed? We still want kerning between chars of the same font, but of different color. So add any pending kern to destX" destX := destX + (pendingKernX ifNil:[0])]. destX := destX + priorFont descentKern]. pendingKernX := 0. "clear any pending kern so there is no danger of it being added twice" destX := destX - font descentKern. "NOTE: next statement should be removed when clipping works" leftMargin ifNotNil: [destX := destX max: leftMargin]. kern := kern - font baseKern. "Install various parameters from the font." spaceWidth := font widthOf: Space. xTable := font xTable. stopConditions := DefaultStopConditions.! ! !CharacterScanner methodsFor: 'scanning' stamp: 'BenjaminVanRyseghem 2/19/2013 17:18'! basicScanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta "Primitive. This is the inner loop of text display--but see scanCharactersFrom: to:rightX: which would get the string, stopConditions and displaying from the instance. March through source String from startIndex to stopIndex. If any character is flagged with a non-nil entry in stops, then return the corresponding value. Determine width of each character from xTable, indexed by map. If dextX would exceed rightX, then return stops at: 258. Advance destX by the width of the character. If stopIndex has been reached, then return stops at: 257. Optional. See Object documentation whatIsAPrimitive." | ascii nextDestX char floatDestX widthAndKernedWidth nextChar atEndOfRun | lastIndex := startIndex. floatDestX := destX. widthAndKernedWidth := Array new: 2. atEndOfRun := false. [lastIndex <= stopIndex] whileTrue: [char := (sourceString at: lastIndex). ascii := char asciiValue + 1. (stops at: ascii) == nil ifFalse: [^stops at: ascii]. "Note: The following is querying the font about the width since the primitive may have failed due to a non-trivial mapping of characters to glyphs or a non-existing xTable." nextChar := (lastIndex + 1 <= stopIndex) ifTrue:[sourceString at: lastIndex + 1] ifFalse:[ atEndOfRun := true. "if there is a next char in sourceString, then get the kern and store it in pendingKernX" lastIndex + 1 <= sourceString size ifTrue:[sourceString at: lastIndex + 1] ifFalse:[ nil]]. font widthAndKernedWidthOfLeft: char right: nextChar into: widthAndKernedWidth. nextDestX := floatDestX + (widthAndKernedWidth at: 1). nextDestX > rightX ifTrue: [^stops crossedX]. floatDestX := floatDestX + kernDelta + (widthAndKernedWidth at: 2). atEndOfRun ifTrue:[ pendingKernX := (widthAndKernedWidth at: 2) - (widthAndKernedWidth at: 1). floatDestX := floatDestX - pendingKernX]. destX := floatDestX. lastIndex := lastIndex + 1]. lastIndex := stopIndex. ^stops endOfRun! ! !CharacterScanner methodsFor: 'scanning' stamp: 'lr 7/4/2009 10:42'! embeddedObject | savedIndex | savedIndex := lastIndex. text attributesAt: lastIndex do: [ :attr | attr anchoredMorph ifNotNil: [ "Following may look strange but logic gets reversed. If the morph fits on this line we're not done (return false for true) and if the morph won't fit we're done (return true for false)" (self placeEmbeddedObject: attr anchoredMorph) ifFalse: [ ^ true ] ] ]. lastIndex := savedIndex + 1. "for multiple(!!) embedded morphs" ^ false! ! !CharacterScanner methodsFor: 'scanning' stamp: 'hmm 7/15/2000 22:40'! handleIndentation self indentationLevel timesRepeat: [ self plainTab]! ! !CharacterScanner methodsFor: 'scanning' 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: 'lr 7/4/2009 10:42'! indentationLevel: anInteger "set the number of tabs to put at the beginning of each line" indentationLevel := anInteger! ! !CharacterScanner methodsFor: 'scanning' 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: 'lr 7/4/2009 10:42'! measureString: aString inFont: aFont from: startIndex to: stopIndex "WARNING: In order to use this method the receiver has to be set up using #initializeStringMeasurer" destX := destY := lastIndex := 0. xTable := aFont xTable. self scanCharactersFrom: startIndex to: stopIndex in: aString rightX: 999999 stopConditions: stopConditions kern: 0. ^ destX! ! !CharacterScanner methodsFor: 'scanning' stamp: 'lr 7/4/2009 10:42'! placeEmbeddedObject: anchoredMorph "Place the anchoredMorph or return false if it cannot be placed. In any event, advance destX by its width." "Workaround: The following should really use #textAnchorType" | w | anchoredMorph relativeTextAnchorPosition ifNotNil: [ ^ true ]. destX := destX + (w := anchoredMorph width). (destX > rightMargin and: [ leftMargin + w <= rightMargin ]) ifTrue: [ "Won't fit, but would on next line" ^ false ]. lastIndex := lastIndex + 1. self setFont. "Force recalculation of emphasis for next run" ^ true! ! !CharacterScanner methodsFor: 'scanning' stamp: 'nice 3/16/2010 20:38'! plainTab "This is the basic method of adjusting destX for a tab." destX := (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: 'scanning' stamp: 'nice 3/6/2010 14:47'! scanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta | startEncoding selector | sourceString isByteString ifTrue: [ ^ self basicScanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta ]. sourceString isWideString ifTrue: [ startIndex > stopIndex ifTrue: [ lastIndex := stopIndex. ^ stops endOfRun ]. startEncoding := (sourceString at: startIndex) leadingChar. selector := (EncodedCharSet charsetAt: startEncoding) scanSelector. ^ self perform: selector withArguments: (Array with: startIndex with: stopIndex with: sourceString with: rightX with: stops with: kernDelta) ]. ^ stops endOfRun! ! !CharacterScanner methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! addEmphasis: code "Set the bold-ital-under-strike emphasis." emphasisCode := emphasisCode bitOr: code! ! !CharacterScanner methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! addKern: kernDelta "Set the current kern amount." kern := kern + kernDelta! ! !CharacterScanner methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! setActualFont: aFont "Set the basal font to an isolated font reference." font := aFont! ! !CharacterScanner methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! setAlignment: style alignment := style! ! !CharacterScanner methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! setConditionArray: aSymbol aSymbol == #paddedSpace ifTrue: [ ^ stopConditions := PaddedSpaceCondition copy ]. aSymbol == #space ifTrue: [ ^ stopConditions := SpaceCondition copy ]. aSymbol == nil ifTrue: [ ^ stopConditions := NilCondition copy ]. self error: 'undefined stopcondition for space character'! ! !CharacterScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:28'! setFont: fontNumber "Set the font by number from the textStyle." self setActualFont: (textStyle fontAt: fontNumber)! ! !CharacterScanner methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! text: t textStyle: ts text := t. textStyle := ts! ! !CharacterScanner methodsFor: 'private' stamp: 'ar 1/8/2000 14:28'! textColor: ignored "Overridden in DisplayScanner"! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CharacterScanner class instanceVariableNames: ''! !CharacterScanner class methodsFor: 'class initialization' stamp: 'nice 3/8/2010 11:51'! initialize " CharacterScanner initialize " | a | a := TextStopConditions new. 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. NilCondition := a copy. DefaultStopConditions := a copy. PaddedSpaceCondition := a copy. PaddedSpaceCondition at: Space asciiValue + 1 put: #paddedSpace. SpaceCondition := a copy. SpaceCondition at: Space asciiValue + 1 put: #space. ! ! Collection subclass: #CharacterSet instanceVariableNames: 'map' classVariableNames: 'CrLf' poolDictionaries: '' category: 'Collections-Support'! !CharacterSet commentStamp: '' prior: 0! A set of characters. Lookups for inclusion are very fast.! !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: '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: '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: '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: '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: '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 5/9/2006 23:02'! size ^map sum! ! !CharacterSet methodsFor: 'comparison' stamp: 'tk 7/5/2001 21:58'! = anObject ^self species == anObject species and: [ self byteArrayMap = anObject byteArrayMap ]! ! !CharacterSet methodsFor: 'comparison' stamp: 'ls 8/17/1998 20:46'! hash ^self byteArrayMap hash! ! !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: '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: '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 methodsFor: 'testing' stamp: 'nice 5/9/2006 23:23'! hasWideCharacters ^false! ! !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: 'alain.plantec 5/28/2009 09:44'! initialize super initialize. map := ByteArray new: 256 withAll: 0.! ! !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 class instanceVariableNames: ''! !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/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: '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/18/1998 00:40'! nonSeparators "return a set containing everything but the whitespace characters" ^self separators complement! ! !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! ! Collection subclass: #CharacterSetComplement instanceVariableNames: 'absent byteArrayMapCache' classVariableNames: '' poolDictionaries: '' category: 'Collections-Support'! !CharacterSetComplement commentStamp: 'nice 8/31/2008 14:53' prior: 0! 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: '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: '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 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: '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'! reject: aBlock "Implementation note: rejecting present is selecting absent" ^(absent select: aBlock) 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: 'nice 12/10/2009 19:20'! remove: aCharacter ifAbsent: aBlock (self includes: aCharacter) ifFalse: [^aBlock value]. ^self remove: aCharacter! ! !CharacterSetComplement methodsFor: 'collection ops' stamp: 'MarianoMartinezPeck 9/22/2011 17:16'! removeAll self becomeForward: CharacterSet new! ! !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: 'collection ops' stamp: 'nice 3/23/2007 02:10'! size "Is this 2**32-absent size ?" ^self shouldNotImplement! ! !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: 'comparing' stamp: 'marcus.denker 8/11/2008 20:45'! hash ^absent hash bitXor: self class hash! ! !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: 'copying' stamp: 'nice 10/5/2009 08:52'! postCopy super postCopy. absent := absent copy! ! !CharacterSetComplement methodsFor: 'initialization' stamp: 'nice 8/31/2008 14:56'! complement: aCharacterSet "initialize with the complement" byteArrayMapCache := nil. absent := aCharacterSet. ! ! !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: '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: '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: '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 class instanceVariableNames: ''! !CharacterSetComplement class methodsFor: 'instance creation' stamp: 'nice 3/23/2007 02:25'! of: aCharacterSet "answer the complement of aCharacterSet" ^ super new complement: aCharacterSet! ! TestCase subclass: #CharacterSetTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Support'! !CharacterSetTest commentStamp: 'nice 11/20/2007 00:35' prior: 0! 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'.! ! ClassTestCase subclass: #CharacterTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Strings'! !CharacterTest commentStamp: '' prior: 0! 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/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: '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' stamp: 'StephaneDucasse 7/31/2010 19:40'! testHex self assert: $a hex = '16r61'. self assert: Character space hex = '16r20'! ! !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' stamp: 'lr 11/21/2005 17:41'! testPrintStringAll Character allCharacters do: [ :each | self assert: (self class compilerClass evaluate: each printString) = each ].! ! !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: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' stamp: 'lr 11/21/2005 17:24'! testStoreStringAll Character allCharacters do: [ :each | self assert: (self class compilerClass evaluate: each storeString) = each ].! ! !CharacterTest methodsFor: 'tests - various' stamp: 'nice 11/1/2011 17:34'! testCharacterSeparators "Regression test" | result | self shouldnt: [result := '/', Character separators] raise: Error. self assert: result size = (Character separators size + 1). ! ! !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 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 instance creation' stamp: 'GabrielOmarCotelli 5/29/2009 23:43'! testInstanceCreation self should: [ Character value: -1] raise: Error. self shouldnt: [Character value: 0] raise: Error. self shouldnt: [Character value: 256] raise: Error! ! !CharacterTest methodsFor: 'tests instance creation' stamp: 'sd 6/5/2005 09:25'! testNew self should: [Character new] raise: Error.! ! ComposableModel subclass: #CheckBoxExample instanceVariableNames: 'button1 button2 button3 container morph1 morph2 morph3' classVariableNames: '' poolDictionaries: '' category: 'Spec-Examples-Widgets'! !CheckBoxExample commentStamp: '' prior: 0! A CheckBoxExample is a simple example of how to use CheckBoxes. CheckBoxExample new openWithSpec! !CheckBoxExample methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/2/2012 01:01'! button1 ^ button1! ! !CheckBoxExample methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/2/2012 01:01'! button2 ^ button2! ! !CheckBoxExample methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/2/2012 01:01'! button3 ^ button3! ! !CheckBoxExample methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/2/2012 01:01'! container ^ container! ! !CheckBoxExample methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/12/2012 19:23'! initialize "Initialization code for RadioButtonGroupExample" container := PanelMorph new. container changeTableLayout; listDirection: #bottomToLeft. self instantiateMorphs. super initialize.! ! !CheckBoxExample methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/12/2012 19:23'! initializePresenter self setActionsForButton1. self setActionsForButton2. self setActionsForButton3. ! ! !CheckBoxExample methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/12/2012 19:23'! initializeWidgets self instantiateModels: #( button1 CheckBoxModel button2 CheckBoxModel button3 CheckBoxModel ). button1 label: 'Button 1'. button2 label: 'Button 2'. button3 label: 'Button 3'. self setFocus.! ! !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: 'BenjaminVanRyseghem 2/2/2012 01:01'! setActionsForButton1 button1 whenActivatedDo: [ container addMorph: morph1 ]. button1 whenDesactivatedDo: [ container removeMorph: morph1 ]! ! !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'! setActionsForButton3 button3 whenActivatedDo: [ container addMorph: morph3 ]. button3 whenDesactivatedDo: [ container removeMorph: morph3 ]! ! !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'! setGroup RadioButtonGroup new addRadioButton: button1; addRadioButton: button2; addRadioButton: button3; default: button1. ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CheckBoxExample class instanceVariableNames: ''! !CheckBoxExample class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/15/2013 11:42'! defaultSpec ^ { #ComposableSpec. #add:. { self topSpec. #layout:. #(FrameLayout bottomFraction: 0 bottomOffset: 20) }. #add:. {{#model . #container } . #layout: . #(FrameLayout topOffset: 22) } }! ! !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. }! ! !CheckBoxExample class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 2/5/2012 17:17'! title ^ 'CheckBox Example'! ! !CheckBoxExample class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/15/2013 11:46'! topSpec ^ { #ComposableSpec. #add:. {{#model . #button1 } . #layout:. #(FrameLayout rightFraction: 0.33 bottomFraction: 0 bottomOffset: 25)}. #add:. {{#model . #button2 } . #layout:. #(FrameLayout leftFraction: 0.33 rightFraction: 0.66 bottomFraction: 0 bottomOffset: 25)}. #add:. {{#model . #button3 } . #layout:. #(FrameLayout leftFraction: 0.66 bottomFraction: 0 bottomOffset: 25)}}! ! AbstractBasicWidget subclass: #CheckBoxModel instanceVariableNames: 'actionWhenActivatedHolder actionWhenDesactivatedHolder stateHolder labelClickableHolder labelHolder' classVariableNames: '' poolDictionaries: '' category: 'Spec-Widgets'! !CheckBoxModel commentStamp: '' prior: 0! 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: 'focus' stamp: 'BenjaminVanRyseghem 2/8/2013 13:20'! eventKeyStrokeForNextFocus "String describing the keystroke to perform to jump to the next widget" ^ Character arrowRight asShortcut! ! !CheckBoxModel methodsFor: 'focus' stamp: 'BenjaminVanRyseghem 2/8/2013 13:21'! eventKeyStrokeForPreviousFocus "String describing the keystroke to perform to jump to the previous widget" ^ Character arrowLeft asShortcut! ! !CheckBoxModel methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/7/2012 12:28'! initialize "initialization code for CheckBox" super initialize. actionWhenActivatedHolder := [] asValueHolder. actionWhenDesactivatedHolder := [] asValueHolder. enabledHolder := true asValueHolder. stateHolder := false asValueHolder. labelClickableHolder := true asValueHolder. labelHolder := '' asValueHolder. stateHolder whenChangedDo: [:bool | bool ifTrue: actionWhenActivatedHolder contents ifFalse: actionWhenDesactivatedHolder contents. self changed: #state ]. labelClickableHolder whenChangedDo: [:aBoolean | self widget ifNotNil: [:w | w labelClickable: aBoolean ]]. labelHolder whenChangedDo: [:label | self widget ifNotNil: [:w | w label: label ]]. ! ! !CheckBoxModel methodsFor: 'morphic' stamp: 'BenjaminVanRyseghem 7/12/2012 17:50'! label ^ labelHolder contents! ! !CheckBoxModel methodsFor: 'morphic' stamp: 'BenjaminVanRyseghem 7/13/2012 02:10'! labelClickable "Return true if the label can be clicked to select the checkbox" ^ labelClickableHolder contents! ! !CheckBoxModel methodsFor: 'morphic' stamp: 'BenjaminVanRyseghem 7/16/2012 17:06'! state "Return the current state of the checkBox" ^ stateHolder contents! ! !CheckBoxModel methodsFor: 'morphic' stamp: 'BenjaminVanRyseghem 7/12/2012 17:49'! state: aBoolean "Set if the checkbox is activated or not" stateHolder contents: aBoolean! ! !CheckBoxModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 16:56'! activationAction: aBlock "This method is used to set the action to perform when I am activated" actionWhenActivatedHolder contents: 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' stamp: 'BenjaminVanRyseghem 7/16/2012 17:00'! desactivationAction: aBlock "This method is used to set the action to perform when I am desactivated" actionWhenDesactivatedHolder contents: aBlock! ! !CheckBoxModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 17:03'! label: aString "Set the label of the checkbox" labelHolder contents: aString.! ! !CheckBoxModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 17:03'! labelClickable: aBoolean "Set if the label can be clicked to select the checkbox" labelClickableHolder contents: aBoolean! ! !CheckBoxModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/12/2012 17:51'! toggleState "Toogle the current state of the checkbox" self state: self state not! ! !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-events' stamp: 'BenjaminVanRyseghem 7/16/2012 16:52'! whenActivationActionChanged: aBlock "A block performed when the activation action changed" actionWhenActivatedHolder whenChangedDo: aBlock ! ! !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/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-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/16/2012 17:01'! whenLabelChanged: aBlock "A block performed when the label changed" labelHolder whenChangedDo: aBlock ! ! !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 class instanceVariableNames: ''! !CheckBoxModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 2/8/2013 14:24'! defaultSpec ^ {#CheckboxSpec. #on:selected:changeSelected:. #model. #state. #state:. #label:. { #model. #label }. #beCheckbox. #hResizing:. #shrinkWrap. #vResizing:. #shrinkWrap. #setBalloonText:. { #model . #help}. #borderWidth:. #(model borderWidth). #borderColor:. #(model borderColor). #labelClickable:. { #model. #labelClickable}.}! ! !CheckBoxModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 7/13/2012 02:00'! title ^ 'Checkbox Button'! ! ThreePhaseButtonMorph subclass: #CheckboxButtonMorph uses: TEnableOnHaloMenu instanceVariableNames: 'repressedImage enabled isRadioButton images' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !CheckboxButtonMorph commentStamp: 'gvc 5/23/2007 12:19' prior: 0! Checkbox/radio - button only.! !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: '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: '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 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: 'accessing' stamp: 'gvc 8/17/2006 16:04'! enabled "Answer the value of enabled" ^ enabled! ! !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 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: '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: '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 10/25/2007 17:34'! isRadioButton "Answer the value of isRadioButton" ^ isRadioButton! ! !CheckboxButtonMorph methodsFor: 'accessing' stamp: 'gvc 10/25/2007 17:34'! isRadioButton: anObject "Set the value of isRadioButton" isRadioButton := anObject! ! !CheckboxButtonMorph methodsFor: 'accessing' stamp: 'gvc 8/17/2006 15:17'! repressedImage "Answer the value of repressedImage" ^ repressedImage! ! !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: '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 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: 'accessing' stamp: 'gvc 8/17/2006 16:41'! state "Answer the state." ^state! ! !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: 'as yet unclassified'! addToggleItemsToHaloMenu: aCustomMenu "Add toggle-items to the halo menu" super addToggleItemsToHaloMenu: aCustomMenu. aCustomMenu addUpdating: #enabledString target: self action: #toggleEnabled! ! !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: '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 5/23/2007 11:38'! colorToUse "Answer the color we should use." ^self paneColor! ! !CheckboxButtonMorph methodsFor: 'as yet unclassified'! 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: 'DamienCassou 4/27/2012 14:28'! imageFromName: aSymbol ^ self images at: aSymbol ifPresent: [:block | block value] ifAbsent: []! ! !CheckboxButtonMorph methodsFor: 'as yet unclassified' stamp: 'DamienCassou 4/27/2012 14:21'! imageToUse "Answer the image we should use." ^ self imageFromName: 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: '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: '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: 'as yet unclassified'! toggleEnabled "Toggle the enabled state." self enabled: self enabled not! ! !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: '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: '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: '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: '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: '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: '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: 'protocol' stamp: 'gvc 8/2/2007 14:16'! disable "Disable the receiver." self enabled: false! ! !CheckboxButtonMorph methodsFor: 'protocol' stamp: 'gvc 8/2/2007 14:16'! enable "Enable the receiver." self enabled: true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CheckboxButtonMorph class uses: TEnableOnHaloMenu classTrait instanceVariableNames: ''! !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! ! !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! ! MorphicModel subclass: #CheckboxMorph uses: TEnableOnHaloMenu instanceVariableNames: 'buttonMorph labelMorph getLabelSelector setStateSelector getStateSelector enabled getEnabledSelector labelClickable' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !CheckboxMorph commentStamp: 'gvc 5/18/2007 13:47' prior: 0! Checkbox with box button and label with enablement support.! !CheckboxMorph methodsFor: '*Keymapping-Core' stamp: 'ThierryGoubier 9/15/2012 22:06'! initializeShortcuts: aKMDispatcher super initializeShortcuts: aKMDispatcher. aKMDispatcher attachCategory: #MorphFocusNavigation! ! !CheckboxMorph methodsFor: '*Morphic-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: 'accessing' stamp: 'gvc 8/17/2006 14:49'! buttonMorph "Answer the value of buttonMorph" ^ buttonMorph! ! !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: 'accessing' stamp: 'gvc 8/17/2006 14:49'! enabled "Answer the value of enabled" ^ enabled! ! !CheckboxMorph methodsFor: 'accessing' stamp: 'MarcusDenker 12/11/2009 07:42'! enabled: aBoolean "Set the value of enabled" enabled := aBoolean. self labelMorph ifNotNil: [:m | (m respondsTo: #enabled:) ifTrue: [ m enabled: aBoolean]]. self buttonMorph ifNotNil: [:m | m enabled: aBoolean]. self changed: #enabled! ! !CheckboxMorph methodsFor: 'accessing' stamp: 'gvc 9/8/2006 14:58'! font "Answer the label font" ^self labelMorph font! ! !CheckboxMorph methodsFor: 'accessing' stamp: 'gvc 9/8/2006 14:58'! font: aFont "Set the label font" self labelMorph font: aFont! ! !CheckboxMorph methodsFor: 'accessing' stamp: 'gvc 8/17/2006 15:05'! getEnabledSelector "Answer the value of getEnabledSelector" ^ getEnabledSelector! ! !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: 'GaryChambers 12/2/2011 10:20'! getLabelSelector ^ getLabelSelector! ! !CheckboxMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/20/2012 12:29'! getLabelSelector: anObject getLabelSelector := anObject. self updateLabel.! ! !CheckboxMorph methodsFor: 'accessing' stamp: 'gvc 8/17/2006 14:49'! getStateSelector "Answer the value of getStateSelector" ^ getStateSelector! ! !CheckboxMorph methodsFor: 'accessing' stamp: 'gvc 8/17/2006 18:02'! getStateSelector: anObject "Set the value of getStateSelector" getStateSelector := anObject. self updateSelection! ! !CheckboxMorph methodsFor: 'accessing' stamp: 'gvc 8/2/2007 16:14'! label "Answer the contents of the label morph." ^(self labelMorph ifNil: [^'']) contents! ! !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: 'accessing' stamp: 'gvc 8/17/2006 14:49'! labelMorph "Answer the value of labelMorph" ^ labelMorph! ! !CheckboxMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/20/2012 12:36'! labelMorph: aMorph "Set the value of labelMorph" labelMorph ifNotNil: [labelMorph delete]. labelMorph := aMorph. self addMorphBack: aMorph. self enabled: self enabled.! ! !CheckboxMorph methodsFor: 'accessing' stamp: 'gvc 8/17/2006 15:00'! setStateSelector "Answer the value of setStateSelector" ^ setStateSelector! ! !CheckboxMorph methodsFor: 'accessing' stamp: 'gvc 8/17/2006 15:00'! setStateSelector: anObject "Set the value of setStateSelector" setStateSelector := anObject! ! !CheckboxMorph methodsFor: 'as yet unclassified'! addToggleItemsToHaloMenu: aCustomMenu "Add toggle-items to the halo menu" super addToggleItemsToHaloMenu: aCustomMenu. aCustomMenu addUpdating: #enabledString target: self action: #toggleEnabled! ! !CheckboxMorph methodsFor: 'as yet unclassified'! enabledString "Answer the string to be shown in a menu to represent the 'enabled' status" ^ (self enabled) -> 'enabled' translated! ! !CheckboxMorph methodsFor: 'as yet unclassified'! toggleEnabled "Toggle the enabled state." self enabled: self enabled not! ! !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: '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: 'event handling' stamp: 'gvc 1/16/2007 15:20'! handlesKeyboard: evt "Yes, we do it here." ^true! ! !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: '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! ! !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: '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: 'initialization' stamp: 'BenjaminVanRyseghem 2/21/2013 23:31'! 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; buttonMorph: self newButtonMorph; labelMorph: self newLabelMorph; on: #mouseDown send: #labelClicked to: self; on: #mouseMove send: #updateButton: to: self; on: #mouseUp send: #updateButton: to: self! ! !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: 'protocol' stamp: 'gvc 5/22/2007 15:38'! beCheckbox "Change the button to be a checkbox." self buttonMorph beCheckbox! ! !CheckboxMorph methodsFor: 'protocol' stamp: 'gvc 5/22/2007 15:38'! beRadioButton "Change the button to be a radio button." self buttonMorph beRadioButton! ! !CheckboxMorph methodsFor: 'protocol' stamp: 'gvc 8/2/2007 11:38'! disable "Disable the receiver." self enabled: false! ! !CheckboxMorph methodsFor: 'protocol' stamp: 'gvc 8/2/2007 11:38'! enable "Enable the receiver." self enabled: true! ! !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: 'protocol' stamp: 'BenjaminVanRyseghem 2/21/2013 23:31'! labelClickable: aBoolean labelClickable := aBoolean.! ! !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: 'updating' stamp: 'GaryChambers 12/2/2011 10:21'! update: aSymbol "Refer to the comment in View|update:." aSymbol == self getStateSelector ifTrue: [self updateSelection. ^ self]. aSymbol == self getEnabledSelector ifTrue: [self updateEnabled. ^ self]. aSymbol == self getLabelSelector ifTrue: [self updateLabel. ^ self]! ! !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: 'updating' stamp: 'GaryChambers 10/17/2011 16:37'! updateButtonDown: evt "Check for keyboard focus." self wantsKeyboardFocusOnMouseDown ifTrue: [ self takeKeyboardFocus]. self updateButton: evt! ! !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: '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: '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: '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: 'private' stamp: 'gvc 8/2/2007 16:13'! newLabel "Answer a new label morph" ^self theme checkboxLabelFor: 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 class uses: TEnableOnHaloMenu classTrait instanceVariableNames: ''! !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! ! AbstractSpec subclass: #CheckboxSpec instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Spec-Core-Specs'! !CheckboxSpec commentStamp: '' prior: 0! A CheckboxSpec is a spec used to describe a CheckboxButton and a RadionButton! !CheckboxSpec methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/24/2012 03:10'! classSymbol ^ #Checkbox! ! MessageDialogWindow subclass: #ChooseDropListDialogWindow instanceVariableNames: 'listMorph list' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Windows'! !ChooseDropListDialogWindow commentStamp: 'gvc 5/18/2007 13:46' prior: 0! Message dialog containing a drop list for selection of an item.! !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 15:21'! list: anObject "Set the value of list" list := anObject. self changed: #list; changed: #selectionIndex! ! !ChooseDropListDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/12/2007 14:17'! listMorph "Answer the value of listMorph" ^ listMorph! ! !ChooseDropListDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/12/2007 14:17'! listMorph: anObject "Set the value of listMorph" listMorph := anObject! ! !ChooseDropListDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/18/2007 10:27'! icon "Answer an icon for the receiver." ^self theme questionIcon! ! !ChooseDropListDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/12/2007 14:35'! initialize "Initialize the receiver." self list: #(). super initialize! ! !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: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: '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 class instanceVariableNames: ''! !ChooseDropListDialogWindow class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'gvc 5/22/2007 11:50'! taskbarIcon "Answer the icon for the receiver in a task bar." ^self theme smallQuestionIcon! ! Announcement subclass: #ChoseDate instanceVariableNames: 'date calendar' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Widgets-Calendar'! !ChoseDate commentStamp: '' prior: 0! A ChoseDate is an announcement raised by the CalendarMorph! !ChoseDate methodsFor: 'accessing' stamp: 'SeanDeNigris 1/20/2013 21:17'! calendar ^ calendar.! ! !ChoseDate methodsFor: 'accessing' stamp: 'SeanDeNigris 1/20/2013 21:17'! date ^ date.! ! !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 class instanceVariableNames: ''! !ChoseDate class methodsFor: 'instance creation' stamp: 'SeanDeNigris 1/20/2013 21:15'! of: aDate from: aCalendarChooserMorph ^ self new date: aDate; calendar: aCalendarChooserMorph.! ! SharedPool subclass: #ChronologyConstants instanceVariableNames: '' classVariableNames: 'DayNames DaysInMonth MonthNames NanosInMillisecond NanosInSecond SecondsInDay SecondsInHour SecondsInMinute SqueakEpoch' poolDictionaries: '' category: 'Kernel-Chronology'! !ChronologyConstants commentStamp: 'brp 3/12/2004 14:34' prior: 0! ChronologyConstants is a SharedPool for the constants used by the Kernel-Chronology classes.! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ChronologyConstants class instanceVariableNames: ''! !ChronologyConstants class methodsFor: 'class initialization' stamp: 'GuillermoPolito 5/21/2012 01:54'! initialize "ChronologyConstants initialize" SqueakEpoch := 2415386. "Julian day number of 1 Jan 1901" SecondsInDay := 86400. 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). ! ! Object subclass: #ChunkFileFormatParser instanceVariableNames: 'readStream parsedDeclarations nextChar' classVariableNames: '' poolDictionaries: '' category: 'CodeImport'! !ChunkFileFormatParser commentStamp: '' prior: 0! 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: 'accessing' stamp: 'GuillermoPolito 5/5/2012 17:19'! addDeclaration: aDeclaration parsedDeclarations add: aDeclaration ! ! !ChunkFileFormatParser methodsFor: 'accessing' stamp: 'GuillermoPolito 5/5/2012 17:07'! readStream: aReadStream readStream := aReadStream! ! !ChunkFileFormatParser methodsFor: 'parsing' stamp: 'GuillermoPolito 5/5/2012 22:24'! 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 stamp | behaviorName := classOrganizationPreamble first. isMeta := (classOrganizationPreamble second = #reorganize) not. self addDeclaration: (ClassOrganizationDeclaration contents: self nextChunk behaviorName: behaviorName isMeta: isMeta)! ! !ChunkFileFormatParser methodsFor: 'parsing' stamp: 'GuillermoPolito 5/5/2012 22:26'! 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:) not. stamp := isMeta ifTrue: [commentPreamble at: 4] ifFalse: [commentPreamble at: 3]. self addDeclaration: (ClassCommentDeclaration contents: self nextChunk behaviorName: behaviorName isMeta: isMeta stamp: stamp)! ! !ChunkFileFormatParser methodsFor: 'parsing' stamp: 'GuillermoPolito 5/5/2012 17:17'! parseDeclarations [ readStream atEnd ] whileFalse: [ self parseNextDeclaration. ]. ^parsedDeclarations! ! !ChunkFileFormatParser methodsFor: 'parsing' stamp: 'GuillermoPolito 5/12/2012 14:05'! 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:) not. 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: 'GuillermoPolito 5/5/2012 22:28'! parseNextDeclaration | isMetadata nextChunk value | 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 := Scanner new scanTokens: nextChunk. (substrings includes: 'methodsFor:') ifTrue: [ ^self parseMethodDeclarations: substrings ]. (substrings includes: 'commentStamp:') ifTrue: [ ^self parseCommentDeclaration: substrings ]. (substrings includes: 'reorganize') ifTrue: [ ^self parseClassOrganization: substrings ]. ]! ! !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: 'testing' stamp: 'GuillermoPolito 5/5/2012 22:06'! initialize parsedDeclarations := OrderedCollection new.! ! !ChunkFileFormatParser methodsFor: 'testing' stamp: 'GuillermoPolito 5/5/2012 22:06'! isChunkEnd nextChar := readStream next. ^ nextChar = nil or: [ (nextChar = self terminatorMark and: [ readStream peek ~= self terminatorMark ]) ]! ! !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: 'testing' stamp: 'GuillermoPolito 5/5/2012 17:09'! isNextStyleChunk "Style chunks are between $] and $[" ^readStream peek == $]! ! !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 22:04'! nextChunk | out next | out := (String new: 1000) writeStream. readStream skipSeparators. [ self isChunkEnd ] whileFalse: [ out nextPut: self next. ]. ^out contents! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ChunkFileFormatParser class instanceVariableNames: ''! !ChunkFileFormatParser class methodsFor: 'instance creation' stamp: 'GuillermoPolito 5/5/2012 17:06'! for: aReadStream ^self new readStream: aReadStream; yourself! ! TestCase subclass: #ChunkImportTestCase instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-CodeImport'! !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: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-code' stamp: 'EstebanLorenzano 8/3/2012 15:11'! testImportAClassCategory | class classOrganizationString chunk | classOrganizationString := '(''testing'' testImportAClass testImportAMethod) (''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. self assert: classOrganizationString trimBoth equals: class organization stringForFileOut trimBoth. ] 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-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: '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: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-methods' stamp: 'GuillermoPolito 5/5/2012 17:26'! testImportFromReadStream self assert: 4 equals: (CodeImporter evaluateReadStream: '2+2!!' readStream)! ! !ChunkImportTestCase methodsFor: 'importing-methods' stamp: 'GuillermoPolito 5/5/2012 17:26'! testImportString self assert: 4 equals: (CodeImporter evaluateString: '2+2!!')! ! EllipseMorph subclass: #CircleMorph uses: TAbleToRotate instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Basic'! !CircleMorph commentStamp: '' prior: 0! I am a specialization of EllipseMorph that knows enough to remain circular. ! !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: '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 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: '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: '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: 'parts bin' stamp: 'alain.plantec 5/28/2009 09:46'! initialize super initialize. self extent: 40@40; color: Color green lighter; yourself! ! !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 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: 'rotate scale and flex' stamp: 'AlainPlantec 5/7/2010 23:54'! rotationDegrees ^ self forwardDirection! ! !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: 't-rotating'! forwardDirection "Return the receiver's forward direction (in eToy terms)" ^self valueOfProperty: #forwardDirection ifAbsent:[0.0]! ! !CircleMorph methodsFor: 't-rotating'! forwardDirection: newDirection "Set the receiver's forward direction (in eToy terms)" self setProperty: #forwardDirection toValue: newDirection.! ! !CircleMorph methodsFor: 't-rotating'! heading "Return the receiver's heading" ^ self owner ifNil: [self forwardDirection] ifNotNil: [self forwardDirection + self owner degreesOfFlex]! ! !CircleMorph methodsFor: 't-rotating'! setDirectionFrom: aPoint | delta degrees | delta := (self transformFromWorld globalPointToLocal: aPoint) - self referencePosition. degrees := delta degrees + 90.0. self forwardDirection: (degrees \\ 360) rounded. ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CircleMorph class uses: TAbleToRotate classTrait instanceVariableNames: ''! TestCase subclass: #CircleMorphBugs instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Bugs'! MorphTest subclass: #CircleMorphTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Basic'! !CircleMorphTest commentStamp: 'tlk 5/21/2006 14:16' prior: 0! A CircleMorphTest is a subclass of MorphTest. It was first implemented when removing some unused and broken functionality. My fixtures are morph, a CircleMorph and world. ! !CircleMorphTest methodsFor: 'initialization' stamp: 'tlk 5/21/2006 14:17'! setUp morph := CircleMorph new! ! ClassDescription subclass: #Class uses: TBehaviorCategorization instanceVariableNames: 'subclasses name classPool sharedPools environment category traitComposition localSelectors' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Classes'! !Class commentStamp: '' prior: 0! 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: '*Fuel' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^aGeneralMapper visitClass: self! ! !Class methodsFor: '*FuelTests' stamp: 'MarianoMartinezPeck 8/7/2012 19:12'! renameSilently: aName [ self rename: aName] fuelValueWithoutNotifications! ! !Class methodsFor: '*GroupManagerUI' stamp: 'BenjaminVanRyseghem 2/25/2012 15:59'! elementsToAddInAGroup ^ self methodDict values! ! !Class methodsFor: '*GroupManagerUI' stamp: 'BenjaminVanRyseghem 2/25/2012 16:35'! prettyName ^ self printString ! ! !Class methodsFor: '*HelpSystem-Core' stamp: 'tbn 3/11/2010 23:42'! asHelpTopic ^SystemReference forClass: self! ! !Class methodsFor: '*Monticello' stamp: 'al 3/26/2006 21:31'! 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 poolDictionaryNames classInstVarNames: self class instVarNames type: self typeOfClass comment: self organization classComment asString commentStamp: self organization commentStamp ! ! !Class methodsFor: '*Monticello' stamp: 'avi 3/10/2004 13:32'! classDefinitions ^ Array with: self asClassDefinition! ! !Class methodsFor: '*Ring-Core-Kernel' stamp: 'VeronicaUquillas 9/19/2011 16:45'! 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 ]. 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: '*Ring-Core-Kernel' stamp: 'VeronicaUquillas 9/19/2011 16:45'! 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; addPoolDictionaries: self poolDictionaryNames; comment: self organization classComment; stamp: self organization commentStamp; definitionSource: self definition; withMetaclass. ring theMetaClass traitCompositionSource: self theMetaClass traitCompositionString; definitionSource: self theMetaClass definition; addInstanceVariables: self theMetaClass instVarNames. ^ ring! ! !Class methodsFor: '*Ring-Core-Kernel' stamp: 'VeronicaUquillas 9/19/2011 15:32'! 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 isNil ifFalse:[ rgSuper := aRGSlice classNamed: self superclass name. rgSuper isNil ifTrue: [ 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 isNil ifTrue: [ rgSub := each asRingDefinitionWithMethods: methodsBoolean withSuperclasses: supersBoolean withSubclasses: subsBoolean withPackageKeys: packageKeys in: aRGSlice ]. rgSub superclass: rgClass ] ]. ^rgClass! ! !Class methodsFor: '*Ring-Core-Kernel' stamp: 'VeronicaUquillas 9/19/2011 15:35'! asRingDefinitionWithMethods: methodsBoolean withSuperclasses: supersBoolean withSubclasses: subsBoolean withPackages: packsBoolean "Retrieves a ring class based on the receiver. The data loaded in the class (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 rgPackage 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: '*Spec-Builder' stamp: 'BenjaminVanRyseghem 3/5/2012 05:50'! addInstVarNamed: aName type: aClass ^ self addInstVarNamed: aName! ! !Class methodsFor: '*Spec-Builder' stamp: 'BenjaminVanRyseghem 2/28/2012 20:27'! addSourceCode: source into: selector | method newSource | method := self methodDict at: selector asSymbol ifAbsent: [ ^ self ]. newSource := String streamContents: [:s | s << method sourceCode << '.' ; cr ; tab ;<< source ]. self compileWithoutReturn: newSource classified: method category! ! !Class methodsFor: '*Spec-Builder' stamp: 'BenjaminVanRyseghem 2/27/2012 07:45'! subclass: newName category: newCategory | result | result := self subclass: newName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: newCategory. ^ result ifNil: [ Smalltalk at: name ifAbsent: [ nil ]] ifNotNil: [ result ]! ! !Class methodsFor: 'accessing' stamp: 'al 3/18/2006 13:23'! basicCategory ^category! ! !Class methodsFor: 'accessing' stamp: 'al 3/18/2006 13:23'! basicCategory: aSymbol category := aSymbol! ! !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: 'accessing' stamp: 'al 3/25/2006 13:16'! basicLocalSelectors: aSetOrNil localSelectors := aSetOrNil! ! !Class methodsFor: 'accessing'! classPool "Answer the dictionary of class variables." classPool == nil ifTrue: [^Dictionary new] ifFalse: [^classPool]! ! !Class methodsFor: 'accessing' stamp: 'BG 8/11/2002 20:53'! classPoolFrom: aClass "share the classPool with aClass." classPool := aClass classPool! ! !Class methodsFor: 'accessing' stamp: 'al 9/3/2004 13:37'! classPool: aDictionary classPool := aDictionary! ! !Class methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/23/2011 18:55'! hasTraitComposition ^ traitComposition notNil and: [ traitComposition notEmpty ]! ! !Class methodsFor: 'accessing'! name "Answer the name of the receiver." name == nil ifTrue: [^super name] ifFalse: [^name]! ! !Class methodsFor: 'accessing' stamp: 'ab 4/14/2003 22:30'! poolDictionaryNames ^ self sharedPools collect: [:ea | self environment keyAtIdentityValue: ea]! ! !Class methodsFor: 'accessing' stamp: 'al 3/25/2006 12:35'! traitComposition traitComposition ifNil: [traitComposition := TraitComposition new]. ^traitComposition! ! !Class methodsFor: 'accessing' stamp: 'al 3/25/2006 12:37'! traitComposition: aTraitComposition traitComposition := aTraitComposition! ! !Class methodsFor: 'accessing class hierarchy' stamp: 'tk 10/17/1999 13:31'! 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 == nil ifTrue: [subclasses := Array with: aSubclass. ^self]. subclasses do:[:cl| cl == aSubclass ifTrue:[^self]]. "Already my subclass" subclasses := subclasses copyWith: aSubclass.! ! !Class methodsFor: 'accessing class hierarchy' stamp: 'ar 7/14/1999 10:54'! removeSubclass: aSubclass "If the argument, aSubclass, is one of the receiver's subclasses, remove it." subclasses == nil ifFalse: [subclasses := subclasses copyWithout: aSubclass. subclasses isEmpty ifTrue: [subclasses := nil]]. ! ! !Class methodsFor: 'accessing class hierarchy' stamp: 'ar 7/14/1999 11:00'! subclasses "Answer a Set containing the receiver's subclasses." ^subclasses == nil ifTrue: [#()] ifFalse: [subclasses copy]! ! !Class methodsFor: 'accessing class hierarchy' stamp: 'ar 7/14/1999 11:00'! subclassesDo: aBlock "Evaluate the argument, aBlock, for each of the receiver's immediate subclasses." subclasses == nil ifFalse:[subclasses do: aBlock]! ! !Class methodsFor: 'as yet unclassified' stamp: 'StephaneDucasse 12/13/2011 17:22'! 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: [ superclass == nil ifTrue: [nil] ifFalse: [superclass sharedPoolOfVarNamed: aString] ] ! ! !Class methodsFor: 'class name' stamp: 'FernandoOlivero 5/17/2010 13:04'! 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']. name := 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: 'class variables' stamp: 'EstebanLorenzano 7/27/2012 16:30'! 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]]. classPool == nil ifTrue: [classPool := Dictionary new]. (classPool includesKey: symbol) ifFalse: ["Pick up any refs in Undeclared" classPool declare: symbol from: Undeclared. SystemAnnouncer uniqueInstance classDefinitionChangedFrom: oldState to: self]! ! !Class methodsFor: 'class variables' stamp: 'nice 10/20/2009 20:47'! 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: 'class variables' stamp: 'MarcusDenker 2/19/2010 11:40'! classVarNamed: name "Answer the content of the Class Variable" ^self classPool at: name asSymbol ifAbsent: [self error: 'no such lass var']! ! !Class methodsFor: 'class variables' stamp: 'MarcusDenker 2/19/2010 11:42'! classVarNamed: name put: anObject "Store anObject in the class variable." | symbol | symbol := name asSymbol. (self classPool includesKey: symbol) ifFalse: [^self error: 'no such lass var']. self classPool at: symbol put: anObject.! ! !Class methodsFor: 'class variables' stamp: 'nice 10/20/2009 22:02'! classVarNames "Answer a collection of the names of the class variables defined in the receiver." ^self classPool keys asArray sort! ! !Class methodsFor: 'class variables' stamp: 'tk 3/15/98 20:19'! ensureClassPool classPool ifNil: [classPool := Dictionary new].! ! !Class methodsFor: 'class variables' stamp: 'StephaneDucasse 8/27/2010 10:55'! 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: 'class variables' stamp: 'StephaneDucasse 11/7/2011 22:42'! 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. (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: (classPool associationAt: aSymbol)) isEmpty ifFalse: [ InMidstOfFileinNotification signal ifTrue: [ self crTrace: self name, ' (' , aString , ' is Undeclared) '. ^Undeclared declare: aSymbol from: classPool]. (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: classPool] ifFalse: [^self]]]]. classPool removeKey: aSymbol. classPool isEmpty ifTrue: [classPool := nil]. ! ! !Class methodsFor: 'class variables' stamp: 'StephaneDucasse 11/11/2010 22:38'! usesClassVarNamed: aString "Return whether the receiver or its superclasses have a class variable named: aString" ^ self allClassVarNames includes: aString! ! !Class methodsFor: 'compiling' stamp: 'MarcusDenker 11/27/2012 12:22'! binding "Answer a binding for the receiver, sharing if possible" | binding | binding := self environment associationAt: name ifAbsent: [nil -> self]. ^binding value == self ifTrue: [binding] ifFalse: [nil -> self]! ! !Class methodsFor: 'compiling' stamp: 'MarcusDenker 3/1/2013 10:27'! 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: 'compiling' stamp: 'ar 5/17/2003 14:13'! canFindWithoutEnvironment: varName "This method is used for analysis of system structure -- see senders." "Look up varName, in the context of the receiver. Return true if it can be found without using the declared environment." "First look in classVar dictionary." (self classPool bindingOf: varName) ifNotNil:[^true]. "Next look in shared pools." self sharedPools do:[:pool | (pool bindingOf: varName) ifNotNil:[^true]. ]. "Finally look higher up the superclass chain and fail at the end." superclass == nil ifTrue: [^ false] ifFalse: [^ (superclass bindingOf: varName) notNil]. ! ! !Class methodsFor: 'compiling' stamp: 'ar 7/14/1999 04:56'! compileAll super compileAll. self class compileAll.! ! !Class methodsFor: 'compiling'! 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: 'compiling' stamp: 'StephaneDucasse 10/15/2011 19:55'! 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" | binding | "First look in classVar dictionary." binding := self classPool bindingOf: aSymbol. binding ifNotNil: [^binding]. "Next look in shared pools." self sharedPools do: [:pool | | aBinding | aBinding := pool bindingOf: aSymbol. aBinding ifNotNil: [^aBinding ]. ]. superclass ifNotNil: [ ^ superclass innerBindingOf: aSymbol. ]. ^ nil! ! !Class methodsFor: 'compiling' stamp: 'sd 3/28/2003 15:24'! possibleVariablesFor: misspelled continuedFrom: oldResults | results | results := misspelled correctAgainstDictionary: self classPool continuedFrom: oldResults. self sharedPools do: [:pool | results := misspelled correctAgainstDictionary: pool continuedFrom: results ]. superclass == nil ifTrue: [ ^ misspelled correctAgainstDictionary: self environment continuedFrom: results ] ifFalse: [ ^ superclass possibleVariablesFor: misspelled continuedFrom: results ]! ! !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: 'copying' stamp: 'jb 7/1/2011 10:39'! 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 evaluatorClass evaluate: newDefinition logged: true. class class instanceVariableNames: self class instanceVariablesString. class copyAllCategoriesFrom: self. class class copyAllCategoriesFrom: self class. ^ class! ! !Class methodsFor: 'fileIn/Out' stamp: 'PeterHugossonMiller 9/3/2009 00:53'! 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: 'fileIn/Out' stamp: 'al 9/3/2004 14:00'! fileOutInitializerOn: aStream ^self class fileOutInitializerOn: aStream! ! !Class methodsFor: 'fileIn/Out' stamp: 'al 9/3/2004 14:04'! 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: 'fileIn/Out' stamp: 'StephaneDucasse 11/7/2011 22:41'! 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: 'fileIn/Out' stamp: 'StephaneDucasse 11/7/2011 22:41'! 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: 'fileIn/Out' stamp: 'al 9/3/2004 14:04'! 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: 'fileIn/Out' stamp: 'StephaneDucasse 12/13/2011 16:08'! 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: 'fileIn/Out' stamp: 'al 9/3/2004 14:05'! 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: 'fileIn/Out' stamp: 'CamilloBruni 8/1/2012 16:15'! 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: 'fileIn/Out' stamp: 'al 9/3/2004 14:05'! shouldFileOutPool: aPoolName "respond with true if the user wants to file out aPoolName" ^self confirm: ('FileOut the sharedPool ', aPoolName, '?')! ! !Class methodsFor: 'fileIn/Out' stamp: 'al 9/3/2004 14:05'! shouldFileOutPools "respond with true if the user wants to file out the shared pools" ^self confirm: 'FileOut selected sharedPools?'! ! !Class methodsFor: 'fileIn/Out' stamp: 'ar 4/10/2005 20:27'! withClassVersion: aVersion aVersion = self classVersion ifTrue:[^self]. ^self error: 'Invalid class version'! ! !Class methodsFor: 'initialize-release' stamp: 'MarcusDenker 3/29/2012 13:08'! 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. classPool ifNotNil: [(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: [classPool := self classPool. "in case it was nil" newVars do: [:var | classPool declare: var from: Undeclared]]. ^conflicts! ! !Class methodsFor: 'initialize-release' stamp: 'al 9/3/2004 14:07'! 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 class instSize do: [:i | self instVarAt: i put: nil]. "Store nil over class instVars." self classPool: nil. self sharedPools: nil. self class obsolete. super obsolete.! ! !Class methodsFor: 'initialize-release' stamp: 'al 9/3/2004 13:35'! 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: 'initialize-release' stamp: 'sd 4/24/2008 22:28'! 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 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: 'initialize-release' stamp: 'al 9/3/2004 13:36'! 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: 'initialize-release' stamp: 'BenjaminVanRyseghem 11/24/2010 15:55'! sharing: poolString "Set up sharedPools. Answer whether recompilation is advisable." | oldPools | oldPools := self sharedPools. sharedPools := OrderedCollection new. (poolString subStrings: ' ') do: [:poolName | 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']])]. sharedPools isEmpty ifTrue: [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: 'NS 4/8/2004 10:55'! 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." superclass := sup. methodDict := md. format := ft. name := nm. instanceVariables := nilOrArray. classPool := pool. sharedPools := poolSet. self organization: org.! ! !Class methodsFor: 'initialize-release' stamp: 'ar 7/20/1999 11:23'! superclass: aClass methodDictionary: mDict format: fmt "Basic initialization of the receiver" super superclass: aClass methodDictionary: mDict format: fmt. subclasses := nil. "Important for moving down the subclasses field into Class" ! ! !Class methodsFor: 'initialize-release' stamp: 'al 9/3/2004 13:35'! unload "Sent when a the class is removed. Does nothing, but may be overridden by (class-side) subclasses." ! ! !Class methodsFor: 'instance variables' stamp: 'StephaneDucasse 8/27/2010 11:38'! addInstVarNamed: aString "Add the argument, aString, as one of the receiver's instance variables." ^(ClassBuilder new) 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: 'instance variables' stamp: 'StephaneDucasse 8/27/2010 11:38'! 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]. ^(ClassBuilder new) 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: 'organization'! 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: 'organization'! 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: 'organization' stamp: 'di 11/16/1999 16:25'! environment environment == nil ifTrue: [^ super environment]. ^ environment! ! !Class methodsFor: 'organization' stamp: 'di 12/23/1999 11:42'! environment: anEnvironment environment := anEnvironment! ! !Class methodsFor: 'pool variables' stamp: 'tpr 5/30/2003 13:04'! 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']. sharedPools == nil ifTrue: [sharedPools := OrderedCollection with: aSharedPool] ifFalse: [sharedPools add: aSharedPool]! ! !Class methodsFor: 'pool variables' stamp: 'StephaneDucasse 12/13/2011 17:02'! 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: 'pool variables' stamp: 'tk 9/12/96'! 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: [sharedPools remove: aDictionary. sharedPools isEmpty ifTrue: [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]]]. sharedPools remove: aDictionary. sharedPools isEmpty ifTrue: [sharedPools := nil]! ! !Class methodsFor: 'pool variables' stamp: 'StephaneDucasse 12/13/2011 16:32'! sharedPools "Answer an orderedCollection of the shared pools declared in the receiver." sharedPools == nil ifTrue: [^OrderedCollection new] ifFalse: [^sharedPools]! ! !Class methodsFor: 'pool variables' stamp: 'al 9/3/2004 13:41'! sharedPools: aCollection sharedPools := aCollection! ! !Class methodsFor: 'pool variables' stamp: 'MarianoMartinezPeck 12/16/2011 11:55'! 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: 'pool variables' stamp: 'StephaneDucasse 12/13/2011 17:14'! 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: 'self evaluating' stamp: 'nice 11/5/2009 21:56'! isSelfEvaluating ^self isObsolete not! ! !Class methodsFor: 'subclass creation' stamp: 'Alexandre Bergel 6/3/2010 08:39'! 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: 'subclass creation' stamp: 'AlexandreBergel 1/26/2009 10:22'! subclass: t ^ self subclass: t instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Unclassified' ! ! !Class methodsFor: 'subclass creation' stamp: 'AlexandreBergel 1/26/2009 10:22'! subclass: t instanceVariableNames: ins ^ self subclass: t instanceVariableNames: ins classVariableNames: '' poolDictionaries: '' category: 'Unclassified' ! ! !Class methodsFor: 'subclass creation' stamp: 'GuillermoPolito 5/1/2012 11:56'! 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 := (ClassBuilder new) superclass: self subclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat. class ifNotNil: [ class setTraitComposition: {} asTraitComposition ]. ^ class ! ! !Class methodsFor: 'subclass creation' stamp: 'Alexandre Bergel 5/22/2010 14:42'! subclass: t uses: aTraitComposition | cls | cls := self subclass: t instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Unclassified'. cls setTraitComposition: aTraitComposition asTraitComposition. ^ cls! ! !Class methodsFor: 'subclass creation' stamp: 'EstebanLorenzano 7/27/2012 16:30'! subclass: t uses: aTraitCompositionOrArray instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat | newClass copyOfOldClass | copyOfOldClass := self copy. newClass := self subclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat. newClass setTraitComposition: aTraitCompositionOrArray asTraitComposition. SystemAnnouncer uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass. ^newClass! ! !Class methodsFor: 'subclass creation' stamp: 'ar 7/15/1999 18:57'! 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." ^(ClassBuilder new) superclass: self variableByteSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat ! ! !Class methodsFor: 'subclass creation' stamp: 'EstebanLorenzano 7/27/2012 16:30'! variableByteSubclass: t uses: aTraitCompositionOrArray 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." | newClass copyOfOldClass | copyOfOldClass := self copy. newClass := self variableByteSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat. newClass setTraitComposition: aTraitCompositionOrArray asTraitComposition. SystemAnnouncer uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass. ^newClass ! ! !Class methodsFor: 'subclass creation' stamp: 'ar 7/15/1999 18:56'! 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." ^(ClassBuilder new) superclass: self variableSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat ! ! !Class methodsFor: 'subclass creation' stamp: 'EstebanLorenzano 7/27/2012 16:30'! variableSubclass: t uses: aTraitCompositionOrArray 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." | newClass copyOfOldClass | copyOfOldClass := self copy. newClass := self variableSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat. newClass setTraitComposition: aTraitCompositionOrArray asTraitComposition. SystemAnnouncer uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass. ^newClass ! ! !Class methodsFor: 'subclass creation' stamp: 'ar 7/15/1999 18:56'! 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." ^(ClassBuilder new) superclass: self variableWordSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat ! ! !Class methodsFor: 'subclass creation' stamp: 'EstebanLorenzano 7/27/2012 16:30'! variableWordSubclass: t uses: aTraitCompositionOrArray 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." | newClass copyOfOldClass | copyOfOldClass := self copy. newClass := self variableWordSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat. newClass setTraitComposition: aTraitCompositionOrArray asTraitComposition. SystemAnnouncer uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass. ^newClass ! ! !Class methodsFor: 'subclass creation' stamp: 'tak 9/25/2008 15:00'! 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." ^(ClassBuilder new) superclass: self weakSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat! ! !Class methodsFor: 'subclass creation' stamp: 'EstebanLorenzano 7/27/2012 16:30'! weakSubclass: t uses: aTraitCompositionOrArray 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." | newClass copyOfOldClass | copyOfOldClass := self copy. newClass := self weakSubclass: t instanceVariableNames: f classVariableNames: d poolDictionaries: s category: cat. newClass setTraitComposition: aTraitCompositionOrArray asTraitComposition. SystemAnnouncer uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass. ^newClass ! ! !Class methodsFor: 'testing' stamp: 'StephaneDucasse 12/16/2012 23:13'! hasAbstractMethods "Tells whether the receiver locally defines an abstract method, i.e., a method sending subclassResponsibility" ^ super hasAbstractMethods or: [self class hasAbstractMethods] ! ! !Class methodsFor: 'testing'! 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: 'testing' stamp: 'StephaneDucasse 12/16/2012 18:18'! isAbstractClass self deprecated: 'Use defineAbstractMethods' on: '16 December 2012' in: #Pharo2.0. ^ (self allMethods anySatisfy: [:cm | cm sendsSelector: #subclassResponsibility ]) or: [ self class allMethods anySatisfy: [:cm | cm sendsSelector: #subclassResponsibility ] ]! ! !Class methodsFor: 'testing' stamp: 'EstebanLorenzano 2/21/2013 18:03'! isAnonymous ^name isNil! ! !Class methodsFor: 'testing' stamp: 'al 6/5/2006 13:13'! isObsolete "Return true if the receiver is obsolete." ^(self environment at: name ifAbsent: [nil]) ~~ self! ! !Class methodsFor: 'traits' stamp: 'CamilloBruni 4/27/2012 16:07'! applyChangesOfNewTraitCompositionReplacing: oldComposition "See Trait>>applyChangesOfNewTraitCompositionReplacing:" | changedSelectors | changedSelectors := super applyChangesOfNewTraitCompositionReplacing: oldComposition. self classSide noteNewBaseTraitCompositionApplied: self traitComposition. ^ changedSelectors! ! !Class methodsFor: 'viewer' stamp: 'sw 12/1/2000 20:39'! externalName "Answer a name by which the receiver can be known." ^ name! ! !Class methodsFor: 'private' stamp: 'ar 7/15/1999 15:37'! setName: aSymbol "Private - set the name of the class" name := aSymbol.! ! !Class methodsFor: 'private' stamp: 'sd 2/1/2004 15:18'! spaceUsed "Object spaceUsed" ^ super spaceUsed + self class spaceUsed! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Class class uses: TBehaviorCategorization classTrait instanceVariableNames: ''! !Class class methodsFor: 'fileIn/Out' stamp: 'SteveFreeman 7/17/2010 13:56'! allSuperclassesFor: aClass cache: cache ^ cache at: aClass ifAbsentPut: [aClass allSuperclasses asArray] ! ! !Class class methodsFor: 'fileIn/Out' stamp: 'SteveFreeman 7/17/2010 15:07'! 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: 'fileIn/Out' stamp: 'PeterHugossonMiller 9/3/2009 00:53'! 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: 'SteveFreeman 7/17/2010 15:09'! 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: 'SteveFreeman 7/17/2010 14:37'! hasNoSuperclassesOf: aClass in: unprocessedClasses cache: cache ^ (unprocessedClasses includesAnyOf: (self allSuperclassesFor: aClass cache: cache)) not ! ! !Class class methodsFor: 'fileIn/Out' stamp: 'SteveFreeman 7/17/2010 15:55'! 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: 'inquiries' stamp: 'StephaneDucasse 3/24/2010 09:49'! rootsOfTheWorld "return all classes that have a nil superclass" ^(Smalltalk globals select: [:each | each isBehavior and: [each superclass isNil]]) asOrderedCollection! ! !Class class methodsFor: 'instance creation' stamp: 'di 6/7/2000 22:01'! 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: 'instance creation' stamp: 'eem 5/7/2008 12:06'! 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: 'private' stamp: 'SteveFreeman 7/17/2010 15:35'! 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]] ! ! HelpBuilder subclass: #ClassAPIHelpBuilder instanceVariableNames: 'addSubclasses addMethods subclassesAsSeparateTopic' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Builders'! !ClassAPIHelpBuilder commentStamp: 'tbn 4/30/2010 15:37' prior: 0! 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: '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: 'accessing' stamp: 'tbn 3/8/2010 16:02'! addSubclasses ^ addSubclasses! ! !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 ^ subclassesAsSeparateTopic! ! !ClassAPIHelpBuilder methodsFor: 'accessing' stamp: 'tbn 3/8/2010 16:45'! subclassesAsSeparateTopic: anObject subclassesAsSeparateTopic := anObject! ! !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: 'initialize-release' stamp: 'tbn 3/8/2010 16:37'! initialize "Initializes the receiver" super initialize. addSubclasses := false. addMethods := true. subclassesAsSeparateTopic := true.! ! !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: '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: '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: '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 class instanceVariableNames: ''! !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 ! ! TestCase subclass: #ClassAPIHelpBuilderTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Tests-Builders'! !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' ! ! !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' ! ! SystemAnnouncement subclass: #ClassAdded instanceVariableNames: 'classAdded classCategory' classVariableNames: '' poolDictionaries: '' category: 'System-Announcements'! !ClassAdded commentStamp: 'cyrilledelaunay 1/18/2011 11:56' prior: 0! 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:46'! classAdded ^classAdded! ! !ClassAdded methodsFor: 'accessing' stamp: 'GuillermoPolito 8/1/2012 17:47'! classAdded: aClass classAdded := aClass! ! !ClassAdded methodsFor: 'accessing' stamp: 'GuillermoPolito 8/3/2012 13:50'! classAffected ^self classAdded! ! !ClassAdded methodsFor: 'accessing' stamp: 'GuillermoPolito 8/1/2012 17:51'! classCategory ^classCategory! ! !ClassAdded methodsFor: 'accessing' stamp: 'GuillermoPolito 8/1/2012 17:51'! classCategory: aClassCategoryName classCategory := aClassCategoryName! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ClassAdded class instanceVariableNames: ''! !ClassAdded class methodsFor: 'instance creation' stamp: 'GuillermoPolito 8/1/2012 17:52'! class: aClass category: aClassCategoryName ^self new classAdded: aClass; classCategory: aClassCategoryName; yourself! ! Object subclass: #ClassBuilder instanceVariableNames: 'environ classMap instVarMap progress maxClassIndex currentClassIndex' classVariableNames: 'QuietMode' poolDictionaries: '' category: 'Kernel-Classes'! !ClassBuilder commentStamp: 'ar 2/27/2003 22:55' prior: 0! Responsible for creating a new class or changing the format of an existing class (from a class definition in a browser or a fileIn). This includes validating the definition, computing the format of instances, creating or modifying the accompanying Metaclass, setting up the class and metaclass objects themselves, registering the class as a global, recompiling methods, modifying affected subclasses, mutating existing instances to the new format, and more. You typically only need to use or modify this class, or even know how it works, when making fundamental changes to how the Smalltalk system and language works. Implementation notes: ClassBuilder relies on the assumption that it can see ALL subclasses of some class. If there are any existing subclasses of some class, regardless of whether they have instances or not, regardless of whether they are considered obsolete or not, ClassBuilder MUST SEE THEM. ! !ClassBuilder methodsFor: '*UIManager' stamp: 'sd 3/28/2008 11:03'! informUserDuring: aBlock self class isSilent ifTrue: [ ^ aBlock value ]. UIManager default informUserDuring: [ :bar | progress := bar. aBlock value ]. progress := nil! ! !ClassBuilder methodsFor: 'class definition' stamp: 'EstebanLorenzano 7/27/2012 16:30'! class: oldClass instanceVariableNames: instVarString unsafe: unsafe "This is the basic initialization message to change the definition of an existing Metaclass" | instVars newClass needNew copyOfOldClass copyOfOldTraitComposition copyOfOldClassTraitComposition | environ := oldClass environment. instVars := instVarString subStrings: ' '. unsafe ifFalse:[ "Run validation checks so we know that we have a good chance for recompilation" (self validateInstvars: instVars from: oldClass forSuper: oldClass superclass) ifFalse:[^nil]. (self validateSubclassFormat: oldClass typeOfClass from: oldClass forSuper: oldClass superclass extra: instVars size) ifFalse:[^nil]]. "See if we need a new subclass or not" needNew := self needsSubclassOf: oldClass superclass type: oldClass typeOfClass instanceVariables: instVars from: oldClass. needNew ifNil:[^nil]. "some error" needNew ifFalse:[^oldClass]. "no new class needed" "Create the new class" copyOfOldClass := oldClass copy. oldClass hasTraitComposition ifTrue: [ copyOfOldTraitComposition := oldClass traitComposition copyTraitExpression ]. oldClass class hasTraitComposition ifTrue: [ copyOfOldClassTraitComposition := oldClass class traitComposition copyTraitExpression ]. newClass := self newSubclassOf: oldClass superclass type: oldClass typeOfClass instanceVariables: instVars from: oldClass. newClass := self recompile: false from: oldClass to: newClass mutate: false. "... set trait composition..." copyOfOldTraitComposition ifNotNil: [ newClass setTraitComposition: copyOfOldTraitComposition ]. copyOfOldClassTraitComposition ifNotNil: [ newClass class setTraitComposition: copyOfOldClassTraitComposition ]. self doneCompiling: newClass. SystemAnnouncer uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass. ^newClass! ! !ClassBuilder methodsFor: 'class definition' stamp: 'ar 8/29/1999 15:34'! name: className inEnvironment: env subclassOf: newSuper type: type instanceVariableNames: instVarString classVariableNames: classVarString poolDictionaries: poolString category: category "Define a new class in the given environment" ^self name: className inEnvironment: env subclassOf: newSuper type: type instanceVariableNames: instVarString classVariableNames: classVarString poolDictionaries: poolString category: category unsafe: false! ! !ClassBuilder methodsFor: 'class definition' stamp: 'EstebanLorenzano 7/27/2012 16:30'! name: className inEnvironment: env subclassOf: newSuper type: type instanceVariableNames: instVarString classVariableNames: classVarString poolDictionaries: poolString category: category unsafe: unsafe "Define a new class in the given environment. If unsafe is true do not run any validation checks. This facility is provided to implement important system changes." | oldClass instVars classVars copyOfOldClass copyOfOldTraitComposition copyOfOldClassTraitComposition newClass | environ := env. instVars := instVarString subStrings: ' '. classVars := (classVarString subStrings: ' ') collect: [ :x | x asSymbol ]. "Validate the proposed name" unsafe ifFalse: [ (self validateClassName: className) ifFalse: [ ^ nil ] ]. oldClass := env at: className ifAbsent: [ nil ]. oldClass isBehavior ifFalse: [ oldClass := nil ] ifTrue: [ copyOfOldClass := oldClass copy. copyOfOldClass superclass addSubclass: copyOfOldClass. copyOfOldClass ifNotNil: [ oldClass hasTraitComposition ifTrue: [ copyOfOldTraitComposition := oldClass traitComposition copyTraitExpression ]. oldClass class hasTraitComposition ifTrue: [ copyOfOldClassTraitComposition := oldClass class traitComposition copyTraitExpression ] ] ]. "Already checked in #validateClassName:" [ | newCategory oldCategory needNew force organization | unsafe ifFalse: [ "Run validation checks so we know that we have a good chance for recompilation" (self validateSuperclass: newSuper forSubclass: oldClass) ifFalse: [ ^ nil ]. (self validateInstvars: instVars from: oldClass forSuper: newSuper) ifFalse: [ ^ nil ]. (self validateClassvars: classVars from: oldClass forSuper: newSuper) ifFalse: [ ^ nil ]. (self validateSubclassFormat: type from: oldClass forSuper: newSuper extra: instVars size) ifFalse: [ ^ nil ] ]. "See if we need a new subclass" needNew := self needsSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass. needNew == nil ifTrue: [ ^ nil ]. "some error" (needNew and: [ unsafe not ]) ifTrue: [ "Make sure we don't redefine any dangerous classes" (self tooDangerousClasses includes: oldClass name) ifTrue: [ self error: oldClass name , ' cannot be changed' ]. "Check if the receiver should not be redefined" (oldClass ~~ nil and: [ oldClass shouldNotBeRedefined ]) ifTrue: [ self notify: oldClass name asText allBold , ' should not be redefined. \Proceed to store over it.' withCRs ] ]. needNew ifTrue: [ "Create the new class" newClass := self newSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass. newClass == nil ifTrue: [ ^ nil ]. "Some error" newClass setName: className ] ifFalse: [ "Reuse the old class" newClass := oldClass ]. "Install the class variables and pool dictionaries... " force := (newClass declare: classVarString) | (newClass sharing: poolString). "... classify ..." newCategory := category asSymbol. organization := environ ifNotNil: [ environ organization ]. oldClass isNil ifFalse: [ oldCategory := (organization categoryOfElement: oldClass name) asSymbol ]. organization classify: newClass name under: newCategory. newClass environment: environ. "... recompile ..." newClass := self recompile: force from: oldClass to: newClass mutate: false. "... export if not yet done ..." (environ at: newClass name ifAbsent: [ nil ]) == newClass ifFalse: [ environ at: newClass name put: newClass. Smalltalk globals flushClassNameCache ]. "... set trait composition..." copyOfOldTraitComposition ifNotNil: [ newClass setTraitComposition: copyOfOldTraitComposition ]. copyOfOldClassTraitComposition ifNotNil: [ newClass class setTraitComposition: copyOfOldClassTraitComposition ]. newClass doneCompiling. "... notify interested clients ..." oldClass isNil ifTrue: [ SystemAnnouncer uniqueInstance classAdded: newClass inCategory: newCategory. ^ newClass ]. newCategory ~= oldCategory ifTrue: [ SystemAnnouncer uniqueInstance class: newClass recategorizedFrom: oldCategory to: category ] ifFalse: [ SystemAnnouncer uniqueInstance classDefinitionChangedFrom: copyOfOldClass to: newClass ] ] ensure: [ copyOfOldClass ifNotNil: [ copyOfOldClass superclass removeSubclass: copyOfOldClass ]. Behavior flushObsoleteSubclasses ]. ^ newClass! ! !ClassBuilder methodsFor: 'class definition' stamp: 'ar 9/22/2002 02:57'! needsSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass "Answer whether we need a new subclass to conform to the requested changes" | newFormat | "Compute the format of the new class" newFormat := self computeFormat: type instSize: instVars size forSuper: newSuper ccIndex: (oldClass ifNil:[0] ifNotNil:[oldClass indexIfCompact]). newFormat == nil ifTrue:[^nil]. "Check if we really need a new subclass" oldClass ifNil:[^true]. "yes, it's a new class" newSuper == oldClass superclass ifFalse:[^true]. "yes, it's a superclass change" newFormat = oldClass format ifFalse:[^true]. "yes, it's a format change" instVars = oldClass instVarNames ifFalse:[^true]. "yes, it's an iVar change" ^false ! ! !ClassBuilder methodsFor: 'class definition' stamp: 'MarcusDenker 2/1/2013 11:11'! newSubclassOf: newSuper type: type instanceVariables: instVars from: oldClass "Create a new subclass of the given superclass with the given specification." | newFormat newClass | "Compute the format of the new class" newFormat := self computeFormat: type instSize: instVars size forSuper: newSuper ccIndex: (oldClass ifNil:[0] ifNotNil:[oldClass indexIfCompact]). newFormat == nil ifTrue:[^nil]. (oldClass == nil or:[oldClass isMeta not]) ifTrue:[newClass := self privateNewSubclassOf: newSuper from: oldClass] ifFalse:[newClass := oldClass shallowCopy]. newClass superclass: newSuper methodDictionary: MethodDictionary new format: newFormat; setInstVarNames: instVars. oldClass ifNotNil:[ newClass organization: oldClass organization. newClass isMeta not ifTrue: [ newClass environment at: newClass name put: newClass ]. "Recompile the new class" oldClass hasMethods ifTrue:[newClass compileAllFrom: oldClass]. self recordClass: oldClass replacedBy: newClass. ]. (oldClass == nil or:[newClass isObsolete not]) ifTrue:[newSuper addSubclass: newClass] ifFalse:[newSuper addObsoleteSubclass: newClass]. ^newClass! ! !ClassBuilder methodsFor: 'class definition' stamp: 'Alexandre.Bergel 8/19/2009 11:22'! recompile: force from: oldClass to: newClass mutate: forceMutation "Do the necessary recompilation after changine oldClass to newClass. If required (e.g., when oldClass ~~ newClass) mutate oldClass to newClass and all its subclasses. If forceMutation is true force a mutation even if oldClass and newClass are the same." oldClass == nil ifTrue:[^ newClass]. (newClass == oldClass and:[force not and:[forceMutation not]]) ifTrue:[ ^newClass]. currentClassIndex := 0. maxClassIndex := oldClass withAllSubclasses size. (oldClass == newClass and:[forceMutation not]) ifTrue:[ "Recompile from newClass without mutating" self informUserDuring:[ newClass withAllSubclassesDo:[:cl| self showProgressFor: cl. cl compileAll]]. ^newClass]. "Recompile and mutate oldClass to newClass" self informUserDuring:[ self mutate: oldClass to: newClass. ]. ^oldClass "now mutated to newClass"! ! !ClassBuilder methodsFor: 'class definition' stamp: 'EstebanLorenzano 7/27/2012 16:30'! silentlyMoveInstVarNamed: instVarName from: srcClass to: dstClass after: prevInstVarName "Move the instvar from srcClass to dstClass. Do not perform any checks." | srcVars dstVars dstIndex newClass copyOfSrcClass copyOfDstClass copyOfOldTraitComposition copyOfOldClassTraitComposition | copyOfSrcClass := srcClass copy. copyOfDstClass := dstClass copy. srcVars := srcClass instVarNames copyWithout: instVarName. srcClass == dstClass ifTrue:[dstVars := srcVars] ifFalse:[dstVars := dstClass instVarNames]. dstIndex := dstVars indexOf: prevInstVarName. dstVars := (dstVars copyFrom: 1 to: dstIndex), (Array with: instVarName), (dstVars copyFrom: dstIndex+1 to: dstVars size). instVarMap at: srcClass name put: srcVars. instVarMap at: dstClass name put: dstVars. (srcClass inheritsFrom: dstClass) ifTrue:[ copyOfOldTraitComposition := copyOfOldClassTraitComposition := nil. dstClass hasTraitComposition ifTrue: [ copyOfOldTraitComposition := dstClass traitComposition copyTraitExpression ]. dstClass class hasTraitComposition ifTrue: [ copyOfOldClassTraitComposition := dstClass class traitComposition copyTraitExpression ]. newClass := self reshapeClass: dstClass toSuper: dstClass superclass. self recompile: false from: dstClass to: newClass mutate: true. copyOfOldTraitComposition ifNotNil: [ newClass setTraitComposition: copyOfOldTraitComposition ]. copyOfOldClassTraitComposition ifNotNil: [ newClass class setTraitComposition: copyOfOldClassTraitComposition ]. ] ifFalse:[ (dstClass inheritsFrom: srcClass) ifTrue:[ newClass := self reshapeClass: srcClass toSuper: srcClass superclass. self recompile: false from: srcClass to: newClass mutate: true. ] ifFalse:[ "Disjunct hierarchies" srcClass == dstClass ifFalse:[ newClass := self reshapeClass: dstClass toSuper: dstClass superclass. self recompile: false from: dstClass to: newClass mutate: true. ]. newClass := self reshapeClass: srcClass toSuper: srcClass superclass. self recompile: false from: srcClass to: newClass mutate: true. ]. ]. self doneCompiling: srcClass. self doneCompiling: dstClass. SystemAnnouncer uniqueInstance classDefinitionChangedFrom: copyOfSrcClass to: srcClass. SystemAnnouncer uniqueInstance classDefinitionChangedFrom: copyOfDstClass to: dstClass.! ! !ClassBuilder methodsFor: 'class format' stamp: 'GuillermoPolito 4/27/2012 10:42'! computeFormat: type instSize: newInstSize forSuper: newSuper ccIndex: ccIndex "Compute the new format for making oldClass a subclass of newSuper. Return the format or nil if there is any problem." | instSize isVar isWords isPointers isWeak | type == #compiledMethod ifTrue: [ "we ensure that compiled method subclasses have as compat class index the one we receive as a argument" ^(CompiledMethod format bitClear: (16r1F bitShift: 11)) bitOr: (ccIndex bitShift: 11)]. instSize := newInstSize + (newSuper ifNil:[0] ifNotNil:[newSuper instSize]). instSize > 254 ifTrue: [self error: 'Class has too many instance variables (', instSize printString,')'. ^nil]. type == #normal ifTrue:[isVar := isWeak := false. isWords := isPointers := true]. type == #bytes ifTrue:[isVar := true. isWords := isPointers := isWeak := false]. type == #words ifTrue:[isVar := isWords := true. isPointers := isWeak := false]. type == #variable ifTrue:[isVar := isPointers := isWords := true. isWeak := false]. type == #weak ifTrue:[isVar := isWeak := isWords := isPointers := true]. (isPointers not and:[instSize > 0]) ifTrue: [self error:'A non-pointer class cannot have instance variables'. ^nil]. ^(self format: instSize variable: isVar words: isWords pointers: isPointers weak: isWeak) + (ccIndex bitShift: 11).! ! !ClassBuilder methodsFor: 'class format' stamp: 'ar 7/11/1999 06:39'! format: nInstVars variable: isVar words: isWords pointers: isPointers weak: isWeak "Compute the format for the given instance specfication." | cClass instSpec sizeHiBits fmt | self flag: #instSizeChange. " Smalltalk browseAllCallsOn: #instSizeChange. Smalltalk browseAllImplementorsOf: #fixedFieldsOf:. Smalltalk browseAllImplementorsOf: #instantiateClass:indexableSize:. " " NOTE: This code supports the backward-compatible extension to 8 bits of instSize. For now the format word is... <2 bits=instSize//64><5 bits=cClass><4 bits=instSpec><6 bits=instSize\\64><1 bit=0> But when we revise the image format, it should become... <5 bits=cClass><4 bits=instSpec><8 bits=instSize><1 bit=0> " sizeHiBits := (nInstVars+1) // 64. cClass := 0. "for now" instSpec := isWeak ifTrue:[4] ifFalse:[isPointers ifTrue: [isVar ifTrue: [nInstVars>0 ifTrue: [3] ifFalse: [2]] ifFalse: [nInstVars>0 ifTrue: [1] ifFalse: [0]]] ifFalse: [isWords ifTrue: [6] ifFalse: [8]]]. fmt := sizeHiBits. fmt := (fmt bitShift: 5) + cClass. fmt := (fmt bitShift: 4) + instSpec. fmt := (fmt bitShift: 6) + ((nInstVars+1)\\64). "+1 since prim size field includes header" fmt := (fmt bitShift: 1). "This shift plus integer bit lets wordSize work like byteSize" ^fmt! ! !ClassBuilder methodsFor: 'class mutation' stamp: 'al 7/4/2009 16:52'! mutate: oldClass to: newClass "Mutate the old class and subclasses into newClass and subclasses. Note: This method is slightly different from: #mutate:toSuper: since here we are at the root of reshaping and have two distinct roots." | copyOfOldTraitComposition copyOfOldClassTraitComposition | self showProgressFor: oldClass. "Convert the subclasses" oldClass subclasses do: [:oldSubclass | | newSubclass | copyOfOldTraitComposition := copyOfOldClassTraitComposition := nil. oldSubclass hasTraitComposition ifTrue: [ copyOfOldTraitComposition := oldSubclass traitComposition copyTraitExpression ]. oldSubclass class hasTraitComposition ifTrue: [ copyOfOldClassTraitComposition := oldSubclass class traitComposition copyTraitExpression ]. newSubclass := self reshapeClass: oldSubclass toSuper: newClass. self mutate: oldSubclass to: newSubclass. copyOfOldTraitComposition ifNotNil: [ newSubclass setTraitComposition: copyOfOldTraitComposition ]. copyOfOldClassTraitComposition ifNotNil: [ newSubclass class setTraitComposition: copyOfOldClassTraitComposition ]. ]. "And any obsolete ones" oldClass obsoleteSubclasses do: [:oldSubclass | | newSubclass | oldSubclass ifNotNil: [ copyOfOldTraitComposition := copyOfOldClassTraitComposition := nil. oldSubclass hasTraitComposition ifTrue: [ copyOfOldTraitComposition := oldSubclass traitComposition copyTraitExpression ]. oldSubclass class hasTraitComposition ifTrue: [ copyOfOldClassTraitComposition := oldSubclass class traitComposition copyTraitExpression ]. newSubclass := self reshapeClass: oldSubclass toSuper: newClass. self mutate: oldSubclass to: newSubclass. copyOfOldTraitComposition ifNotNil: [ newSubclass setTraitComposition: copyOfOldTraitComposition ]. copyOfOldClassTraitComposition ifNotNil: [ newSubclass class setTraitComposition: copyOfOldClassTraitComposition ]. ]. ]. self update: oldClass to: newClass. ^newClass! ! !ClassBuilder methodsFor: 'class mutation' stamp: 'ar 9/22/2002 03:16'! reshapeClass: oldClass toSuper: newSuper "Reshape the given class to the new super class. Recompile all the methods in the newly created class. Answer the new class." | instVars | "ar 9/22/2002: The following is a left-over from some older code. I do *not* know why we uncompact oldClass here. If you do, then please let me know so I can put a comment here..." oldClass becomeUncompact. instVars := instVarMap at: oldClass name ifAbsent:[oldClass instVarNames]. ^self newSubclassOf: newSuper type: oldClass typeOfClass instanceVariables: instVars from: oldClass! ! !ClassBuilder methodsFor: 'class mutation' stamp: 'ar 2/27/2003 23:42'! update: oldClass to: newClass "Convert oldClass, all its instances and possibly its meta class into newClass, instances of newClass and possibly its meta class. The process is surprisingly simple in its implementation and surprisingly complex in its nuances and potentially bad side effects. We can rely on two assumptions (which are critical): #1: The method #updateInstancesFrom: will not create any lasting pointers to 'old' instances ('old' is quote on quote since #updateInstancesFrom: will do a become of the old vs. the new instances and therefore it will not create pointers to *new* instances before the #become: which are *old* afterwards) #2: The non-preemptive execution of the critical piece of code guarantees that nobody can get a hold by 'other means' (such as process interruption and reflection) on the old instances. Given the above two, we know that after #updateInstancesFrom: there are no pointer to any old instances. After the forwarding become there will be no pointers to the old class or meta class either. Meaning that if we throw in a nice fat GC at the end of the critical block, everything will be gone (but see the comment right there). There's no need to worry. " | meta | meta := oldClass isMeta. "Note: Everything from here on will run without the ability to get interrupted to prevent any other process to create new instances of the old class." [ "Note: The following removal may look somewhat obscure and needs an explanation. When we mutate the class hierarchy we create new classes for any existing subclass. So it may look as if we don't have to remove the old class from its superclass. However, at the top of the hierarchy (the first class we reshape) that superclass itself is not newly created so therefore it will hold both the oldClass and newClass in its (obsolete or not) subclasses. Since the #become: below will transparently replace the pointers to oldClass with newClass the superclass would have newClass in its subclasses TWICE. With rather unclear effects if we consider that we may convert the meta-class hierarchy itself (which is derived from the non-meta class hierarchy). Due to this problem ALL classes are removed from their superclass just prior to converting them. Here, breaking the superclass/subclass invariant really doesn't matter since we will effectively remove the oldClass (become+GC) just a few lines below." oldClass superclass removeSubclass: oldClass. oldClass superclass removeObsoleteSubclass: oldClass. "Convert the instances of oldClass into instances of newClass" newClass updateInstancesFrom: oldClass. meta ifTrue:[oldClass becomeForward: newClass] ifFalse:[(Array with: oldClass with: oldClass class) elementsForwardIdentityTo: (Array with: newClass with: newClass class)]. Smalltalk garbageCollect. "Warning: Read this before you even think about removing the GC. Yes, it slows us down. Quite heavily if you have a large image. However, there's no good and simple alternative here, since unfortunately, #become: does change class pointers. What happens is that after the above become all of the instances of the old class will have a class pointer identifying them as instances of newClass. If we get our hands on any of these instances we will break immediately since their expected instance layout (that of its class, e.g., newClass) will not match their actual instance layout (that of oldClass). And getting your hands on any of those instances is really simple - just reshaping one class two times in rapid succession will do it. Reflection techniques, interrupts, etc. will only add to this problem. In the case of Metaclass things get even worse since when we recompile the entire class hierarchy we will recompile both, Metaclass and its instances (and some of its instances will have the old and some the new layout). The only easy solution to this problem would be to 'fix up' the class pointers of the old instances to point to the old class (using primitiveChangeClassTo:). But this won't work either - as we do a one-way become we would have to search the entire object memory for the oldClass and couldn't even clearly identify it unless we give it some 'special token' which sounds quite error-prone. If you really need to get rid of the GC here are some alternatives: On the image level, one could create a copy of the oldClass before becoming it into the new class and, after becoming it, 'fix up' the old instances. That would certainly work but it sounds quite complex, as we need to make sure we're not breaking any of the superclass/subclass meta/non-meta class variants. Alternatively, fix up #becomeForward on the VM-level to 'dump the source objects' of #become. This would be quite doable (just 'convert' them into a well known special class such as bitmap) yet it has problems if (accidentally or not) one of the objects in #become: appears on 'both sides of the fence' (right now, this will work ... in a way ... even though the consequences are unclear). Another alternative is to provide a dedicated primitive for this (instead of using it implicitly in become) which would allow us to dump all the existing instances right here. This is equivalent to a more general primitiveChangeClassTo: and might be worthwhile but it would likely have to keep in mind the differences between bits and pointer thingies etc. Since all of the alternatives seem rather complex and magical compared to a straight-forward GC it seems best to stick with the GC solution for now. If someone has a real need to fix this problem, that person will likely be motivated enough to check out the alternatives. Personally I'd probably go for #1 (copy the old class and remap the instances to it) since it's a solution that could be easily reverted from within the image if there's any problem with it." ] valueUnpreemptively. ! ! !ClassBuilder methodsFor: 'initialize' stamp: 'ar 3/3/2001 00:29'! doneCompiling: aClass "The receiver has finished modifying the class hierarchy. Do any necessary cleanup." aClass doneCompiling. Behavior flushObsoleteSubclasses.! ! !ClassBuilder methodsFor: 'initialize' stamp: 'alain.plantec 5/28/2009 09:47'! initialize super initialize. environ := Smalltalk. instVarMap := IdentityDictionary new.! ! !ClassBuilder methodsFor: 'public' stamp: 'ar 8/29/1999 15:38'! class: oldClass instanceVariableNames: instVarString "This is the basic initialization message to change the definition of an existing Metaclass" oldClass isMeta ifFalse:[^self error: oldClass name, 'is not a Metaclass']. ^self class: oldClass instanceVariableNames: instVarString unsafe: false! ! !ClassBuilder methodsFor: 'public' stamp: 'ar 7/19/1999 23:40'! moveInstVarNamed: instVarName from: srcClass to: dstClass after: prevInstVarName "Move the given instVar from srcClass to dstClass" (srcClass instVarNames includes: instVarName) ifFalse:[^self error: instVarName,' is not an instance variable of ', srcClass name]. (prevInstVarName isNil or:[dstClass instVarNames includes: prevInstVarName]) ifFalse:[^self error: prevInstVarName, 'is not an instance variable of', dstClass name]. (srcClass inheritsFrom: dstClass) ifTrue:[ "Move the instvar up the hierarchy." (self validateClass: srcClass forMoving: instVarName upTo: dstClass) ifFalse:[^false]. ]. (dstClass inheritsFrom: srcClass) ifTrue:[ "Move the instvar down the hierarchy" (self validateClass: srcClass forMoving: instVarName downTo: dstClass) ifFalse:[^false]. ]. ^self silentlyMoveInstVarNamed: instVarName from: srcClass to: dstClass after: prevInstVarName! ! !ClassBuilder methodsFor: 'public' stamp: 'ar 7/19/1999 23:29'! 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! ! !ClassBuilder methodsFor: 'public' stamp: 'eem 6/13/2008 10:00'! 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! ! !ClassBuilder methodsFor: 'public' stamp: 'ar 7/19/1999 23:29'! 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! ! !ClassBuilder methodsFor: 'public' stamp: 'ar 7/19/1999 23:30'! 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! ! !ClassBuilder methodsFor: 'public' stamp: 'ar 7/19/1999 23:30'! 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! ! !ClassBuilder methodsFor: 'validation' stamp: 'MarcusDenker 12/14/2009 19:34'! validateClass: srcClass forMoving: iv downTo: dstClass "Make sure that we don't have any accesses to the instVar left" srcClass withAllSubclassesDo:[:cls| (cls == dstClass or:[cls inheritsFrom: dstClass]) ifFalse:[ (cls whichSelectorsAccess: iv) isEmpty ifFalse:[ self notify: (iv printString asText allBold), ' is still used in ', cls name asText allBold,'. Proceed to move it to Undeclared'. ]. ]. ]. ^true! ! !ClassBuilder methodsFor: 'validation' stamp: 'ar 7/20/1999 00:39'! validateClass: srcClass forMoving: iv upTo: dstClass "Make sure we don't have this instvar already" dstClass withAllSubclassesDo:[:cls| (cls == srcClass or:[cls inheritsFrom: srcClass]) ifFalse:[ cls isPointers ifFalse:[ self error: dstClass name, ' cannot have instance variables'. ^false]. cls instSize >= 254 ifTrue:[ self error: cls name, ' has more than 254 instance variables'. ^false]. (cls instVarNames includes: iv) ifTrue:[ self notify: (iv printString asText allBold),' is defined in ', cls name asText allBold,' Proceed to move it up to ', dstClass name asText allBold,' as well'. instVarMap at: cls name put: (cls instVarNames copyWithout: iv)]. ]. ]. ^true! ! !ClassBuilder methodsFor: 'validation' stamp: 'MarcusDenker 3/13/2012 17:29'! validateClassName: aString "Validate the new class name" | allowed | aString isSymbol ifFalse: [ ^ false ]. allowed := ($0 to: $9), {$_}, ($A to: $Z), ($a to: $z). (aString detect: [:c | (allowed includes: c) not] ifNone: [ ]) ifNotNil: [ :c | self error: 'Invalid character: ''', c printString, ''''. ^ false]. aString first canBeGlobalVarInitial ifFalse:[ self error: 'Class names must be capitalized'. ^false]. environ at: aString ifPresent:[:old| (old isKindOf: Behavior) ifFalse:[ self notify: aString, ' already exists!!\Proceed will store over it.' withCRs]]. ^ true! ! !ClassBuilder methodsFor: 'validation' stamp: 'GuillermoPolito 1/11/2012 23:24'! validateClassvars: classVarArray from: oldClass forSuper: newSuper "Check if any of the classVars of oldClass conflict with the new superclass" | usedNames classVars temp | classVarArray isEmpty ifTrue:[^true]. "Okay" "Validate the class var names" usedNames := classVarArray asSet. usedNames size = classVarArray size ifFalse:[ classVarArray do:[:var| usedNames remove: var ifAbsent:[temp := var]]. self error: temp,' is multiply defined'. ]. (usedNames includesAnyOf: self reservedNames) ifTrue:[ self reservedNames do:[:var| (usedNames includes: var) ifTrue:[temp := var]]. self error: temp,' is a reserved name'. ]. usedNames do: [ :name | name isLegalInstVarName ifFalse: [ self error: name, ' is not a legal inst var name'. ] ]. newSuper == nil ifFalse:[ usedNames := newSuper allClassVarNames asSet. classVarArray do:[:iv| (usedNames includes: iv) ifTrue:[ newSuper withAllSuperclassesDo:[:cl| (cl classVarNames includes: iv) ifTrue:[temp := cl]]. (DuplicatedVariableError new) superclass: temp; variable: iv; signal: iv, ' is already defined in ', temp name. ^false]]]. classVars := classVarArray. oldClass == nil ifFalse:[ usedNames := Set new: 20. (oldClass allSubclasses reject: #isMeta) do: [:cl | usedNames addAll: cl classVarNames]. newSuper == nil ifFalse:[classVars := classVars, newSuper allClassVarNames asArray]. classVars do:[:iv| (usedNames includes: iv) ifTrue:[ (DuplicatedVariableError new) superclass: oldClass; variable: iv; signal: iv, ' is already defined in a subclass of ', oldClass name. ^false]]]. ^true! ! !ClassBuilder methodsFor: 'validation' stamp: 'MarcusDenker 4/29/2012 10:06'! validateInstvars: instVarArray from: oldClass forSuper: newSuper "Check if any of the instVars of oldClass conflict with the new superclass" | instVars usedNames temp | instVarArray isEmpty ifTrue:[^true]. "Okay" newSuper allowsSubInstVars ifFalse: [ self error: newSuper printString, ' does not allow subclass inst vars. See allowsSubInstVars.'. ]. "Validate the inst var names" usedNames := instVarArray asSet. usedNames size = instVarArray size ifFalse:[ instVarArray do:[:var| usedNames remove: var ifAbsent:[temp := var]]. self error: temp,' is multiply defined'. ]. (usedNames includesAnyOf: self reservedNames) ifTrue:[ self reservedNames do:[:var| (usedNames includes: var) ifTrue:[temp := var]]. self error: temp,' is a reserved name'. ]. usedNames do: [ :name | name isLegalInstVarName ifFalse: [ self error: name, ' is not a legal inst var name'. ] ]. ^true! ! !ClassBuilder methodsFor: 'validation' stamp: 'ar 7/13/2009 21:19'! validateSubclass: subclass canKeepLayoutFrom: oldClass forSubclassFormat: newType "Returns whether the immediate subclasses of oldClass can keep its layout" "Note: Squeak does not appear to model classFormat relationships.. so I'm putting some logic here. bkv 4/2/2003" "Only run this test for a real subclass - otherwise this prevents changing a class from #subclass: to #variableSubclass: etc." subclass = oldClass ifTrue:[^true]. "isWeak implies isVariant" (oldClass isVariable and: [ subclass isWeak ]) ifFalse: [ "In general we discourage format mis-matches" (subclass typeOfClass == newType) ifFalse: [ self error: subclass name,' cannot be recompiled'. ^ false ]]. ^ true! ! !ClassBuilder methodsFor: 'validation' stamp: 'bkv 4/2/2003 17:19'! validateSubclassFormat: newType from: oldClass forSuper: newSuper extra: newInstSize "Validate the # of instVars and the format of the subclasses" | deltaSize | oldClass == nil ifTrue: [^ true]. "No subclasses" "Compute the # of instvars needed for all subclasses" deltaSize := newInstSize. (oldClass notNil) ifTrue: [deltaSize := deltaSize - oldClass instVarNames size]. (newSuper notNil) ifTrue: [deltaSize := deltaSize + newSuper instSize]. (oldClass notNil and: [oldClass superclass notNil]) ifTrue: [deltaSize := deltaSize - oldClass superclass instSize]. (oldClass == nil) ifTrue: [ (deltaSize > 254) ifTrue: [ self error: 'More than 254 instance variables'. ^ false]. ^ true]. oldClass withAllSubclassesDo: [:sub | ( sub instSize + deltaSize > 254 ) ifTrue: [ self error: sub name,' has more than 254 instance variables'. ^ false]. "If we get this far, check whether the immediate subclasses of oldClass can keep its layout." (newType ~~ #normal) ifTrue: [ self validateSubclass: sub canKeepLayoutFrom: oldClass forSubclassFormat: newType ]]. ^ true! ! !ClassBuilder methodsFor: 'validation' stamp: 'ar 7/15/1999 13:50'! validateSuperclass: aSuperClass forSubclass: aClass "Check if it is okay to use aSuperClass as the superclass of aClass" aClass == nil ifTrue:["New class" (aSuperClass == nil or:[aSuperClass isBehavior and:[aSuperClass isMeta not]]) ifFalse:[self error: aSuperClass name,' is not a valid superclass'. ^false]. ^true]. aSuperClass == aClass superclass ifTrue:[^true]. "No change" (aClass isMeta) "Not permitted - meta class hierarchy is derived from class hierarchy" ifTrue:[^self error: aClass name, ' must inherit from ', aClass superclass name]. "Check for circular references" (aSuperClass ~~ nil and:[aSuperClass == aClass or:[aSuperClass inheritsFrom: aClass]]) ifTrue:[self error: aSuperClass name,' inherits from ', aClass name. ^false]. ^true! ! !ClassBuilder methodsFor: 'private' stamp: 'ar 2/27/2003 22:56'! privateNewSubclassOf: newSuper "Create a new meta and non-meta subclass of newSuper" "WARNING: This method does not preserve the superclass/subclass invariant!!" | newSuperMeta newMeta | newSuperMeta := newSuper ifNil:[Class] ifNotNil:[newSuper class]. newMeta := Metaclass new. newMeta superclass: newSuperMeta methodDictionary: MethodDictionary new format: newSuperMeta format. ^newMeta new ! ! !ClassBuilder methodsFor: 'private' stamp: 'pmm 3/13/2010 11:21'! privateNewSubclassOf: newSuper from: oldClass "Create a new meta and non-meta subclass of newSuper using oldClass as template" "WARNING: This method does not preserve the superclass/subclass invariant!!" | newSuperMeta oldMeta newMeta | oldClass ifNil:[^self privateNewSubclassOf: newSuper]. newSuperMeta := newSuper ifNil:[Class] ifNotNil:[newSuper class]. oldMeta := oldClass class. newMeta := oldMeta shallowCopy. newMeta superclass: newSuperMeta methodDictionary: MethodDictionary new format: (self computeFormat: oldMeta typeOfClass instSize: oldMeta instVarNames size forSuper: newSuperMeta ccIndex: 0); setInstVarNames: oldMeta instVarNames; organization: oldMeta organization. "Recompile the meta class" oldMeta hasMethods ifTrue:[newMeta compileAllFrom: oldMeta]. "Record the meta class change" self recordClass: oldMeta replacedBy: newMeta. "And create a new instance" ^newMeta adoptInstance: oldClass from: oldMeta! ! !ClassBuilder methodsFor: 'private' stamp: 'EstebanLorenzano 7/27/2012 16:30'! recordClass: oldClass replacedBy: newClass "Keep the changes up to date when we're moving instVars around" (instVarMap includesKey: oldClass name) ifTrue:[ SystemAnnouncer uniqueInstance classDefinitionChangedFrom: oldClass to: newClass. ].! ! !ClassBuilder methodsFor: 'private' stamp: 'gk 2/28/2005 16:35'! reservedNames "Return a list of names that must not be used for variables" ^#('self' 'super' 'thisContext' 'true' 'false' 'nil' self super thisContext #true #false #nil).! ! !ClassBuilder methodsFor: 'private' stamp: 'SeanDeNigris 6/20/2012 18:45'! showProgressFor: aClass "Announce that we're processing aClass" progress == nil ifTrue:[^self]. aClass isObsolete ifTrue:[^self]. currentClassIndex := currentClassIndex + 1. (aClass hasMethods and: [aClass wantsRecompilationProgressReported]) ifTrue: [progress label: ('Recompiling ', aClass name, ' (', currentClassIndex printString, '/', maxClassIndex printString, ')')]! ! !ClassBuilder methodsFor: 'private' stamp: 'MarcusDenker 2/25/2012 19:43'! 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" Magnitude Number SmallInteger Float "Misc other" LookupKey Association Link Point Rectangle Behavior PositionableStream UndefinedObject ) ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ClassBuilder class instanceVariableNames: ''! !ClassBuilder class methodsFor: '*UIManager' stamp: 'sd 3/28/2008 11:03'! checkClassHierarchyConsistency "Check the consistency of the class hierarchy. The class hierarchy is consistent if the following two logical equivalences hold for classes A and B: - B is obsolete and 'B superclass' yields A <--> 'A obsoleteSubclasses' contains B - B is not obsolete and 'B superclass' yields A <--> 'A subclasses' contains B" UIManager default informUserDuring: [ :bar | self checkClassHierarchyConsistency: bar ]! ! !ClassBuilder class methodsFor: '*UIManager' stamp: 'sd 3/28/2008 11:03'! cleanupAndCheckClassHierarchy "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary. Afterwards it checks whether the hierarchy is really consistent." UIManager default informUserDuring: [ :bar | self cleanupAndCheckClassHierarchy: bar ]! ! !ClassBuilder class methodsFor: '*UIManager' stamp: 'sd 3/28/2008 11:03'! cleanupClassHierarchy "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary." UIManager default informUserDuring: [ :bar | self cleanupClassHierarchy: bar ]! ! !ClassBuilder class methodsFor: 'accessing' stamp: 'ar 7/15/1999 18:50'! beSilent: aBool "ClassDefiner beSilent: true" "ClassDefiner beSilent: false" QuietMode := aBool.! ! !ClassBuilder class methodsFor: 'accessing' stamp: 'ar 7/15/1999 18:53'! beSilentDuring: aBlock "Temporarily suppress information about what is going on" | wasSilent result | wasSilent := self isSilent. self beSilent: true. result := aBlock value. self beSilent: wasSilent. ^result! ! !ClassBuilder class methodsFor: 'accessing' stamp: 'ar 7/15/1999 18:48'! isSilent ^QuietMode == true! ! !ClassBuilder class methodsFor: 'class initialization' stamp: 'GuillermoPolito 5/21/2012 01:56'! initialize QuietMode := false.! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'SeanDeNigris 6/20/2012 23:25'! checkClassHierarchyConsistency: informer "Check the consistency of the class hierarchy. The class hierarchy is consistent if the following two logical equivalences hold for classes A and B: - B is obsolete and 'B superclass' yields A <--> 'A obsoleteSubclasses' contains B - B is not obsolete and 'B superclass' yields A <--> 'A subclasses' contains B" | classes | self crTrace: 'Start checking the class hierarchy...'. Smalltalk garbageCollect. classes := Metaclass allInstances. classes keysAndValuesDo: [:index :meta | informer label: 'Validating class hierarchy ', (index * 100 // classes size) printString, '%'. meta allInstances do: [:each | self checkClassHierarchyConsistencyFor: each]. self checkClassHierarchyConsistencyFor: meta. ]. self trace: 'OK'.! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/19/2002 11:48'! checkClassHierarchyConsistencyFor: aClassDescription "Check whether aClassDescription has a consistent superclass and consistent regular and obsolete subclasses" | mySuperclass | mySuperclass := aClassDescription superclass. (mySuperclass subclasses includes: aClassDescription) = aClassDescription isObsolete ifTrue: [self error: 'Something wrong!!']. mySuperclass ifNil: [^ self]. "Obsolete subclasses of nil cannot be stored" (mySuperclass obsoleteSubclasses includes: aClassDescription) = aClassDescription isObsolete ifFalse: [self error: 'Something wrong!!']. aClassDescription subclasses do: [:each | each isObsolete ifTrue: [self error: 'Something wrong!!']. each superclass == aClassDescription ifFalse: [self error: 'Something wrong!!'] ]. aClassDescription obsoleteSubclasses do: [:each | each isObsolete ifFalse: [self error: 'Something wrong!!']. each superclass == aClassDescription ifFalse: [self error: 'Something wrong!!'] ].! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'StephaneDucasse 11/20/2011 15:33'! cleanupAndCheckClassHierarchy: informer "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary. Afterwards it checks whether the hierarchy is really consistent." self crTrace: '*** Before cleaning up ***'. self countReallyObsoleteClassesAndMetaclasses. self cleanupClassHierarchy: informer. self checkClassHierarchyConsistency: informer. self crTrace: ''; crTrace: '*** After cleaning up ***'. self countReallyObsoleteClassesAndMetaclasses.! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'SeanDeNigris 6/20/2012 23:25'! cleanupClassHierarchy: informer "Makes the class hierarchy consistent and removes obsolete classes from the SystemDictionary." | classes | self crTrace: 'Start fixing the class hierarchy and cleaning up...'. Smalltalk garbageCollect. classes := Metaclass allInstances. classes keysAndValuesDo: [:index :meta | informer label: 'Fixing class hierarchy ', (index * 100 // classes size) printString, '%'. "Check classes before metaclasses (because Metaclass>>isObsolete checks whether the related class is obsolete)" meta allInstances do: [:each | self cleanupClassHierarchyFor: each]. self cleanupClassHierarchyFor: meta. ]. self traceCr: 'DONE'.! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'lr 3/14/2010 21:13'! cleanupClassHierarchyFor: aClassDescription | myName mySuperclass | mySuperclass := aClassDescription superclass. (self isReallyObsolete: aClassDescription) ifTrue: [ "Remove class >>>from SystemDictionary if it is obsolete" myName := aClassDescription name asString. Smalltalk keys asArray do: [ :each | (each asString = myName and: [ (Smalltalk globals at: each) == aClassDescription ]) ifTrue: [ Smalltalk removeKey: each ] ]. "Make class officially obsolete if it is not" (aClassDescription name asString beginsWith: 'AnObsolete') ifFalse: [ aClassDescription obsolete ]. aClassDescription isObsolete ifFalse: [ self error: 'Something wrong!!' ]. "Add class to obsoleteSubclasses of its superclass" mySuperclass ifNil: [ self error: 'Obsolete subclasses of nil cannot be stored' ]. (mySuperclass obsoleteSubclasses includes: aClassDescription) ifFalse: [ mySuperclass addObsoleteSubclass: aClassDescription ] ] ifFalse: [ "check if superclass has aClassDescription in its obsolete subclasses" mySuperclass ifNil: [ mySuperclass := Class ]. "nil subclasses" mySuperclass removeObsoleteSubclass: aClassDescription ]. "And remove its obsolete subclasses if not actual superclass" aClassDescription obsoleteSubclasses do: [ :obs | obs superclass == aClassDescription ifFalse: [ aClassDescription removeObsoleteSubclass: obs ] ]! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'StephaneDucasse 11/7/2011 22:43'! countReallyObsoleteClassesAndMetaclasses "Counting really obsolete classes and metaclasses" | metaSize classSize | Smalltalk garbageCollect. metaSize := self reallyObsoleteMetaclasses size. self crTrace: 'Really obsolete metaclasses: ', metaSize printString. classSize := self reallyObsoleteClasses size. Transcript crTrace: 'Really obsolete classes: ', classSize printString; cr. "Metaclasses must correspond to classes!!" metaSize ~= classSize ifTrue: [self error: 'Serious metalevel inconsistency!!!!'].! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/19/2002 11:49'! isReallyObsolete: aClassDescription "Returns whether the argument class is *really* obsolete. (Due to a bug, the method isObsolete isObsolete does not always return the right answer" ^ aClassDescription isObsolete or: [(aClassDescription superclass subclasses includes: aClassDescription) not]! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/15/2002 16:52'! reallyObsoleteClasses | obsoleteClasses | obsoleteClasses := OrderedCollection new. Metaclass allInstances do: [:meta | meta allInstances do: [:each | (self isReallyObsolete: each) ifTrue: [obsoleteClasses add: each]]]. ^ obsoleteClasses! ! !ClassBuilder class methodsFor: 'cleanup obsolete classes' stamp: 'NS 2/15/2002 16:52'! reallyObsoleteMetaclasses ^ Metaclass allInstances select: [:each | self isReallyObsolete: each].! ! TestCase subclass: #ClassBuilderChangeClassTypeTest instanceVariableNames: 'baseClass subClass' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Classes'! !ClassBuilderChangeClassTypeTest methodsFor: 'utilities' stamp: 'BG 1/5/2004 22:49'! baseClassName ^'TestClassForClassChangeTest'! ! !ClassBuilderChangeClassTypeTest methodsFor: 'utilities' stamp: 'BG 1/5/2004 22:51'! cleanup baseClass ifNotNil:[baseClass removeFromSystem].! ! TestCase subclass: #ClassBuilderFormatTests instanceVariableNames: 'baseClass subClass' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Classes'! !ClassBuilderFormatTests methodsFor: 'testing' stamp: 'Janniklaval 10/23/2010 12:57'! testByteVariableSubclass "Ensure that the invariants for superclass/subclass format are preserved" baseClass := Object variableByteSubclass: self baseClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self categoryNameForTemporaryClasses. [ self shouldnt:[self makeNormalSubclassOf: baseClass] raise: Error. self deny: (subClass isPointers). self assert: (subClass isVariable). self deny: (subClass isWeak). self assert: (subClass isBytes). subClass removeFromSystem. "pointer classes" self should:[self makeIVarsSubclassOf: baseClass] raise: Error. self should:[self makeVariableSubclassOf: baseClass] raise: Error. self should:[self makeWeakSubclassOf: baseClass] raise: Error. "bit classes" self shouldnt:[self makeByteVariableSubclassOf: baseClass] raise: Error. self deny: (subClass isPointers). self assert: (subClass isVariable). self deny: (subClass isWeak). self assert: (subClass isBytes). subClass removeFromSystem. self should:[self makeWordVariableSubclassOf: baseClass] raise: Error. ] ensure:[self cleanup].! ! !ClassBuilderFormatTests methodsFor: 'testing' stamp: 'Janniklaval 10/23/2010 12:57'! testChangeToVariableSubclass "Ensure that the invariants for superclass/subclass format are preserved" baseClass := Object subclass: self baseClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self categoryNameForTemporaryClasses. [ self shouldnt:[baseClass := Object variableSubclass: self baseClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self categoryNameForTemporaryClasses] raise: Error. ] ensure:[self cleanup].! ! !ClassBuilderFormatTests methodsFor: 'testing' stamp: 'Janniklaval 10/23/2010 14:43'! testDuplicateClassVariableError baseClass := Object subclass: self baseClassName instanceVariableNames: '' classVariableNames: 'TestVar' poolDictionaries: '' category: self categoryNameForTemporaryClasses. self should:[ subClass := baseClass subclass: self subClassName instanceVariableNames: '' classVariableNames: 'TestVar' poolDictionaries: '' category: self categoryNameForTemporaryClasses ] raise: DuplicatedVariableError. [subClass := baseClass subclass: self subClassName instanceVariableNames: '' classVariableNames: 'TestVar' poolDictionaries: '' category: self categoryNameForTemporaryClasses ] on: DuplicatedVariableError do:[:ex| self assert: ex superclass == baseClass. self assert: ex variable = 'TestVar'. ex resume. ]. self shouldnt:[ baseClass := Object subclass: self baseClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self categoryNameForTemporaryClasses. ] raise: DuplicatedVariableError.! ! !ClassBuilderFormatTests methodsFor: 'testing' stamp: 'Janniklaval 10/23/2010 13:33'! testSubclass "Ensure that the invariants for superclass/subclass format are preserved" baseClass := Object subclass: self baseClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self categoryNameForTemporaryClasses. [ self shouldnt:[self makeNormalSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self deny: (subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. "pointer classes" self shouldnt:[self makeIVarsSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self deny: (subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. self shouldnt:[self makeVariableSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self assert:(subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. self shouldnt:[self makeWeakSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self assert:(subClass isVariable). self assert:(subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. "bit classes" self shouldnt:[self makeByteVariableSubclassOf: baseClass] raise: Error. self deny: (subClass isPointers). self assert: (subClass isVariable). self deny: (subClass isWeak). self assert: (subClass isBytes). subClass removeFromSystem. self shouldnt:[self makeWordVariableSubclassOf: baseClass] raise: Error. self deny: (subClass isPointers). self assert: (subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. ] ensure:[self cleanup].! ! !ClassBuilderFormatTests methodsFor: 'testing' stamp: 'Janniklaval 10/23/2010 13:34'! testSubclassWithInstanceVariables "Ensure that the invariants for superclass/subclass format are preserved" baseClass := Object subclass: self baseClassName instanceVariableNames: 'var1 var2' classVariableNames: '' poolDictionaries: '' category: self categoryNameForTemporaryClasses. [ self shouldnt:[self makeNormalSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self deny: (subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. "pointer classes" self shouldnt:[self makeIVarsSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self deny: (subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. self shouldnt:[self makeVariableSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self assert: (subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. self shouldnt:[self makeWeakSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self assert: (subClass isVariable). self assert: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. "bit classes" self should:[self makeByteVariableSubclassOf: baseClass] raise: Error. self should:[self makeWordVariableSubclassOf: baseClass] raise: Error. ] ensure:[self cleanup].! ! !ClassBuilderFormatTests methodsFor: 'testing' stamp: 'Janniklaval 10/23/2010 13:34'! testVariableSubclass "Ensure that the invariants for superclass/subclass format are preserved" baseClass := Object variableSubclass: self baseClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self categoryNameForTemporaryClasses. [ "pointer classes" self shouldnt:[self makeNormalSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self assert: (subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. self shouldnt:[self makeIVarsSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self assert: (subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. self shouldnt:[self makeVariableSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self assert: (subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. self shouldnt:[self makeWeakSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self assert: (subClass isVariable). self assert: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. "bit classes" self should:[self makeByteVariableSubclassOf: baseClass] raise: Error. self should:[self makeWordVariableSubclassOf: baseClass] raise: Error. ] ensure:[self cleanup].! ! !ClassBuilderFormatTests methodsFor: 'testing' stamp: 'Janniklaval 10/23/2010 13:34'! testWeakSubclass "Ensure that the invariants for superclass/subclass format are preserved" baseClass := Object weakSubclass: self baseClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self categoryNameForTemporaryClasses. [ "pointer classes" self shouldnt:[self makeNormalSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self assert: (subClass isVariable). self assert: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. self shouldnt:[self makeIVarsSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self assert: (subClass isVariable). self assert: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. self shouldnt:[self makeVariableSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self assert: (subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. self shouldnt:[self makeWeakSubclassOf: baseClass] raise: Error. self assert: (subClass isPointers). self assert: (subClass isVariable). self assert: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. "bit classes" self should:[self makeByteVariableSubclassOf: baseClass] raise: Error. self should:[self makeWordVariableSubclassOf: baseClass] raise: Error. ] ensure:[self cleanup].! ! !ClassBuilderFormatTests methodsFor: 'testing' stamp: 'Janniklaval 10/23/2010 13:34'! testWordVariableSubclass "Ensure that the invariants for superclass/subclass format are preserved" baseClass := Object variableWordSubclass: self baseClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self categoryNameForTemporaryClasses. [ self shouldnt:[self makeNormalSubclassOf: baseClass] raise: Error. self deny: (subClass isPointers). self assert: (subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. "pointer classes" self should:[self makeIVarsSubclassOf: baseClass] raise: Error. self should:[self makeVariableSubclassOf: baseClass] raise: Error. self should:[self makeWeakSubclassOf: baseClass] raise: Error. "bit classes" self should:[self makeByteVariableSubclassOf: baseClass] raise: Error. self shouldnt:[self makeWordVariableSubclassOf: baseClass] raise: Error. self deny: (subClass isPointers). self assert: (subClass isVariable). self deny: (subClass isWeak). self deny: (subClass isBytes). subClass removeFromSystem. ] ensure:[self cleanup].! ! !ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:15'! baseClassName ^#DummyClassBuilderFormatTestSuperClass! ! !ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'Janniklaval 10/23/2010 14:07'! categoryNameForTemporaryClasses "Answer the category where to classify temporarily created classes" ^'Dummy-Tests-ClassBuilder'! ! !ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'StephaneDucasse 6/3/2012 22:27'! cleanup (subClass isNil or: [ subClass isObsolete ]) ifFalse:[ subClass removeFromSystem ]. (baseClass isNil or: [ baseClass isObsolete ]) ifFalse: [ baseClass removeFromSystem ]. (Smalltalk organization listAtCategoryNamed: self categoryNameForTemporaryClasses) isEmpty ifTrue: [Smalltalk organization removeCategory: self categoryNameForTemporaryClasses]! ! !ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'Janniklaval 10/23/2010 12:52'! makeByteVariableSubclassOf: aClass subClass := aClass variableByteSubclass: self subClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self categoryNameForTemporaryClasses! ! !ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'Janniklaval 10/23/2010 12:55'! makeIVarsSubclassOf: aClass subClass := aClass subclass: self subClassName instanceVariableNames: 'var3 var4' classVariableNames: '' poolDictionaries: '' category: self categoryNameForTemporaryClasses! ! !ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'Janniklaval 10/23/2010 12:56'! makeNormalSubclassOf: aClass subClass := aClass subclass: self subClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self categoryNameForTemporaryClasses! ! !ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'Janniklaval 10/23/2010 12:56'! makeVariableSubclassOf: aClass subClass := aClass variableSubclass: self subClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self categoryNameForTemporaryClasses.! ! !ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'Janniklaval 10/23/2010 12:56'! makeWeakSubclassOf: aClass subClass := aClass weakSubclass: self subClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self categoryNameForTemporaryClasses! ! !ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'Janniklaval 10/23/2010 12:56'! makeWordVariableSubclassOf: aClass subClass := aClass variableWordSubclass: self subClassName instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: self categoryNameForTemporaryClasses! ! !ClassBuilderFormatTests methodsFor: 'utilities' stamp: 'ar 1/4/2004 20:16'! subClassName ^#DummyClassBuilderFormatTestSubClass! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ClassBuilderFormatTests class instanceVariableNames: ''! !ClassBuilderFormatTests class methodsFor: 'testing' stamp: 'JorgeRessia 3/16/2010 20:23'! isUnitTest ^false! ! TestCase subclass: #ClassBuilderValidationTests instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Classes'! !ClassBuilderValidationTests methodsFor: 'testing' stamp: 'hfm 4/5/2010 04:29'! testCreateClassWithString self assert: ( Object subclass: 'Test1' instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Tests-ClassBuilder' ) equals: nil.! ! Object subclass: #ClassCategoryReader instanceVariableNames: 'class category changeStamp' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Classes'! !ClassCategoryReader commentStamp: '' prior: 0! I represent a mechanism for retrieving class descriptions stored on a file.! !ClassCategoryReader methodsFor: '*CodeImport' stamp: 'GuillermoPolito 5/5/2012 02:32'! compileSourceCode: someSourceCode self theClass compile: someSourceCode classified: category withStamp: changeStamp notifying: nil! ! !ClassCategoryReader methodsFor: '*CodeImport' stamp: 'GuillermoPolito 5/5/2012 02:13'! importCodeFrom: aCodeImporter aCodeImporter importClassCategory: self.! ! !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: '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 ! ! !ClassCategoryReader methodsFor: 'private' stamp: 'ajh 1/18/2002 01:14'! theClass ^ class! ! Object subclass: #ClassChangeRecord instanceVariableNames: 'changeTypes priorDefinition thisName priorName methodChanges' classVariableNames: '' poolDictionaries: '' category: 'System-Changes'! !ClassChangeRecord commentStamp: '' prior: 0! 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: '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: '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: 'all changes' stamp: 'di 3/28/2000 10:59'! hasNoChanges ^ changeTypes isEmpty and: [methodChanges isEmpty]! ! !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: 'all changes' stamp: 'di 3/28/2000 15:14'! noteChangeType: changeSymbol ^ self noteChangeType: changeSymbol fromClass: nil! ! !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: '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/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: 'definition' stamp: 'di 3/27/2000 22:08'! notePriorDefinition: oldClass oldClass ifNil: [^ self]. priorDefinition ifNil: [priorDefinition := oldClass definition]! ! !ClassChangeRecord methodsFor: 'definition' stamp: 'di 3/28/2000 09:12'! priorDefinition ^ priorDefinition! ! !ClassChangeRecord methodsFor: 'initialization' stamp: 'MarcusDenker 12/21/2012 12:01'! initFor: className changeTypes := IdentitySet new. methodChanges := IdentityDictionary new. priorName := thisName := className.! ! !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: 'di 3/28/2000 11:01'! atSelector: selector put: changeType (self findOrMakeMethodChangeAt: selector priorMethod: nil) noteChangeType: changeType! ! !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: 'method changes' stamp: 'MarcusDenker 8/25/2010 20:54'! findOrMakeMethodChangeAt: selector priorMethod: priorMethod ^methodChanges at: selector ifAbsentPut: [MethodChangeRecord new]! ! !ClassChangeRecord methodsFor: 'method changes' stamp: 'di 3/29/2000 16:26'! infoFromRemoval: selector ^ (methodChanges at: selector ifAbsent: [^ nil]) methodInfoFromRemoval ! ! !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: 'method changes' stamp: 'di 4/1/2000 23:49'! methodChanges ^ methodChanges! ! !ClassChangeRecord methodsFor: 'method changes' stamp: 'MarcusDenker 12/21/2012 12:00'! noteNewMethod: newMethod selector: selector priorMethod: methodOrNil | methodChange | methodChange := self findOrMakeMethodChangeAt: selector priorMethod: methodOrNil. methodOrNil isNil ifTrue: [ methodChange noteChangeType: #add ] ifFalse: [ methodChange noteChangeType: #change ].! ! !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: '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: 'removal' stamp: 'MarcusDenker 8/25/2010 21:02'! forgetChangesIn: otherRecord "See forgetAllChangesFoundIn:. Used in culling changeSets." | cls otherMethodChanges | (cls := self realClass) isNil ifTrue: [ ^ 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: '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]! ! !ClassChangeRecord methodsFor: 'rename' stamp: 'di 5/8/2000 20:39'! noteNewName: newName thisName := newName! ! !ClassChangeRecord methodsFor: 'rename' stamp: 'di 3/24/2000 09:38'! priorName ^ priorName! ! !ClassChangeRecord methodsFor: 'rename' stamp: 'tk 6/8/2001 09:11'! thisName ^ thisName! ! BehaviorInstallingDeclaration subclass: #ClassCommentDeclaration instanceVariableNames: 'stamp' classVariableNames: '' poolDictionaries: '' category: 'CodeImport'! !ClassCommentDeclaration commentStamp: '' prior: 0! 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: 'accessing' stamp: 'GuillermoPolito 5/5/2012 20:37'! stamp: classCommentStamp stamp := classCommentStamp! ! !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 class instanceVariableNames: ''! !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! ! ClassCategoryReader subclass: #ClassCommentReader instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Classes'! !ClassCommentReader methodsFor: '*CodeImport' stamp: 'GuillermoPolito 5/5/2012 02:13'! importCodeFrom: aCodeImporter aCodeImporter importClassComment: self.! ! !ClassCommentReader methodsFor: '*CodeImport' stamp: 'GuillermoPolito 5/5/2012 02:33'! setClassComment: aClassComment self theClass theNonMetaClass classComment: aClassComment stamp: changeStamp! ! !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 methodsFor: 'fileIn/Out' stamp: 'tk 1/27/2000 22:56'! scanFromNoCompile: 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." self scanFrom: aStream. "for comments, the same as usual"! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ClassCommentReader class instanceVariableNames: ''! !ClassCommentReader class methodsFor: 'instance creation' stamp: 'AndrewBlack 9/1/2009 06:42'! forClass: aClass ^ self new setClass: aClass category: #Comment ! ! VersionsBrowser subclass: #ClassCommentVersionsBrowser instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tools-Changes'! !ClassCommentVersionsBrowser commentStamp: 'StephaneDucasse 1/7/2011 17:48' prior: 0! A tool to read and browse class comment versions.! !ClassCommentVersionsBrowser methodsFor: 'basic function' stamp: 'sd 11/20/2005 21:26'! 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 := self selectedClass. (listIndex == changeList size or: [class == nil]) ifTrue: [^ later]. earlier := (changeList at: listIndex + 1) text. ^ TextDiffBuilder buildDisplayPatchFrom: earlier to: later inClass: class prettyDiffs: self showingPrettyDiffs! ! !ClassCommentVersionsBrowser methodsFor: 'basic function' stamp: 'sd 11/20/2005 21:26'! reformulateList classOfMethod organization classComment ifNil: [^ self]. self scanVersionsOf: classOfMethod. self changed: #list. "for benefit of mvc" listIndex := 1. self changed: #listIndex. self contentsChanged! ! !ClassCommentVersionsBrowser methodsFor: 'basic function' stamp: 'sd 11/20/2005 21:26'! scanVersionsOf: class "Scan for all past versions of the class comment of the given class" | oldCommentRemoteStr sourceFilesCopy position prevPos stamp preamble tokens prevFileIndex | classOfMethod := class. oldCommentRemoteStr := class organization commentRemoteStr. currentCompiledMethod := oldCommentRemoteStr. selectorOfMethod := #Comment. changeList := OrderedCollection new. list := OrderedCollection new. listIndex := 0. oldCommentRemoteStr ifNil:[^ nil] ifNotNil: [oldCommentRemoteStr sourcePointer]. sourceFilesCopy := SourceFiles collect: [:x | x isNil ifTrue: [ nil ] ifFalse: [x readOnlyCopy]]. position := oldCommentRemoteStr position. file := sourceFilesCopy at: oldCommentRemoteStr sourceFileNumber. [position notNil & file notNil] whileTrue: [file position: (0 max: position-150). " Skip back to before the preamble" [file position < (position-1)] "then pick it up from the front" whileTrue: [preamble := file nextChunk]. prevPos := nil. stamp := ''. (preamble findString: 'commentStamp:' startingAt: 1) > 0 ifTrue: [tokens := Scanner new scanTokens: preamble. (tokens at: tokens size-3) = #commentStamp: ifTrue: ["New format gives change stamp and unified prior pointer" stamp := tokens at: tokens size-2. prevPos := tokens last. prevFileIndex := sourceFilesCopy fileIndexFromSourcePointer: prevPos. prevPos := sourceFilesCopy filePositionFromSourcePointer: prevPos]] ifFalse: ["The stamp get lost, maybe after a condenseChanges" stamp := '']. self addItem: (ChangeRecord new file: file position: position type: #classComment class: class name category: nil meta: class stamp: stamp) text: stamp , ' ' , class name , ' class comment'. prevPos = 0 ifTrue:[prevPos := nil]. position := prevPos. prevPos notNil ifTrue:[file := sourceFilesCopy at: prevFileIndex]]. sourceFilesCopy do: [:x | x notNil ifTrue: [x close]]. listSelections := Array new: list size withAll: false! ! !ClassCommentVersionsBrowser methodsFor: 'basic function' stamp: 'sd 11/20/2005 21:26'! updateListsAndCodeIn: aWindow | aComment | aComment := classOfMethod organization commentRemoteStr. aComment == currentCompiledMethod ifFalse: ["Do not attempt to formulate if there is no source pointer. It probably means it has been recompiled, but the source hasn't been written (as during a display of the 'save text simply?' confirmation)." aComment last ~= 0 ifTrue: [self reformulateList]]. ^ true ! ! !ClassCommentVersionsBrowser methodsFor: 'menu' 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 s1 s2 | listIndex = 0 ifTrue: [^ self]. change := changeList at: listIndex. s1 := classOfMethod organization classComment. s2 := change string. s1 = s2 ifTrue: [^ self inform: 'Exact Match']. (StringHolder new textContents: (TextDiffBuilder buildDisplayPatchFrom: s1 to: s2 inClass: classOfMethod prettyDiffs: self showingPrettyDiffs)) openLabel: 'Comparison to Current Version'! ! !ClassCommentVersionsBrowser methodsFor: 'menu' stamp: 'asm 8/13/2002 21:02'! offerVersionsHelp (StringHolder new contents: self versionsHelpString) openLabel: 'Class Comment Versions Browsers'! ! !ClassCommentVersionsBrowser methodsFor: 'menu' stamp: 'EstebanLorenzano 1/31/2013 19:25'! versionsMenu: aMenu "Fill aMenu with menu items appropriate to the receiver" aMenu title: 'Versions'. aMenu addStayUpItemSpecial. aMenu addAllFromPragma: 'classCommentVersionsListMenu' target: self. ^aMenu ! ! !ClassCommentVersionsBrowser methodsFor: 'misc' stamp: 'sw 8/17/2002 21:57'! classCommentIndicated "Answer whether the receiver is pointed at a class comment" ^ true! ! !ClassCommentVersionsBrowser methodsFor: 'misc' stamp: 'tbn 7/6/2010 16:41'! contentsSymbolQuints "Answer a list of quintuplets representing information on the alternative views available in the code pane" ^ #( (source togglePlainSource showingPlainSourceString 'Source' 'the textual source code as writen') (showDiffs toggleRegularDiffing showingRegularDiffsString 'ShowDiffs' 'the textual source diffed from its prior version'))! ! !ClassCommentVersionsBrowser methodsFor: 'misc' stamp: 'sd 11/20/2005 21:26'! priorSourceOrNil "If the currently-selected method has a previous version, return its source, else return nil" | aClass aSelector changeRecords | (aClass := self selectedClass) ifNil: [^ nil]. (aSelector := self selectedMessageName) ifNil: [^ nil]. changeRecords := self class commentRecordsOf: self selectedClass. (changeRecords == nil or: [changeRecords size <= 1]) ifTrue: [^ nil]. ^ (changeRecords at: 2) string ! ! !ClassCommentVersionsBrowser methodsFor: 'misc' stamp: 'asm 8/13/2002 20:59'! selectedClass "Answer the class currently selected in the browser. In the case of a VersionsBrowser, the class and selector are always the same, regardless of which version is selected and indeed whether or not any entry is selected in the list pane" ^ classOfMethod! ! !ClassCommentVersionsBrowser methodsFor: 'misc' stamp: 'sw 8/15/2002 22:35'! wantsPrettyDiffOption "Answer whether pretty-diffs are meaningful for this tool" ^ false! ! !ClassCommentVersionsBrowser methodsFor: 'shout' stamp: 'BenjaminVanRyseghem 7/13/2012 14:14'! shoutAboutToStyle: aPluggableShoutMorphOrView ^ false! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ClassCommentVersionsBrowser class instanceVariableNames: ''! !ClassCommentVersionsBrowser class methodsFor: 'instance creation' stamp: 'nice 1/5/2010 15:59'! browseCommentOf: class Cursor read showWhile: [ | changeList |changeList := self new scanVersionsOf: class. changeList ifNil: [^ self inform: 'No versions available']. self open: changeList name: 'Recent versions of ',class name,'''s comments' multiSelect: false ] ! ! !ClassCommentVersionsBrowser class methodsFor: 'menu' stamp: 'EstebanLorenzano 1/31/2013 18:29'! classCommentVersionsListMenu: aBuilder | target | target := aBuilder model. (aBuilder item: #'Compare to current') help: 'Compare selected version to the current version'; target: target; selector: #compareToCurrentVersion. (aBuilder item: #'Revert to selected version') help: 'Resubmit the selected version, so that it becomes the current version'; target: target; selector: #fileInSelections. (aBuilder item: #'Remove from changes') help: 'Remove this method from the current change set, if present'; target: target; selector: #removeMethodFromChanges. (aBuilder item: #'Toggle diffing') keyText: 'D'; help: 'Toggle whether or not diffs should be shown here'; target: target; selector: #toggleDiffing. (aBuilder item: #'Update list') help: 'Reformulate the list of versions, in case it somehow got out of synch with reality'; target: target; selector: #reformulateList. (aBuilder item: #'Help...') help: 'Provide an explanation of the use of this tool'; target: target; selector: #offerVersionsHelp. ! ! !ClassCommentVersionsBrowser class methodsFor: 'utilities' stamp: 'sd 11/20/2005 21:28'! commentRecordsOf: aClass "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." | aList | aList := self new scanVersionsOf: aClass. ^ aList ifNotNil: [aList changeList]! ! !ClassCommentVersionsBrowser class methodsFor: 'utilities' stamp: 'sd 11/20/2005 21:28'! timeStampFor: aSelector class: aClass reverseOrdinal: anInteger "Answer the time stamp corresponding to some version of the given method, nil if none. The reverseOrdinal parameter is interpreted as: 1 = current version; 2 = last-but-one version, etc." | aChangeList | aChangeList := self new scanVersionsOf: aClass. ^ aChangeList ifNil: [nil] ifNotNil: [aChangeList list size >= anInteger ifTrue: [(aChangeList changeList at: anInteger) stamp] ifFalse: [nil]]! ! !ClassCommentVersionsBrowser 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 fromRgbTriplet: #(0.769 0.653 1.0) ! ! SystemAnnouncement subclass: #ClassCommented instanceVariableNames: 'newStamp newComment classCommented oldComment oldStamp' classVariableNames: '' poolDictionaries: '' category: 'System-Announcements'! !ClassCommented commentStamp: '' prior: 0! This announcement will be emitted when a class or a trait comment changes! !ClassCommented methodsFor: 'accessing' stamp: 'GuillermoPolito 8/3/2012 13:51'! classAffected ^self classCommented! ! !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'! newComment ^newComment! ! !ClassCommented methodsFor: 'accessing' stamp: 'GuillermoPolito 8/1/2012 23:55'! newComment: aNewComment newComment := aNewComment! ! !ClassCommented methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:13'! newStamp ^newStamp! ! !ClassCommented methodsFor: 'accessing' stamp: 'GuillermoPolito 8/1/2012 23:54'! newStamp: aNewStamp newStamp := aNewStamp! ! !ClassCommented methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:13'! oldComment oldComment! ! !ClassCommented methodsFor: 'accessing' stamp: 'GuillermoPolito 8/1/2012 23:55'! oldComment: andOldComment oldComment := andOldComment! ! !ClassCommented methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:14'! oldStamp oldStamp! ! !ClassCommented methodsFor: 'accessing' stamp: 'GuillermoPolito 8/1/2012 23:55'! oldStamp: anOldStamp oldStamp := anOldStamp! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ClassCommented class instanceVariableNames: ''! !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! ! Behavior subclass: #ClassDescription uses: TClassAndTraitDescription - {#removeSelector:} instanceVariableNames: 'instanceVariables organization' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Classes'! !ClassDescription commentStamp: '' prior: 0! 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. The slots 'organization' and 'methodDict' should ONLY be accessed by message in order for things to work during ImageSegment>>discoverActiveClasses (q.v.).! !ClassDescription methodsFor: '*Fuel' stamp: 'MartinDias 12/22/2011 15:24'! 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 := superclass notNil ifTrue: [superclass instSize] ifFalse: [0]) > 0 ifTrue: [superclass instanceVariableNamesDo: anUnaryBlock]. 1 to: self instSize - superInstSize do: [:i| anUnaryBlock value: (instanceVariables at: i)]! ! !ClassDescription methodsFor: '*FuelTests'! duringTestCompileSilently: code ^ Author useAuthor: 'TestsAuthor' during: [ [self compile: code classified: '' withStamp: nil notifying: nil logSource: true] fuelValueWithoutNotifications ]! ! !ClassDescription methodsFor: '*FuelTests'! duringTestCompileSilently: code classified: aCategory ^ Author useAuthor: 'TestsAuthor' during: [ SystemAnnouncer uniqueInstance suspendAllWhile: [self compile: code classified: aCategory withStamp: nil notifying: nil logSource: true]. ]! ! !ClassDescription methodsFor: '*NautilusCommon'! 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: '*Spec-Builder' stamp: 'BenjaminVanRyseghem 2/27/2012 07:50'! compileWithoutReturn: code classified: heading self compile: code classified: heading! ! !ClassDescription methodsFor: '*System-Support'! 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: '*refactoring-core-deprecated' stamp: 'lr 10/31/2009 17:30'! metaclass self deprecated: 'Use aClass>>#theMetaClass instead'. ^ self theMetaClass! ! !ClassDescription methodsFor: '*refactoring-core-deprecated' stamp: 'lr 10/31/2009 17:31'! nonMetaclass self deprecated: 'Use aClass>>#theNonMetaClass instead'. ^ self theNonMetaClass! ! !ClassDescription methodsFor: '*refactoring-core-fixes' stamp: 'lr 5/15/2010 18:12'! whichSelectorsReallyRead: aString "This is a modified version of #whichSelectorsRead: that does exclude the writers." | index | index := self instVarIndexFor: aString ifAbsent: [ ^ IdentitySet new ]. ^ methodDict keys select: [ :each | (methodDict at: each) readsField: index ]! ! !ClassDescription methodsFor: '*rpackage-core' stamp: 'sd 10/29/2009 20:31'! 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: '*rpackage-core' stamp: 'StephaneDucasse 6/3/2012 22:35'! extendingPackages "the extending packages of a class are the packages that extend it." ^ RPackage organizer extendingPackagesOf: self ! ! !ClassDescription methodsFor: '*rpackage-core' stamp: 'StephaneDucasse 4/20/2010 22:10'! isDefinedInPackage: aPackage "returns true if aPackage contains the definitino of this class" ^ aPackage includesClass: self. ! ! !ClassDescription methodsFor: '*rpackage-core' stamp: 'StephaneDucasse 5/15/2010 19:54'! isExtended ^ self extendingPackages isEmpty! ! !ClassDescription methodsFor: '*rpackage-core' stamp: 'tg 3/16/2010 17:53'! isExtendedInPackage: aPackage "returns true if aPackage defines an extension to this class" ^ aPackage extendsClass: self. ! ! !ClassDescription methodsFor: '*rpackage-core' stamp: 'StephaneDucasse 6/3/2012 22:35'! package ^ RPackage organizer packageOf: self. ! ! !ClassDescription methodsFor: '*rpackage-core' stamp: 'tg 3/16/2010 17:36'! packageFromOrganizer: anOrganizer "returns the package that defines this class" ^ anOrganizer packageOf: self. ! ! !ClassDescription methodsFor: '*rpackage-core' stamp: 'StephaneDucasse 6/3/2012 22:34'! packageOrganizer "Returns the organizer of this class" ^ RPackage organizer ! ! !ClassDescription methodsFor: '*rpackage-core' stamp: 'sd 5/19/2010 16:31'! packages "the extending packages of a class are the packages that extend it." ^ self extendingPackages asSet copy add: self package; yourself! ! !ClassDescription methodsFor: 'accessing' stamp: 'CamilloBruni 8/1/2012 16:02'! classVersion "Default. Any class may return a later version to inform readers that use ReferenceStream. This method allows you to distinguish between class versions when the shape of the class hasn't changed (when there's no change in the instVar names). In the conversion methods you usually can tell by the inst var names what old version you have. In a few cases, though, the same inst var names were kept but their interpretation changed (like in the layoutFrame). By changing the class version when you keep the same instVars you can warn older and newer images that they have to convert." ^ 0! ! !ClassDescription methodsFor: 'accessing' stamp: 'Alexandre Bergel 4/27/2010 14:08'! version "Allows polymorphism with TraitDescription>>version" ^ self classVersion! ! !ClassDescription methodsFor: 'accessing class hierarchy' stamp: 'di 2/17/2000 22:36'! classesThatImplementAllOf: selectorSet "Return an array of any classes that implement all the messages in selectorSet." | found remaining | found := OrderedCollection new. selectorSet do: [:sel | (self methodDict includesKey: 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: 'accessing class hierarchy' stamp: 'StephaneDucasse 10/6/2010 19:46'! 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 class hierarchy' stamp: 'al 11/28/2005 11:51'! 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: 'accessing class hierarchy' stamp: 'al 11/28/2005 11:52'! subclasses ^ Array new! ! !ClassDescription methodsFor: 'accessing class hierarchy' stamp: 'al 11/28/2005 11:52'! subclassesDo: aBlock "Evaluate the argument, aBlock, for each of the receiver's immediate subclasses." ^self subclasses do: aBlock! ! !ClassDescription methodsFor: 'accessing comment' stamp: 'PeterHugossonMiller 9/3/2009 00:54'! 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.'; 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: 'accessing comment'! 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: 'accessing comment'! comment: aStringOrText "Set the receiver's comment to be the argument, aStringOrText." self instanceSide classComment: aStringOrText.! ! !ClassDescription methodsFor: 'accessing comment'! comment: aStringOrText stamp: aStamp "Set the receiver's comment to be the argument, aStringOrText." self instanceSide classComment: aStringOrText stamp: aStamp.! ! !ClassDescription methodsFor: 'accessing comment'! hasComment "return whether this class truly has a comment other than the default" | org | org := self instanceSide organization. ^org classComment isEmptyOrNil not! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: 'EstebanLorenzano 3/1/2013 14:42'! addAndClassifySelector: selector withMethod: compiledMethod inProtocol: category notifying: requestor | priorMethodOrNil oldProtocol newProtocol | priorMethodOrNil := self compiledMethodAt: selector ifAbsent: [nil]. self addSelectorSilently: selector withMethod: compiledMethod. oldProtocol := self organization categoryOfElement: selector. SystemAnnouncer uniqueInstance suspendAllWhile: [ self organization classify: selector under: category ]. newProtocol := self organization categoryOfElement: selector. priorMethodOrNil isNil 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" newProtocol = oldProtocol ifFalse: [ | oldPackage newPackage | "Check for repackage" newPackage := RPackage organizer packageForProtocol: newProtocol inClass: self. oldPackage := RPackage organizer packageForProtocol: oldProtocol inClass: self. (newPackage = oldPackage) ifFalse: [ SystemAnnouncer uniqueInstance methodRepackaged: compiledMethod from: oldPackage to: newPackage ]. "Announce recategorization" SystemAnnouncer uniqueInstance selector: selector recategorizedFrom: oldProtocol to: newProtocol inClass: self ]. SystemAnnouncer uniqueInstance methodChangedFrom: priorMethodOrNil to: compiledMethod selector: selector inClass: self oldProtocol: oldProtocol newProtocol: newProtocol requestor: requestor.]. ! ! !ClassDescription methodsFor: 'accessing method dictionary'! addSelectorSilently: selector withMethod: compiledMethod super addSelectorSilently: selector withMethod: compiledMethod. self instanceSide noteAddedSelector: selector meta: self isMeta.! ! !ClassDescription methodsFor: 'accessing method dictionary'! addSelector: selector withMethod: compiledMethod notifying: requestor | priorMethodOrNil | priorMethodOrNil := self compiledMethodAt: selector ifAbsent: [nil]. self addSelectorSilently: selector withMethod: compiledMethod. priorMethodOrNil isNil ifTrue: [SystemAnnouncer uniqueInstance methodAdded: compiledMethod selector: selector inClass: self requestor: requestor] ifFalse: [SystemAnnouncer uniqueInstance methodChangedFrom: priorMethodOrNil to: compiledMethod selector: selector inClass: self requestor: requestor].! ! !ClassDescription methodsFor: 'accessing method dictionary' stamp: 'DamienCassou 2/28/2013 16:06'! allMethodCategoriesIntegratedThrough: mostGenericClass "Answer a list of all the method categories of the receiver and all its superclasses, up through mostGenericClass" | otherClassCategories thisClassCategories lowercaseSortBlock combinedClassCategories | 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: 'accessing method dictionary' stamp: 'MarcusDenker 3/5/2010 14:31'! allMethodsInCategory: aName "Answer a list of all the methods of the receiver and all its superclasses that are in the category named aName" | aColl | aColl := OrderedCollection new. self withAllSuperclasses do: [:aClass | aColl addAll: (aName = ClassOrganizer allCategory ifTrue: [aClass organization allMethodSelectors] ifFalse: [aClass organization listAtCategoryNamed: aName])]. ^ aColl asSet asArray sort! ! !ClassDescription methodsFor: 'accessing method dictionary'! methodsInCategory: aName "Answer a list of the methods of the receiver that are in category named aName" | aColl | aColl := Set withAll: (aName = ClassOrganizer allCategory ifTrue: [self organization allMethodSelectors] ifFalse: [self organization listAtCategoryNamed: aName]). ^ aColl asArray sort! ! !ClassDescription methodsFor: 'accessing method dictionary'! noteAddedSelector: aSelector meta: isMeta "A hook allowing some classes to react to adding of certain selectors"! ! !ClassDescription methodsFor: 'accessing method dictionary'! removeCategory: 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: 'accessing method dictionary' stamp: 'MartinDias 2/11/2013 14:12'! 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: 'accessing method dictionary'! uncategorizedMethods ^ self methodsInCategory: ClassOrganizer default! ! !ClassDescription methodsFor: 'accessing parallel hierarchy' stamp: 'NS 4/12/2004 15:03'! classSide ^self theMetaClass! ! !ClassDescription methodsFor: 'accessing parallel hierarchy' stamp: 'NS 4/12/2004 15:04'! instanceSide ^ self theNonMetaClass! ! !ClassDescription methodsFor: 'accessing parallel hierarchy'! isClassSide ^self == self classSide! ! !ClassDescription methodsFor: 'accessing parallel hierarchy'! isInstanceSide ^self isClassSide not! ! !ClassDescription methodsFor: 'accessing parallel hierarchy'! isMeta ^self isClassSide! ! !ClassDescription methodsFor: 'accessing parallel hierarchy' stamp: 'sd 6/27/2003 22:50'! theMetaClass "Sent to a class or metaclass, always return the metaclass" ^self class! ! !ClassDescription methodsFor: 'accessing parallel hierarchy'! theNonMetaClass "Sent to a class or metaclass, always return the class" ^self! ! !ClassDescription methodsFor: 'authors' stamp: 'StephaneDucasse 11/6/2011 22:18'! addAuthorsTo: result "private method that to store the result in the argument." self methodsDo: [:each | result add: each author ]! ! !ClassDescription methodsFor: 'authors' stamp: 'StephaneDucasse 11/6/2011 22:19'! authors "Returns a bag representing the author frequency based on the latest version of the methods of the receiver." "self new authorsgather: Date" | br result selectors | result := Bag new. self addAuthorsTo: result. self class addAuthorsTo: result. ^ result! ! !ClassDescription methodsFor: 'compiling' stamp: 'CamilloBruni 8/1/2012 15:57'! 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: 'compiling'! 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: 'CamilloBruni 4/27/2012 18:42'! 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: 'compiling' stamp: 'CamilloBruni 4/27/2012 18:42'! compile: text classified: category withStamp: changeStamp notifying: requestor ^ self compile: text classified: category withStamp: changeStamp notifying: requestor logSource: self acceptsLoggingOfCompilation! ! !ClassDescription methodsFor: 'compiling' stamp: 'EstebanLorenzano 3/1/2013 14:27'! compile: text classified: category withStamp: changeStamp notifying: requestor logSource: logSource | methodAndNode | methodAndNode := self compile: text asString classified: category notifying: requestor trailer: self defaultMethodTrailer ifFail: [ ^ nil ]. logSource ifTrue: [ self logMethodSource: methodAndNode node sourceCode forMethodWithNode: methodAndNode inCategory: category withStamp: changeStamp notifying: requestor ]. self addAndClassifySelector: methodAndNode selector withMethod: methodAndNode method inProtocol: category notifying: requestor. self instanceSide noteCompilationOf: methodAndNode selector meta: self isClassSide. ^ methodAndNode selector! ! !ClassDescription methodsFor: 'compiling'! compile: code notifying: requestor "Refer to the comment in Behavior|compile:notifying:." ^self compile: code classified: ClassOrganizer default notifying: requestor! ! !ClassDescription methodsFor: 'compiling'! 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: 'compiling'! 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: 'compiling'! doneCompiling "A ClassBuilder has finished the compilation of the receiver. This message is a notification for a class that needs to do some cleanup / reinitialization after it has been recompiled."! ! !ClassDescription methodsFor: 'compiling' stamp: 'eem 5/13/2008 09:48'! 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 := 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]! ! !ClassDescription methodsFor: 'compiling' stamp: 'al 11/28/2005 11:51'! moveInstVarNamed: instVarName to: anotherClass after: prevInstVarName "Move the given instance variable to another class." self == anotherClass ifFalse:[ self notify:'Warning:' asText allBold,' moving ', instVarName printString,' from ', self name,' to ', anotherClass name,' will not be recorded in the change set correctly. Proceed to do it anyways.']. ^(ClassBuilder new) moveInstVarNamed: instVarName from: self to: anotherClass after: prevInstVarName! ! !ClassDescription methodsFor: 'compiling'! noteCompilationOf: aSelector meta: isMeta "A hook allowing some classes to react to recompilation of certain selectors"! ! !ClassDescription methodsFor: 'compiling'! reformatAll "Reformat all methods in this class. Leaves old code accessible to version browsing" self selectorsDo: [:sel | self reformatMethodAt: sel]! ! !ClassDescription methodsFor: 'compiling'! reformatMethodAt: selector | newCodeString method | newCodeString := self prettyPrinterClass format: (self sourceCodeAt: selector) in: self notifying: nil. method := self compiledMethodAt: selector. method putSource: newCodeString fromParseNode: nil class: self category: (self organization categoryOfElement: selector) inFile: 2 priorMethod: method ! ! !ClassDescription methodsFor: 'compiling' stamp: 'CamilloBruni 8/1/2012 16:18'! wantsChangeSetLogging "Answer whether code submitted for the receiver should be remembered by the changeSet mechanism." ^ true! ! !ClassDescription methodsFor: 'compiling'! wantsRecompilationProgressReported "Answer whether the receiver would like progress of its recompilation reported interactively to the user." ^ true! ! !ClassDescription methodsFor: 'copying'! 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: 'copying'! 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: 'copying'! 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: 'copying'! 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: 'copying'! 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: 'copying'! 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: 'copying'! 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: 'copying'! 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: 'fileIn/Out'! 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." | ptr header file oldCommentRemoteStr 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]. oldCommentRemoteStr := self organization commentRemoteStr. (aString size = 0) & (oldCommentRemoteStr isNil) ifTrue: [^ self organization classComment: nil]. "never had a class comment, no need to write empty string out" ptr := oldCommentRemoteStr ifNil: [0] ifNotNil: [oldCommentRemoteStr sourcePointer]. SourceFiles ifNotNil: [(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: ptr 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: 'fileIn/Out'! 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: 'fileIn/Out'! 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: 'fileIn/Out'! selectorsToFileOutCategory: aSymbol ^ (aSymbol asString = ClassOrganizer allCategory) ifTrue: [ self organization allMethodSelectors ] ifFalse: [ self organization listAtCategoryNamed: aSymbol ]! ! !ClassDescription methodsFor: 'filein/out'! 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: 'filein/out'! commentStamp: changeStamp self organization commentStamp: changeStamp. ^ self commentStamp: changeStamp prior: 0! ! !ClassDescription methodsFor: 'filein/out'! commentStamp: changeStamp prior: indexAndOffset "Prior source link ignored when filing in." ^ ClassCommentReader new setClass: self category: #Comment changeStamp: changeStamp! ! !ClassDescription methodsFor: 'filein/out' stamp: 'GuillermoPolito 4/30/2012 18:17'! definition "Answer a String that defines the receiver." | aStream | aStream := (String new: 800) writeStream. superclass == nil ifTrue: [aStream nextPutAll: 'ProtoObject'] ifFalse: [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: 'filein/out' stamp: 'PeterHugossonMiller 9/3/2009 00:55'! 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: 'filein/out'! 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: 'filein/out' stamp: 'MarcusDenker 2/19/2010 18:38'! 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) categories 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: 'nice 1/5/2010 15:59'! fileOutChangedMessagesHistorically: aSet on: aFileStream moveSource: moveSource toFile: fileIndex "File all historical 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) categories do: [:cat | | sels | sels := (org listAtCategoryNamed: cat) select: [:sel | aSet includes: sel]. sels do: [:sel | self printMethodChunkHistorically: sel on: aFileStream moveSource: moveSource toFile: fileIndex]]! ! !ClassDescription methodsFor: 'filein/out' stamp: 'PeterHugossonMiller 9/3/2009 00:55'! fileOutMethod: selector "Write source code of a single method on a file. Make up a name for the file." | internalStream | (selector == #Comment) ifTrue: [^ self inform: 'Sorry, cannot file out class comment in isolation.']. (self includesSelector: selector) ifFalse: [^ self error: 'Selector ', selector asString, ' not found']. internalStream := (String new: 1000) writeStream. internalStream header; timeStamp. self printMethodChunk: selector withPreamble: true on: internalStream moveSource: false toFile: 0. FileStream writeSourceCodeFrom: internalStream baseName: (self name , '-' , (selector copyReplaceAll: ':' with: '')) isSt: true.! ! !ClassDescription methodsFor: 'filein/out'! fileOutOn: aFileStream "File a description of the receiver on aFileStream." self fileOutOn: aFileStream moveSource: false toFile: 0! ! !ClassDescription methodsFor: 'filein/out'! 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 categories do: [:heading | self fileOutCategory: heading on: aFileStream moveSource: moveSource toFile: fileIndex]! ! !ClassDescription methodsFor: 'filein/out'! 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: 'filein/out'! 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: 'filein/out'! methods "returns the methods of classes including the ones of the traits that the class uses" ^ self methodDict values ! ! !ClassDescription methodsFor: 'filein/out'! 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: 'filein/out'! methodsFor: aString priorSource: sourcePosition inFile: fileIndex "Prior source pointer ignored when filing in." ^ self methodsFor: aString! ! !ClassDescription methodsFor: 'filein/out'! methodsFor: categoryName stamp: changeStamp ^ self methodsFor: categoryName stamp: (Author fixStamp: changeStamp) prior: 0! ! !ClassDescription methodsFor: 'filein/out'! methodsFor: categoryName stamp: changeStamp prior: indexAndOffset "Prior source link ignored when filing in." ^ ClassCategoryReader new setClass: self category: categoryName asSymbol changeStamp: changeStamp "Most importantly, return the new ClassCategoryReader, so a fileIn will let it seize control. So method will be placed in the proper category. See the transfer of control where ReadWriteStream fileIn calls scanFrom:"! ! !ClassDescription methodsFor: 'filein/out' stamp: 'MarcusDenker 2/21/2010 12:51'! moveChangesWithVersionsTo: 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 methodDict at: sel) fileIndex > 1]. self fileOutChangedMessagesHistorically: changes on: newFile moveSource: true toFile: 2! ! !ClassDescription methodsFor: 'filein/out'! printCategoryChunk: categoryName on: aFileStream ^ self printCategoryChunk: categoryName withStamp: '' on: aFileStream! ! !ClassDescription methodsFor: 'filein/out'! printCategoryChunk: category on: aFileStream priorMethod: priorMethod ^ self printCategoryChunk: category on: aFileStream withStamp: Author changeStamp priorMethod: priorMethod! ! !ClassDescription methodsFor: 'filein/out'! 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: 'filein/out'! printCategoryChunk: categoryName withStamp: changeStamp on: aFileStream ^ self printCategoryChunk: categoryName on: aFileStream withStamp: changeStamp priorMethod: nil! ! !ClassDescription methodsFor: 'filein/out'! 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]. ((method fileIndex = 0 or: [(SourceFiles at: method fileIndex) == nil]) or: [(oldPos := method filePosition) = 0]) ifTrue: ["The source code is not accessible. We must decompile..." preamble size > 0 ifTrue: [outStream cr; nextPut: $!!; nextChunkPut: preamble; cr]. outStream nextChunkPut: method decompileString] ifFalse: [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: 'filein/out' stamp: 'md 4/26/2012 12:03'! printMethodChunkHistorically: selector on: outStream moveSource: moveSource toFile: fileIndex "Copy all source codes historically for the method associated with selector onto the fileStream. If moveSource true, then also set the source code pointer of the method." | preamble method sourceFile endPos category changeList newPos | category := self organization categoryOfElement: selector. preamble := self name , ' methodsFor: ', category asString printString. method := self methodDict at: selector. ((method fileIndex = 0 or: [(SourceFiles at: method fileIndex) == nil]) or: [method filePosition = 0]) ifTrue: [ outStream cr; nextPut: $!!; nextChunkPut: preamble; cr. outStream nextChunkPut: method decompileString. outStream nextChunkPut: ' '; cr] ifFalse: [ changeList := ChangeSet scanVersionsOf: method class: self meta: self isMeta category: category selector: selector. newPos := nil. sourceFile := SourceFiles at: method fileIndex. changeList reverseDo: [ :chgRec | | prior | chgRec fileIndex = fileIndex ifTrue: [ outStream copyPreamble: preamble from: sourceFile at: chgRec position. (prior := chgRec prior) ifNotNil: [ outStream position: outStream position - 2. outStream nextPutAll: ' prior: ', ( prior first = method fileIndex ifFalse: [prior third] ifTrue: [ SourceFiles sourcePointerFromFileIndex: method fileIndex andPosition: newPos]) printString. outStream nextPut: $!!; cr]. "Copy the method chunk" newPos := outStream position. outStream copyMethodChunkFrom: sourceFile at: chgRec position. sourceFile skipSeparators. "The following chunk may have ]style[" sourceFile peek == $] ifTrue: [ outStream cr; copyMethodChunkFrom: sourceFile]. outStream nextChunkPut: ' '; cr]]. moveSource ifTrue: [ endPos := outStream position. method setSourcePosition: newPos inFile: fileIndex]]. ^ outStream! ! !ClassDescription methodsFor: 'filein/out' stamp: 'StephaneDucasse 5/28/2011 13:39'! 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: 'initialize-release' stamp: 'NS 4/8/2004 11:00'! obsolete "Make the receiver obsolete." superclass removeSubclass: self. self organization: nil. super obsolete.! ! !ClassDescription methodsFor: 'initialize-release' stamp: 'NS 4/8/2004 11:26'! superclass: aClass methodDictionary: mDict format: fmt "Basic initialization of the receiver" super superclass: aClass methodDictionary: mDict format: fmt. instanceVariables := nil. self organization: nil.! ! !ClassDescription methodsFor: 'initialize-release' stamp: 'ar 3/1/2001 23:25'! 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: 'initialize-release' stamp: 'MarcusDenker 6/27/2011 13:42'! 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: '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: 'instance variables' stamp: 'al 11/28/2005 11:50'! 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: 'instance variables' stamp: 'BenjaminVanRyseghem 11/24/2010 15:56'! 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: 'instance variables' stamp: 'al 11/28/2005 11:50'! 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: 'instance variables' stamp: 'al 11/28/2005 11:50'! classThatDefinesInstanceVariable: instVarName (self instVarNames notNil and: [self instVarNames includes: instVarName asString]) ifTrue: [^ self]. ^self superclass ifNotNil: [self superclass classThatDefinesInstanceVariable: instVarName]! ! !ClassDescription methodsFor: 'instance variables'! 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: 'instance variables' stamp: 'StephaneDucasse 8/27/2010 11:06'! hasInstVarNamed: aString "Return true whether the receiver defines an instance variable named aString." ^ self instVarNames includes: aString! ! !ClassDescription methodsFor: 'instance variables' stamp: 'StephaneDucasse 5/28/2011 13:32'! instVarIndexFor: instVarName "Answer the index of the named instance variable." | index | index := instanceVariables == nil ifTrue: [0] ifFalse: [instanceVariables indexOf: instVarName]. index = 0 ifTrue: [^superclass == nil ifTrue: [0] ifFalse: [superclass instVarIndexFor: instVarName]]. ^superclass == nil ifTrue: [index] ifFalse: [index + superclass instSize]! ! !ClassDescription methodsFor: 'instance variables' stamp: 'ul 11/15/2010 10:10'! instVarIndexFor: instVarName ifAbsent: aBlock "Answer the index of the named instance variable." | index | index := instanceVariables == nil ifTrue: [0] ifFalse: [instanceVariables indexOf: instVarName ifAbsent: [0]]. index = 0 ifTrue: [^superclass == nil ifTrue: [aBlock value] ifFalse: [superclass instVarIndexFor: instVarName ifAbsent: aBlock]]. ^superclass == nil ifTrue: [index] ifFalse: [index + superclass instSize]! ! !ClassDescription methodsFor: 'instance variables'! instVarNameForIndex: index "Answer the named instance variable with index index or nil if none." | superInstSize | index > self instSize ifTrue: [^nil]. superInstSize := superclass isNil ifTrue: [0] ifFalse: [superclass instSize]. index > superInstSize ifTrue: [^instanceVariables at: index - superInstSize]. superclass isNil ifTrue: [^nil]. ^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: 'instance variables'! instVarNames "Answer an Array of the receiver's instance variable names." instanceVariables == nil ifTrue: [^#()] ifFalse: [^instanceVariables]! ! !ClassDescription methodsFor: 'instance variables' stamp: 'StephaneDucasse 8/27/2010 11:05'! 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: 'instance variables' stamp: 'al 11/28/2005 11:52'! renameInstVar: oldName to: newName (self confirm: 'WARNING: Renaming of instance variables is subject to substitution ambiguities. Do you still wish to attempt it?') ifFalse: [self halt]. "...In other words, this does a dumb text search-and-replace, which might improperly alter, eg, a literal string. As long as the oldName is unique, everything should work jes' fine. - di" ^ self renameSilentlyInstVar: oldName to: newName! ! !ClassDescription methodsFor: 'instance variables' stamp: 'al 11/28/2005 11:52'! renameSilentlyInstVar: old to: new | i oldName newName | oldName := old asString. newName := new asString. (i := self instVarNames indexOf: oldName) = 0 ifTrue: [self error: oldName , ' is not defined in ', self name]. self allSuperclasses , self withAllSubclasses asOrderedCollection do: [:cls | (cls instVarNames includes: newName) ifTrue: [self error: newName , ' is already used in ', cls name]]. self instVarNames replaceFrom: i to: i with: (Array with: newName). self replaceSilently: oldName to: newName. "replace in text body of all methods"! ! !ClassDescription methodsFor: 'instance variables' stamp: 'nice 12/4/2009 00:00'! replaceSilently: old to: new "text-replace any part of a method. Used for class and pool variables. Don't touch the header. Not guaranteed to work if name appears in odd circumstances" | oldName newName | oldName := old asString. newName := new asString. self withAllSubclasses do: [:cls | | sels | sels := cls selectors copyWithoutAll: #(DoIt DoItIn:). sels do: [:sel | | oldCode newCode parser header body | oldCode := cls sourceCodeAt: sel. "Don't make changes in the method header" (parser := cls parserClass new) parseSelector: oldCode. header := oldCode copyFrom: 1 to: (parser endOfLastToken min: oldCode size). body := header size > oldCode size ifTrue: [''] ifFalse: [oldCode copyFrom: header size+1 to: oldCode size]. newCode := header , (body copyReplaceTokens: oldName with: newName). newCode ~= oldCode ifTrue: [cls compile: newCode classified: (cls organization categoryOfElement: sel) notifying: nil]]. cls isMeta ifFalse: [| oldCode newCode | oldCode := cls comment. newCode := oldCode copyReplaceTokens: oldName with: newName. newCode ~= oldCode ifTrue: [cls comment: newCode]]]! ! !ClassDescription methodsFor: 'organization' stamp: 'MarcusDenker 7/13/2012 16:51'! organization "Answer the instance of ClassOrganizer that represents the organization of the messages of the receiver." organization ifNil: [self organization: (ClassOrganizer defaultList: self selectors asArray sort)]. "Making sure that subject is set correctly. It should not be necessary." organization ifNotNil: [organization setSubject: self]. ^ organization! ! !ClassDescription methodsFor: 'organization' stamp: 'NS 4/8/2004 11:04'! organization: aClassOrg "Install an instance of ClassOrganizer that represents the organization of the messages of the receiver." aClassOrg ifNotNil: [aClassOrg setSubject: self]. organization := aClassOrg! ! !ClassDescription methodsFor: 'organization'! 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: 'organization'! 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: 'organization'! 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: 'organization updating'! applyChangesOfNewTraitCompositionReplacing: oldComposition | changedSelectors oldMethodDict | oldMethodDict := self methodDict copy. changedSelectors := super applyChangesOfNewTraitCompositionReplacing: oldComposition. self noteRecategorizedSelectors: changedSelectors oldComposition: oldComposition. self noteChangesFrom: oldMethodDict. ^ changedSelectors.! ! !ClassDescription methodsFor: 'organization updating' stamp: 'CamilloBruni 4/27/2012 18:53'! 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: 'organization updating' stamp: 'CamilloBruni 4/27/2012 16:09'! noteChangesFrom: oldMethodDict with: changedSelectors "create notifications about the changes made to the method dictionary" self haltIf: changedSelectors isEmpty not. "oldMethodDict keys \ methodDict keys" changedSelectors do: [ :selector| " deal with removal / updates relative to the old method dictionary" oldMethodDict at: selector ifPresent: [:oldMethod| methodDict at: selector ifPresent: [:newMethod| self noteMethodChanged: oldMethod to: newMethod] ifAbsent: [ self noteMethodRemoved: oldMethod ]] ifAbsent: [ self noteMethodAdded: (methodDict at: selector)]]. ! ! !ClassDescription methodsFor: 'organization updating' stamp: 'EstebanLorenzano 7/27/2012 16:30'! noteMethodAdded: aMethod SystemAnnouncer uniqueInstance methodAdded: aMethod! ! !ClassDescription methodsFor: 'organization updating' stamp: 'EstebanLorenzano 7/27/2012 16:30'! noteMethodChanged: oldMethod to: newMethod SystemAnnouncer uniqueInstance methodChangedFrom: oldMethod to: newMethod ! ! !ClassDescription methodsFor: 'organization updating' stamp: 'EstebanLorenzano 7/27/2012 16:30'! noteMethodRemoved: oldMethod SystemAnnouncer uniqueInstance methodRemoved: oldMethod! ! !ClassDescription methodsFor: 'organization updating' stamp: 'nice 1/5/2010 15:59'! 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'! 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 updating' stamp: 'EstebanLorenzano 7/27/2012 16:30'! notifyOfRecategorizedSelector: element from: oldCategory to: newCategory SystemAnnouncer uniqueInstance selector: element recategorizedFrom: oldCategory to: newCategory inClass: self! ! !ClassDescription methodsFor: 'organization updating' stamp: 'CamilloBruni 4/27/2012 14:41'! 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 == ClassOrganizer ambiguous or: [ currentCategory == oldCategoryOrNil ] ]) and: [ currentCategory ~~ effectiveCategory ]) ifTrue: [ currentCategory ifNotNil: [ changedCategories add: currentCategory ]. self organization classify: sel under: effectiveCategory suppressIfDefault: false ]! ! !ClassDescription methodsFor: 'organization updating' stamp: 'CamilloBruni 4/27/2012 14:37'! 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: 'pool variable' stamp: 'StephaneDucasse 12/13/2011 17:02'! 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: 'pool variable' stamp: 'StephaneDucasse 12/13/2011 16:11'! hasSharedPools "Only a class may have shared pools" ^ false! ! !ClassDescription methodsFor: 'pool variable' stamp: 'StephaneDucasse 12/13/2011 17:38'! sharedPoolOfVarNamed: aString "Only classes may have shared pools" ^ nil! ! !ClassDescription methodsFor: 'pool variable' stamp: 'MarianoMartinezPeck 12/16/2011 11:59'! usesLocalPoolVarNamed: aString ^ false! ! !ClassDescription methodsFor: 'pool variable' stamp: 'StephaneDucasse 12/13/2011 17:10'! usesPoolVarNamed: aString "Only classes may use a pool variable named: aString" ^ false! ! !ClassDescription methodsFor: 'printing' stamp: 'nice 10/22/2009 09:39'! 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: 'printing' stamp: 'al 11/28/2005 11:51'! 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: 'printing'! printOn: aStream aStream nextPutAll: self name! ! !ClassDescription methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! printWithClosureAnalysisOn: aStream aStream nextPutAll: self name! ! !ClassDescription methodsFor: 'printing' stamp: 'al 11/28/2005 11:52'! 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: 'printing'! storeOn: aStream "Classes and Metaclasses have global names." aStream nextPutAll: self name! ! !ClassDescription methodsFor: 'testing' stamp: 'StephaneDucasse 12/16/2012 18:18'! isAbstractClass self deprecated: 'Use defineAbstractMethods' on: '16 December 2012' in: #Pharo2.0. self subclassResponsibility! ! !ClassDescription methodsFor: 'private'! errorCategoryName self error: 'Category name must be a String'! ! !ClassDescription methodsFor: 'private' stamp: 'al 11/28/2005 11:51'! 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: 'private' stamp: 'StephaneDucasse 3/3/2010 13:43'! 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: 'private' stamp: 'alain.plantec 5/18/2009 08:43'! logMethodSource: aText forMethodWithNode: aCompiledMethodWithNode inCategory: category withStamp: changeStamp notifying: requestor aCompiledMethodWithNode method putSource: aText fromParseNode: aCompiledMethodWithNode node class: self category: category withStamp: changeStamp inFile: 2 priorMethod: (self compiledMethodAt: aCompiledMethodWithNode selector ifAbsent: []) ! ! !ClassDescription methodsFor: 'private' stamp: 'ar 7/10/1999 11:17'! 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: 'private' stamp: 'Alexandre Bergel 4/27/2010 14:17'! 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: 'private' stamp: 'ar 7/15/1999 17:04'! setInstVarNames: instVarArray "Private - for class initialization only" | required | required := self instSize. superclass notNil ifTrue:[required := required - superclass instSize]. instVarArray size = required ifFalse:[^self error: required printString, ' instvar names are required']. instVarArray isEmpty ifTrue:[instanceVariables := nil] ifFalse:[instanceVariables := instVarArray asArray].! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ClassDescription class uses: TClassAndTraitDescription classTrait instanceVariableNames: ''! ClassTestCase subclass: #ClassDescriptionTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Classes'! !ClassDescriptionTest commentStamp: '' prior: 0! 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: 'DamienCassou 2/28/2013 16:08'! 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 methodsInCategory: 'testing') includes: #isAbstract). CompiledMethod allMethodCategoriesIntegratedThrough: Object. self assert: ((CompiledMethod methodsInCategory: 'testing') includes: #isAbstract)! ! !ClassDescriptionTest methodsFor: 'tests' stamp: 'sd 5/10/2008 12:34'! testMethods self assert: Object methods = Object methodDict values. ! ! !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 6/5/2005 08:24'! testOrganization | aClassOrganizer | aClassOrganizer := ClassDescription organization. self assert: (aClassOrganizer isKindOf: ClassOrganizer).! ! TextDiffBuilder subclass: #ClassDiffBuilder instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-FilePackage'! !ClassDiffBuilder commentStamp: 'HenrikSperreJohansen 5/21/2010 02:06' prior: 0! 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 ] ]! ! Object subclass: #ClassFactoryForTestCase instanceVariableNames: 'createdClasses' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Core-Extensions'! !ClassFactoryForTestCase commentStamp: 'LaurentLaffont 4/15/2011 20:20' prior: 0! 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: 'accessing' stamp: 'Noury 10/26/2008 14:21'! createdClassNames ^self createdClasses collect: [:class| class name]! ! !ClassFactoryForTestCase methodsFor: 'accessing' stamp: 'Noury 10/26/2008 13:59'! createdClasses ^createdClasses! ! !ClassFactoryForTestCase methodsFor: 'accessing' stamp: 'Noury 10/26/2008 14:01'! createdClasses: classes createdClasses := classes asIdentitySet ! ! !ClassFactoryForTestCase methodsFor: 'accessing' stamp: 'Noury 10/26/2008 16:37'! defaultCategory ^ (self packageName , '-', self defaultCategoryPostfix) asSymbol! ! !ClassFactoryForTestCase methodsFor: 'accessing' stamp: 'Noury 10/26/2008 16:23'! defaultCategoryPostfix ^ #Default! ! !ClassFactoryForTestCase methodsFor: 'accessing' stamp: 'NouryBouraqadi 12/18/2010 18:46'! defaultSuperclass ^Object! ! !ClassFactoryForTestCase methodsFor: 'accessing' stamp: 'Noury 10/26/2008 16:20'! packageName ^#CategoryForTestToBeDeleted! ! !ClassFactoryForTestCase methodsFor: 'cleaning' stamp: 'Noury 10/26/2008 16:26'! cleanUp | createdClassNames | createdClassNames := self createdClassNames. self deleteClasses. self deletePackage. self cleanUpChangeSetForClassNames: createdClassNames! ! !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: 'cleaning' stamp: 'Noury 10/26/2008 12:47'! delete: aClass aClass isObsolete ifTrue: [^self]. aClass removeFromChanges. aClass removeFromSystemUnlogged ! ! !ClassFactoryForTestCase methodsFor: 'cleaning' stamp: 'Noury 10/26/2008 12:46'! deleteClasses self createdClasses do: [:class| self delete: class]! ! !ClassFactoryForTestCase methodsFor: 'cleaning' stamp: 'Noury 10/26/2008 16:33'! deletePackage | categoriesMatchString | categoriesMatchString := self packageName, '-*'. SystemOrganization removeCategoriesMatching: categoriesMatchString! ! !ClassFactoryForTestCase methodsFor: 'cleaning' stamp: 'Noury 10/26/2008 14:01'! initialize super initialize. self createdClasses: IdentitySet new! ! !ClassFactoryForTestCase methodsFor: 'creating' stamp: 'NouryBouraqadi 12/18/2010 18:46'! newClass ^self newSubclassOf: self defaultSuperclass instanceVariableNames: '' classVariableNames: ''! ! !ClassFactoryForTestCase methodsFor: 'creating' stamp: 'NouryBouraqadi 12/18/2010 18:48'! newClassInCategory: category ^self newSubclassOf: self defaultSuperclass instanceVariableNames: '' classVariableNames: '' category: category! ! !ClassFactoryForTestCase methodsFor: 'creating' stamp: 'Noury 11/12/2009 17:53'! newName | postFix | postFix := (self createdClasses size + 1) printString. ^(#ClassForTestToBeDeleted, postFix) asSymbol! ! !ClassFactoryForTestCase methodsFor: 'creating' stamp: 'Noury 10/26/2008 16:25'! newSubclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString ^self newSubclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString category: self defaultCategoryPostfix! ! !ClassFactoryForTestCase methodsFor: 'creating' stamp: 'Noury 10/26/2008 16:36'! newSubclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString category: category | newClass | newClass := aClass subclass: self newName instanceVariableNames: ivNamesString classVariableNames: classVarsString poolDictionaries: '' category: (self packageName, '-', category) asSymbol. self createdClasses add: newClass. ^newClass! ! !ClassFactoryForTestCase methodsFor: 'creating - silently' stamp: 'MarianoMartinezPeck 4/19/2012 19:29'! silentlyNewClassInCategory: category ^self silentlyNewSubclassOf: self defaultSuperclass instanceVariableNames: '' classVariableNames: '' category: category! ! !ClassFactoryForTestCase methodsFor: 'creating - silently' stamp: 'MarianoMartinezPeck 4/19/2012 19:16'! silentlyNewSubclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString ^ self silentlyNewSubclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString category: self defaultCategoryPostfix ! ! !ClassFactoryForTestCase methodsFor: 'creating - silently' stamp: 'EstebanLorenzano 8/7/2012 10:55'! silentlyNewSubclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString category: category | default newClass | SystemAnnouncer uniqueInstance suspendAllWhile: [ newClass := aClass subclass: self newName instanceVariableNames: ivNamesString classVariableNames: classVarsString poolDictionaries: '' category: (self packageName, '-', category) asSymbol. ]. self createdClasses add: newClass. ^newClass ! ! !ClassFactoryForTestCase methodsFor: 'creating - silently' stamp: 'EstebanLorenzano 8/7/2012 10:55'! silentlyNewSubclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString package: packageName | default newClass | SystemAnnouncer uniqueInstance suspendAllWhile: [ newClass := aClass subclass: self newName instanceVariableNames: ivNamesString classVariableNames: classVarsString poolDictionaries: '' category: packageName asSymbol. ]. self createdClasses add: newClass. ^newClass ! ! !ClassFactoryForTestCase methodsFor: 'creating - silently' stamp: 'MarianoMartinezPeck 4/19/2012 19:06'! withNotificationsNewClass ^ self withNotificationsNewClassWithInstanceVariableNames: ''! ! !ClassFactoryForTestCase methodsFor: 'creating - silently' stamp: 'MarianoMartinezPeck 4/19/2012 19:23'! withNotificationsNewClassWithInstanceVariableNames: instanceVariableNames ^ self newSubclassOf: Object instanceVariableNames: instanceVariableNames classVariableNames: '' category: self defaultCategoryPostfix ! ! TestCase subclass: #ClassFactoryForTestCaseTest instanceVariableNames: 'factory' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Tests-Core'! !ClassFactoryForTestCaseTest methodsFor: 'setUp-tearDown' stamp: 'Noury 10/26/2008 12:19'! setUp super setUp. factory := ClassFactoryForTestCase new! ! !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: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: '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: 'testing' stamp: 'Noury 10/26/2008 16:44'! testDefaultCategoryCleanUp | createdClassNames allClasses | 3 timesRepeat: [ factory newClass]. 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 deny: (SystemOrganization categories includes: factory defaultCategory). self deny: (ChangeSet current changedClassNames includesAnyOf: createdClassNames) ! ! !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: '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: '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: '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 class instanceVariableNames: ''! !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)! ! ClassFactoryForTestCase subclass: #ClassFactoryWithOrganization instanceVariableNames: 'organization' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Core-Extensions'! !ClassFactoryWithOrganization commentStamp: 'LaurentLaffont 5/4/2011 21:25' prior: 0! 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: 'accessing' stamp: 'LucFabresse 10/24/2010 20:31'! organization ^organization! ! !ClassFactoryWithOrganization methodsFor: 'accessing' stamp: 'LucFabresse 10/24/2010 20:31'! organization: aSystemOrganizer organization := aSystemOrganizer! ! !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/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: 'creating' stamp: 'LucFabresse 10/29/2010 08:03'! newClassNamed: aString subclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString category: category | newClass | newClass := (ClassBuilder new) 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: '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: 'creating' stamp: 'LucFabresse 10/24/2010 21:35'! newSubclassOf: aClass instanceVariableNames: ivNamesString classVariableNames: classVarsString category: category | newClass | newClass := (ClassBuilder new) name: self newName inEnvironment: self organization environment subclassOf: aClass type: aClass typeOfClass instanceVariableNames: ivNamesString classVariableNames: classVarsString poolDictionaries: '' category: category asSymbol. self createdClasses add: newClass. ^newClass! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ClassFactoryWithOrganization class instanceVariableNames: ''! !ClassFactoryWithOrganization class methodsFor: 'instance creation' stamp: 'LucFabresse 10/24/2010 20:33'! newWithOrganization: aSystemOrganizer ^self new organization: aSystemOrganizer; yourself! ! TestCase subclass: #ClassFactoryWithOrganizationTest instanceVariableNames: 'factory' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Tests-Core'! !ClassFactoryWithOrganizationTest methodsFor: 'accessing' stamp: 'LucFabresse 10/24/2010 19:57'! testedEnvironment ^self testedOrganization environment! ! !ClassFactoryWithOrganizationTest methodsFor: 'accessing' stamp: 'LucFabresse 10/24/2010 20:31'! testedOrganization ^factory organization! ! !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: 'testing' stamp: 'LucFabresse 10/24/2010 19:48'! assertEnvironmentOf: aBehavior self assert: aBehavior environment = self testedEnvironment! ! !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/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: '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: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/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! ! TestCase subclass: #ClassHierarchyTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Classes'! !ClassHierarchyTest methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 7/12/2012 18:00'! testMethodDuplication "self debug: #testMethodDuplication" |methods| SystemNavigation new allClasses do: [ :cls| methods := cls copiedMethodsFromSuperclass. self assert: methods isEmpty]! ! !ClassHierarchyTest methodsFor: 'as yet unclassified' 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: 'as yet unclassified' 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 instanceVariableNames: ''! !ClassHierarchyTest class methodsFor: 'fixing' stamp: 'CamilloBruni 1/30/2013 15:50'! fixSubclasses "Fix all the missing subclasses" " self fixSubclasses " SystemNavigation new allClassesDo: [ :cls| (cls superclass subclasses includes: cls) ifFalse: [ cls superclass addSubclass: cls ]]! ! MorphTreeModel subclass: #ClassListExample instanceVariableNames: 'rootClass' classVariableNames: '' poolDictionaries: '' category: 'Morphic-MorphTreeWidget-Examples'! !ClassListExample commentStamp: 'AlainPlantec 1/22/2010 15:10' prior: 0! ClassListExample new openOn: Object ! !ClassListExample methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 10/1/2011 09:44'! defaultChunkSize ^ nil! ! !ClassListExample methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 2/25/2011 17:03'! keyStroke: anEvent from: aTreeMorph self selectedNode ifNotNil: [:current | current keyStroke: anEvent from: aTreeMorph]! ! !ClassListExample methodsFor: 'as yet unclassified' 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! ! !ClassListExample methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 1/16/2010 09:50'! open ^ self openOn: Object ! ! !ClassListExample methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'AlainPlantec 1/16/2010 09:50'! rootClass ^ rootClass ifNil: [rootClass := Object]! ! !ClassListExample methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 1/16/2010 09:50'! rootClass: aClass rootClass := aClass! ! !ClassListExample methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 1/15/2010 13:56'! rootItems ^ self rootClass allSubclasses asArray sort: [:a :b | a name < b name ]! ! !ClassListExample methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 2/7/2010 22:44'! rootNodeClassFromItem: anItem ^ClassListNodeExample! ! !ClassListExample methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 9/29/2011 00:40'! 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: self theme smallOpenIcon target: nil actionSelector: nil arguments: #(). MorphTreeColumn new rowMorphGetSelector: #commentText; headerButtonLabel: 'Comments' font: nil icon: self theme 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! ! MorphTreeNodeModel subclass: #ClassListNodeExample instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-MorphTreeWidget-Examples'! !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'! exploreItem self explore! ! !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: '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 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: 'menu' stamp: 'FernandoOlivero 4/12/2011 09:41'! commentText ^ ( self theme newTextIn: World text: self item comment) unlock; wrapFlag: true; yourself! ! !ClassListNodeExample methodsFor: 'menu' stamp: 'FernandoOlivero 4/12/2011 09:41'! icon ^ self theme smallExpertIcon! ! ComposableModel subclass: #ClassMethodBrowser instanceVariableNames: 'listModel methodModel' classVariableNames: '' poolDictionaries: '' category: 'Spec-Examples-PolyWidgets'! !ClassMethodBrowser commentStamp: '' prior: 0! 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'! listModel ^ listModel! ! !ClassMethodBrowser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/14/2011 18:03'! methodModel ^ methodModel! ! !ClassMethodBrowser methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/12/2012 19:34'! initializePresenter listModel whenSelectedItemChanged: [:selection | selection ifNotNil: [:class | methodModel methods: (class methodDict values sort: [:a :b | a selector < b selector]). methodModel listModel resetSelection ]].! ! !ClassMethodBrowser methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/12/2012 19:34'! initializeWidgets self instantiateModels: #( listModel ListComposableModel methodModel MethodBrowser ). self focusOrder add: listModel; add: methodModel. methodModel displayBlock: [:method | method selector ].! ! !ClassMethodBrowser methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/22/2012 19:16'! classes: aList self listModel items: aList! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ClassMethodBrowser class instanceVariableNames: ''! !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 6/22/2012 19:19'! defaultSpec ^ SpecLayout composed newRow: [:row | row add: #listModel; add: #methodModel ]; yourself! ! !ClassMethodBrowser class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/15/2013 14:16'! defaultSpec2 ^ { #ComposableSpec. #add:. {{#model. #listModel.}. #layout:. #(FrameLayout rightFraction: 0.5 bottomFraction: 0.5)}. #add:. {{#model. #methodModel. #listModel.}. #layout:.#(FrameLayout leftFraction: 0.5 bottomFraction: 0.5)}. #add:. {{#model. #methodModel. #textModel}. #layout:.#(FrameLayout topFraction: 0.5)}}.! ! !ClassMethodBrowser class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 12/14/2011 18:12'! title ^ 'Class Method Browser'! ! SystemAnnouncement subclass: #ClassModifiedClassDefinition instanceVariableNames: 'newClassDefinition oldClassDefinition' classVariableNames: '' poolDictionaries: '' category: 'System-Announcements'! !ClassModifiedClassDefinition commentStamp: '' prior: 0! This announcement will be emitted when a class or a trait definition changes: when an inst var or a classVariable is added! !ClassModifiedClassDefinition methodsFor: 'accessing' stamp: 'GuillermoPolito 8/3/2012 13:51'! classAffected ^self newClassDefinition! ! !ClassModifiedClassDefinition methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:10'! newClassDefinition ^newClassDefinition! ! !ClassModifiedClassDefinition methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:09'! newClassDefinition: aClass newClassDefinition := aClass! ! !ClassModifiedClassDefinition methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:10'! oldClassDefinition ^oldClassDefinition! ! !ClassModifiedClassDefinition methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:10'! oldClassDefinition: aClass oldClassDefinition := aClass! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ClassModifiedClassDefinition class instanceVariableNames: ''! !ClassModifiedClassDefinition class methodsFor: 'instance creation' stamp: 'GuillermoPolito 8/2/2012 00:09'! classDefinitionChangedFrom: oldClass to: newClass ^self new oldClassDefinition: oldClass; newClassDefinition: newClass; yourself! ! Object subclass: #ClassMultiplePoolUser instanceVariableNames: '' classVariableNames: '' poolDictionaries: 'PoolDefiner PoolDefiner2' category: 'KernelTests-Classes'! !ClassMultiplePoolUser commentStamp: 'StephaneDucasse 12/13/2011 15:59' prior: 0! I'm a class using two shared pools. ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ClassMultiplePoolUser class instanceVariableNames: ''! !ClassMultiplePoolUser class methodsFor: 'accessing' stamp: 'StephaneDucasse 12/13/2011 15:59'! author ^ Author! ! !ClassMultiplePoolUser class methodsFor: 'accessing' stamp: 'StephaneDucasse 12/13/2011 15:59'! gloups ^ Gloups! ! !ClassMultiplePoolUser class methodsFor: 'accessing' stamp: 'StephaneDucasse 12/13/2011 16:00'! variableInPoolDefiner2 ^ VariableInPoolDefiner2! ! ComposableModel subclass: #ClassNameSetter instanceVariableNames: 'classNameLabel classNameTextField categoryLabel categoryField toolbar descriptionHolder' classVariableNames: '' poolDictionaries: '' category: 'Spec-Builder-Tools'! !ClassNameSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/30/2012 14:38'! categoryField ^ categoryField! ! !ClassNameSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/30/2012 14:38'! categoryLabel ^ categoryLabel! ! !ClassNameSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/30/2012 14:38'! classNameLabel ^ classNameLabel! ! !ClassNameSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/30/2012 14:38'! classNameTextField ^ classNameTextField! ! !ClassNameSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/30/2012 14:38'! toolbar ^ toolbar! ! !ClassNameSetter methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 6/12/2012 19:08'! initialize descriptionHolder := nil asValueHolder. super initialize. ! ! !ClassNameSetter methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 6/12/2012 18:54'! initializePresenter toolbar okAction: [ classNameTextField getText ifNotNil: [:cn | categoryField getText ifNotNil: [:cat | descriptionHolder contents addClassNamed: cn categorized: cat ]]]. descriptionHolder whenChangedDo: [:desc || acDesc | acDesc:= desc addClassDescription. classNameTextField text: acDesc newClassName. categoryField text: acDesc category ]! ! !ClassNameSetter methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 6/12/2012 18:55'! initializeWidgets self instantiateModels: #( toolbar OkCancelToolbar categoryField TextInputFieldModel categoryLabel LabelModel classNameTextField TextInputFieldModel classNameLabel LabelModel ). categoryField autoAccept: true. classNameTextField autoAccept: true. classNameLabel text: 'Class name:'. categoryLabel text: 'Category:'.! ! !ClassNameSetter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/30/2012 17:28'! description: aDescription descriptionHolder contents: aDescription! ! !ClassNameSetter methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/30/2012 15:34'! initialExtent ^ (300@200)! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ClassNameSetter class instanceVariableNames: ''! !ClassNameSetter class methodsFor: 'generating' stamp: 'BenjaminVanRyseghem 3/30/2012 14:38'! generatingSpec ^ ((Array new: 57) at: 1 put: #model; at: 2 put: #subclass:category:; at: 3 put: #ClassNameSetter; at: 4 put: 'Spec-Builder-Tools'; at: 5 put: #addInstVarNamed:type:; at: 6 put: 'classNameLabel'; at: 7 put: LabelModel; at: 8 put: #addInstVarNamed:type:; at: 9 put: 'classNameTextField'; at: 10 put: TextInputFieldModel; at: 11 put: #addInstVarNamed:type:; at: 12 put: 'categoryLabel'; at: 13 put: LabelModel; at: 14 put: #addInstVarNamed:type:; at: 15 put: 'categoryField'; at: 16 put: TextInputFieldModel; at: 17 put: #addInstVarNamed:type:; at: 18 put: 'toolbar'; at: 19 put: OkCancelToolbar; at: 20 put: #compileWithoutReturn:classified:; at: 21 put: 'initialize super initialize'; at: 22 put: 'initialize'; at: 23 put: #compileWithoutReturn:classified:; at: 24 put: 'classNameLabel ^ classNameLabel'; at: 25 put: 'accessing'; at: 26 put: #compileWithoutReturn:classified:; at: 27 put: 'classNameTextField ^ classNameTextField'; at: 28 put: 'accessing'; at: 29 put: #compileWithoutReturn:classified:; at: 30 put: 'categoryLabel ^ categoryLabel'; at: 31 put: 'accessing'; at: 32 put: #compileWithoutReturn:classified:; at: 33 put: 'categoryField ^ categoryField'; at: 34 put: 'accessing'; at: 35 put: #compileWithoutReturn:classified:; at: 36 put: 'toolbar ^ toolbar'; at: 37 put: 'accessing'; at: 38 put: #addSourceCode:into:; at: 39 put: 'toolbar := self instantiate: OkCancelToolbar'; at: 40 put: #initialize; at: 41 put: #addSourceCode:into:; at: 42 put: 'categoryField := self instantiate: TextInputFieldModel'; at: 43 put: #initialize; at: 44 put: #addSourceCode:into:; at: 45 put: 'categoryLabel := self instantiate: LabelModel'; at: 46 put: #initialize; at: 47 put: #addSourceCode:into:; at: 48 put: 'classNameTextField := self instantiate: TextInputFieldModel'; at: 49 put: #initialize; at: 50 put: #addSourceCode:into:; at: 51 put: 'classNameLabel := self instantiate: LabelModel'; at: 52 put: #initialize; at: 53 put: #theMetaClass; at: 54 put: #compileWithoutReturn:classified:; at: 55 put: 'internSpec ^ {#Panel. #changeProportionalLayout. #''add::''. {#(#model ''classNameLabel'' ''internSpec''). #layout:. {#LayoutFrame. #fractions:offsets:. (0@0) corner: (1@0). (0@0) corner: (0@25)}}. #''add::''. {#(#model ''classNameTextField'' ''internSpec''). #layout:. {#LayoutFrame. #fractions:offsets:. (0@0) corner: (1@0). (0@30) corner: (0@45)}}. #''add::''. {#(#model ''categoryLabel'' ''internSpec''). #layout:. {#LayoutFrame. #fractions:offsets:. (0@0) corner: (1@0). (0@50) corner: (0@75)}}. #''add::''. {#(#model ''categoryField'' ''internSpec''). #layout:. {#LayoutFrame. #fractions:offsets:. (0@0) corner: (1@0). (0@80) corner: (0@105)}}. #add:. {#(#model #toolbar #internSpec). #layout:. {#LayoutFrame. #fractions:offsets:. (0@1) corner: (1@1). (0@ -25) corner: (0@0)}}. #vResizing:. #spaceFill. #hResizing:. #spaceFill}'; at: 56 put: 'specs'; at: 57 put: #theNonMetaClass; yourself)! ! !ClassNameSetter class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/15/2013 13:01'! defaultSpec ^ {#Panel. #changeProportionalLayout. #'add:'. {#(#model 'classNameLabel' ). #layout:. #(FrameLayout bottomFraction: 0 bottomOffset: 25)}. #'add:'. {#(#model 'classNameTextField' ). #layout:. #(FrameLayout bottomFraction: 0 topOffset: 30 bottomOffset: 65)}. #'add:'. {#(#model 'categoryLabel' ). #layout:. #(FrameLayout bottomFraction: 0 topOffset: 70 bottomOffset: 95)}. #'add:'. {#(#model 'categoryField' ). #layout:. #(FrameLayout bottomFraction: 0 topOffset: 100 bottomOffset: 135)}. #add:. {#(#model #toolbar ). #layout:. #(FrameLayout topFraction: 1 topOffset: -25)}. #vResizing:. #spaceFill. #hResizing:. #spaceFill}! ! Object subclass: #ClassOrganization instanceVariableNames: 'comment commentStamp protocolOrganizer organizedClass' classVariableNames: '' poolDictionaries: '' category: 'NewClassOrganizer'! !ClassOrganization commentStamp: '' prior: 0! A ClassOrganization is a new implementation of ClassOrganizer with - cleaner API - better object management - better categorization 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: 'BenjaminVanRyseghem 4/12/2012 18:39'! comment comment ifNil: [^ '']. ^ comment string ifNil: ['']! ! !ClassOrganization methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/12/2012 18:37'! comment: aString "Store the comment, aString, associated with the object that refers to the receiver." (aString isKindOf: RemoteString) ifTrue: [ comment := aString] ifFalse: [aString isEmptyOrNil ifTrue: [ comment := nil] ifFalse: [ comment := RemoteString newString: aString onFileNumber: 2]] "Later add priorSource and date and initials?"! ! !ClassOrganization methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/12/2012 15:04'! commentStamp ^ commentStamp! ! !ClassOrganization methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/12/2012 15:04'! commentStamp: anObject commentStamp := anObject! ! !ClassOrganization methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/12/2012 15:52'! organizedClass ^ organizedClass! ! !ClassOrganization methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/12/2012 15:01'! protocolOrganizer ^ protocolOrganizer! ! !ClassOrganization methodsFor: 'backward compatibility' stamp: 'BenjaminVanRyseghem 4/12/2012 15:42'! addCategory: aProtocolName before: aUselessArgument self protocolOrganizer addProtocolNamed: aProtocolName! ! !ClassOrganization methodsFor: 'backward compatibility' stamp: 'BenjaminVanRyseghem 4/24/2012 14:17'! allMethodSelectors ^ protocolOrganizer allMethods! ! !ClassOrganization methodsFor: 'backward compatibility' stamp: 'BenjaminVanRyseghem 4/12/2012 15:25'! categoryOfElement: aSelector ^ (self protocolOrganizer protocolsOfSelector: aSelector) ifEmpty: [ Protocol defaultName ] ifNotEmpty: [:col | col first name ]! ! !ClassOrganization methodsFor: 'backward compatibility' stamp: 'BenjaminVanRyseghem 4/12/2012 15:02'! classComment ^ self comment! ! !ClassOrganization methodsFor: 'backward compatibility' stamp: 'BenjaminVanRyseghem 4/12/2012 15:03'! classComment: aString self comment: aString! ! !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/12/2012 15:45'! classify: aMethod under: aProtocolName suppressIfDefault: aBoolean ^ self protocolOrganizer classify: aMethod inProtocolNamed: aProtocolName suppressIfDefault: aBoolean! ! !ClassOrganization methodsFor: 'backward compatibility' stamp: 'BenjaminVanRyseghem 4/12/2012 18:41'! commentRemoteStr ^ comment! ! !ClassOrganization methodsFor: 'backward compatibility' stamp: 'BenjaminVanRyseghem 4/12/2012 16:15'! hasSubject ^ organizedClass notNil! ! !ClassOrganization methodsFor: 'backward compatibility' stamp: 'BenjaminVanRyseghem 4/24/2012 14:18'! listAtCategoryNumber: aSmallInteger ^ (protocolOrganizer allProtocols at: aSmallInteger ifAbsent: [ ^ {} ]) methods asArray! ! !ClassOrganization methodsFor: 'backward compatibility' stamp: 'BenjaminVanRyseghem 4/12/2012 16:04'! removeCategory: aProtocolName | oldCategories | oldCategories := self protocolOrganizer allProtocolsNames copy. self protocolOrganizer removeProtocolNamed: aProtocolName. self notifyOfChangedCategoriesFrom: oldCategories to: self protocolOrganizer allProtocolsNames.! ! !ClassOrganization methodsFor: 'backward compatibility' stamp: 'BenjaminVanRyseghem 4/24/2012 14:38'! removeElement: aSymbol | oldCat | oldCat := self categoryOfElement: aSymbol. self protocolOrganizer removeMethod: aSymbol. self notifyOfChangedSelector: aSymbol from: oldCat to: (self categoryOfElement: aSymbol).! ! !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 16:20'! renameCategory: oldName toBe: newName self protocolOrganizer renameProtocol: oldName into: newName. self notifyOfChangedCategoryFrom: oldName to: newName.! ! !ClassOrganization methodsFor: 'backward compatibility' stamp: 'BenjaminVanRyseghem 4/12/2012 16:15'! setSubject: anObject organizedClass := anObject! ! !ClassOrganization methodsFor: 'backward compatibility' stamp: 'BenjaminVanRyseghem 4/24/2012 14:40'! sortCategories! ! !ClassOrganization methodsFor: 'backward compatibility' stamp: 'BenjaminVanRyseghem 4/12/2012 16:18'! subject ^organizedClass! ! !ClassOrganization methodsFor: 'backward compatibility - file in/out' stamp: 'BenjaminVanRyseghem 4/12/2012 18:11'! changeFromCategorySpecs: categorySpecs "notification" self internalChangeFromString: categorySpecs! ! !ClassOrganization methodsFor: 'backward compatibility - file in/out' stamp: 'BenjaminVanRyseghem 4/12/2012 18:29'! changeFromString: aString "Parse the argument, aString, and make this be the receiver's structure." | categorySpecs | categorySpecs := Scanner new scanTokens: aString. "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: '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: '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 - file in/out' stamp: 'BenjaminVanRyseghem 4/12/2012 18:10'! stringForFileOut ^ self protocolOrganizer stringForFileOut! ! !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: 'notifications' stamp: 'MarcusDenker 9/18/2012 13:50'! notifyOfChangedCategoriesFrom: oldCollectionOrNil to: newCollectionOrNil (self hasSubject and: [oldCollectionOrNil ~= newCollectionOrNil]) ifTrue: [SystemAnnouncer uniqueInstance classReorganized: self subject].! ! !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: 'notifications' stamp: 'BenjaminVanRyseghem 4/12/2012 15:54'! notifyOfChangedSelector: element from: oldCategory to: newCategory (self hasSubject and: [(oldCategory ~= newCategory)]) ifTrue: [ self subject notifyOfRecategorizedSelector: element from: oldCategory to: newCategory. ].! ! !ClassOrganization methodsFor: 'notifications' stamp: 'BenjaminVanRyseghem 4/12/2012 15:54'! notifyOfChangedSelectorsOldDict: oldDictionaryOrNil newDict: newDictionaryOrNil (oldDictionaryOrNil isNil and: [newDictionaryOrNil isNil]) ifTrue: [^ self]. oldDictionaryOrNil isNil ifTrue: [ newDictionaryOrNil keysAndValuesDo: [:el :cat | self notifyOfChangedSelector: el from: nil to: cat]. ^ self. ]. newDictionaryOrNil isNil ifTrue: [ oldDictionaryOrNil keysAndValuesDo: [:el :cat | self notifyOfChangedSelector: el from: cat to: nil]. ^ self. ]. oldDictionaryOrNil keysAndValuesDo: [:el :cat | | newCat | newCat := newDictionaryOrNil at: el. self notifyOfChangedSelector: el from: cat to: newCat. ].! ! !ClassOrganization methodsFor: 'protocol - forward' stamp: 'BenjaminVanRyseghem 4/12/2012 16:55'! categories ^ self protocolOrganizer protocolsNames! ! !ClassOrganization methodsFor: 'protocol - forward' stamp: 'BenjaminVanRyseghem 4/12/2012 16:45'! categoriesSorted ^ self protocolOrganizer protocolsSorted! ! !ClassOrganization methodsFor: 'protocol - forward' stamp: 'BenjaminVanRyseghem 4/12/2012 16:02'! listAtCategoryNamed: aName ^ (self protocolOrganizer methodsInProtocolNamed: aName) asArray! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ClassOrganization class instanceVariableNames: ''! !ClassOrganization class methodsFor: 'import' stamp: 'BenjaminVanRyseghem 4/24/2012 14:11'! importFrom: aClassOrganizer aClassOrganizer class = self ifTrue: [ ^ aClassOrganizer ]. ^ self new importFrom: aClassOrganizer; yourself! ! BehaviorInstallingDeclaration subclass: #ClassOrganizationDeclaration instanceVariableNames: 'classOrganizer' classVariableNames: '' poolDictionaries: '' category: 'CodeImport'! !ClassOrganizationDeclaration commentStamp: '' prior: 0! 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 instanceVariableNames: ''! !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! ! !ClassOrganizationDeclaration class methodsFor: 'instance creation' stamp: 'GuillermoPolito 5/5/2012 16:31'! contents: someContents organizer: aClassOrganizer ^self new contents: someContents; organizer: aClassOrganizer; yourself! ! BasicClassOrganizer subclass: #ClassOrganizer instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Classes'! !ClassOrganizer commentStamp: 'NS 4/6/2004 16:13' prior: 0! I represent method categorization information for classes. The handling of class comments has gone through a tortuous evolution. Grandfathered class comments (before late aug 98) have no time stamps, and historically, fileouts of class comments always substituted the timestamp reflecting the author and date/time at the moment of fileout; and historically any timestamps in a filed out class comment were dropped on the floor, with the author & time prevailing at the moment of filein being substituted. Such grandfathered comments now go out on fileouts with '' timestamp; class comments created after the 8/98 changes will have their correct timestamps preserved, though there is not yet a decent ui for reading those stamps other than filing out and looking at the file; nor is there yet any ui for browsing and recovering past versions of such comments. Everything in good time!!! !ClassOrganizer methodsFor: '*rpackage-systemintegration' stamp: 'EstebanLorenzano 2/22/2013 16:12'! silentlyRenameCategory: oldCatString toBe: newCatString | oldCat newCat oldElementsBefore oldElementsAfter index | oldCat := oldCatString asSymbol. newCat := newCatString asSymbol. oldElementsBefore := self listAtCategoryNamed: oldCat. (index := categoryArray indexOf: oldCat) = 0 ifTrue: [^ self]. "old name not found, so no action" (categoryArray indexOf: newCat) > 0 ifFalse: [ categoryArray := categoryArray copy. "need to change identity so smart list update will notice the change" categoryArray at: index put: newCat ] ifTrue: [ "if the category already exist, we move all elements inside and remove the old category" SystemAnnouncer uniqueInstance suspendAllWhile: [ oldElementsBefore do: [:anElement | self classify: anElement under: newCat ]. self removeCategory: oldCat ] ].! ! !ClassOrganizer methodsFor: 'accessing' stamp: 'EstebanLorenzano 8/3/2012 15:27'! addCategory: catString before: nextCategory | oldCategories | oldCategories := self categories copy. SystemAnnouncer uniqueInstance suspendAllWhile: [ super addCategory: catString before: nextCategory]. self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! ! !ClassOrganizer methodsFor: 'accessing' stamp: 'EstebanLorenzano 8/3/2012 15:27'! changeFromCategorySpecs: categorySpecs | oldDict oldCategories | oldDict := self elementCategoryDict. oldCategories := self categories copy. SystemAnnouncer uniqueInstance suspendAllWhile: [ super changeFromCategorySpecs: categorySpecs]. self notifyOfChangedSelectorsOldDict: oldDict newDict: self elementCategoryDict. self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! ! !ClassOrganizer methodsFor: 'accessing' stamp: 'EstebanLorenzano 8/3/2012 15:28'! classify: element under: heading suppressIfDefault: aBoolean | oldCat newCat | oldCat := self categoryOfElement: element. SystemAnnouncer uniqueInstance suspendAllWhile: [ super classify: element under: heading suppressIfDefault: aBoolean]. newCat := self categoryOfElement: element. self notifyOfChangedSelector: element from: oldCat to: newCat.! ! !ClassOrganizer methodsFor: 'accessing' stamp: 'PavelKrivanek 3/6/2012 10:50'! 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 categories. set ]. ^ (self categories copyWithoutAll: traitsCategories) asArray. ! ! !ClassOrganizer methodsFor: 'accessing' stamp: 'EstebanLorenzano 8/3/2012 15:28'! removeCategory: cat | oldCategories | oldCategories := self categories copy. SystemAnnouncer uniqueInstance suspendAllWhile: [ super removeCategory: cat]. self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! ! !ClassOrganizer methodsFor: 'accessing' stamp: 'EstebanLorenzano 8/3/2012 15:28'! removeElement: element | oldCat | oldCat := self categoryOfElement: element. SystemAnnouncer uniqueInstance suspendAllWhile: [ super removeElement: element]. self notifyOfChangedSelector: element from: oldCat to: (self categoryOfElement: element).! ! !ClassOrganizer methodsFor: 'accessing' stamp: 'EstebanLorenzano 8/3/2012 15:28'! removeEmptyCategories | oldCategories | oldCategories := self categories copy. SystemAnnouncer uniqueInstance suspendAllWhile: [ super removeEmptyCategories]. self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! ! !ClassOrganizer methodsFor: 'accessing' stamp: 'EstebanLorenzano 8/3/2012 15:28'! renameCategory: oldCatString toBe: newCatString | oldCat newCat oldElementsBefore oldElementsAfter | oldCat := oldCatString asSymbol. newCat := newCatString asSymbol. oldElementsBefore := self listAtCategoryNamed: oldCat. SystemAnnouncer uniqueInstance suspendAllWhile: [ super renameCategory: oldCatString toBe: newCatString]. oldElementsAfter := (self listAtCategoryNamed: oldCat) asSet. oldElementsBefore do: [:each | (oldElementsAfter includes: each) ifFalse: [self notifyOfChangedSelector: each from: oldCat to: newCat]. ]. self notifyOfChangedCategoryFrom: oldCat to: newCat.! ! !ClassOrganizer methodsFor: 'accessing' stamp: 'EstebanLorenzano 8/3/2012 15:28'! setDefaultList: aSortedCollection | oldDict oldCategories | oldDict := self elementCategoryDict. oldCategories := self categories copy. SystemAnnouncer uniqueInstance suspendAllWhile: [ super setDefaultList: aSortedCollection]. self notifyOfChangedSelectorsOldDict: oldDict newDict: self elementCategoryDict. self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! ! !ClassOrganizer methodsFor: 'accessing' stamp: 'EstebanLorenzano 8/3/2012 15:28'! sortCategories | oldCategories | oldCategories := self categories copy. SystemAnnouncer uniqueInstance suspendAllWhile: [ super sortCategories]. self notifyOfChangedCategoriesFrom: oldCategories to: self categories.! ! !ClassOrganizer methodsFor: 'compatibility' stamp: 'BenjaminVanRyseghem 4/24/2012 14:47'! categoriesSorted ^ self categories! ! !ClassOrganizer methodsFor: 'private' stamp: 'EstebanLorenzano 7/27/2012 16:30'! notifyOfChangedCategoriesFrom: oldCollectionOrNil to: newCollectionOrNil (self hasSubject and: [oldCollectionOrNil ~= newCollectionOrNil]) ifTrue: [SystemAnnouncer uniqueInstance classReorganized: self subject].! ! !ClassOrganizer methodsFor: 'private' stamp: 'EstebanLorenzano 7/27/2012 16:30'! notifyOfChangedCategoryFrom: oldNameOrNil to: newNameOrNil (self hasSubject and: [oldNameOrNil ~= newNameOrNil]) ifTrue: [SystemAnnouncer uniqueInstance classReorganized: self subject].! ! !ClassOrganizer methodsFor: 'private' stamp: 'NS 4/16/2004 10:47'! notifyOfChangedSelector: element from: oldCategory to: newCategory (self hasSubject and: [(oldCategory ~= newCategory)]) ifTrue: [ self subject notifyOfRecategorizedSelector: element from: oldCategory to: newCategory. ].! ! !ClassOrganizer methodsFor: 'private' stamp: 'eem 6/11/2008 17:00'! notifyOfChangedSelectorsOldDict: oldDictionaryOrNil newDict: newDictionaryOrNil (oldDictionaryOrNil isNil and: [newDictionaryOrNil isNil]) ifTrue: [^ self]. oldDictionaryOrNil isNil ifTrue: [ newDictionaryOrNil keysAndValuesDo: [:el :cat | self notifyOfChangedSelector: el from: nil to: cat]. ^ self. ]. newDictionaryOrNil isNil ifTrue: [ oldDictionaryOrNil keysAndValuesDo: [:el :cat | self notifyOfChangedSelector: el from: cat to: nil]. ^ self. ]. oldDictionaryOrNil keysAndValuesDo: [:el :cat | | newCat | newCat := newDictionaryOrNil at: el. self notifyOfChangedSelector: el from: cat to: newCat. ].! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ClassOrganizer class instanceVariableNames: ''! !ClassOrganizer class methodsFor: 'cleanup' stamp: 'StephaneDucasse 3/9/2010 22:21'! cleanUp: aggressive "Remove empty method categories when cleaning aggressively" aggressive ifTrue: [Smalltalk removeEmptyMessageCategories]. ! ! TestCase subclass: #ClassQueryTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-System'! !ClassQueryTest methodsFor: 'dependencies' stamp: 'NickPapoulias 2/8/2013 15:56'! testReferencedClasses " self debug: #testReferencedClasses " | refs | refs := Metaclass referencedClasses. self assert: (refs includes: ClassBuilder). refs := self class referencedClasses. self assert: (refs includesAllOf: {SoundService . Beeper})! ! !ClassQueryTest methodsFor: 'tests' stamp: 'AlexandreBergel 9/12/2011 11:03'! testAllCallsOn | set | set := Beeper allCallsOn. self assert: (set allSatisfy: [ :cm | (cm compiledMethod literals select: [ :l | l isKindOf: Association ] thenCollect: #value) includes: Beeper])! ! !ClassQueryTest methodsFor: 'tests' stamp: 'AlexandreBergel 9/12/2011 11:07'! testAllCallsOnASymbol | set cm | set := Beeper allCallsOn: #beep. cm := (set detect: [ :rgMethod | rgMethod selector == #play ]) compiledMethod. self assert: (cm methodClass == Beeper). self assert: (cm literals includes: #beep)! ! SystemAnnouncement subclass: #ClassRecategorized instanceVariableNames: 'newCategory oldCategory classRecategorized' classVariableNames: '' poolDictionaries: '' category: 'System-Announcements'! !ClassRecategorized commentStamp: 'cyrilledelaunay 1/18/2011 10:42' prior: 0! 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/3/2012 13:50'! classAffected ^self classRecategorized! ! !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/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/2/2012 00:25'! oldCategory ^oldCategory! ! !ClassRecategorized methodsFor: 'accessing' stamp: 'GuillermoPolito 8/1/2012 23:58'! oldCategory: anOldCategory oldCategory := anOldCategory! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ClassRecategorized class instanceVariableNames: ''! !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! ! SystemAnnouncement subclass: #ClassRemoved instanceVariableNames: 'categoryName classRemoved' classVariableNames: '' poolDictionaries: '' category: 'System-Announcements'! !ClassRemoved commentStamp: 'cyrilledelaunay 1/18/2011 11:43' prior: 0! the annoucement will be emitted when removing a class or a trait using: => removeFromSystem! !ClassRemoved methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:29'! categoryName ^ categoryName! ! !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'! classRemoved ^ classRemoved! ! !ClassRemoved methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:29'! classRemoved: anObject classRemoved := anObject! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ClassRemoved class instanceVariableNames: ''! !ClassRemoved class methodsFor: 'instance creation' stamp: 'GuillermoPolito 8/2/2012 00:29'! class: aClass category: aCategoryName ^self new classRemoved: aClass; categoryName: aCategoryName; yourself.! ! TestCase subclass: #ClassRenameFixTest instanceVariableNames: 'previousChangeSet testsChangeSet newClassName originalName' classVariableNames: '' poolDictionaries: '' category: 'Tests-Bugs'! !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: '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: '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: '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: 'tests' stamp: 'md 9/6/2005 18:30'! testRenameClassUsingClass "self run: #testRenameClassUsingClass" self renameClassUsing: [:class :newName | class rename: newName].! ! !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: '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]]! ! SystemAnnouncement subclass: #ClassRenamed instanceVariableNames: 'category classRenamed newName oldName' classVariableNames: '' poolDictionaries: '' category: 'System-Announcements'! !ClassRenamed commentStamp: 'cyrilledelaunay 1/18/2011 11:44' prior: 0! 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'! category ^ category! ! !ClassRenamed methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:33'! category: anObject category := 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'! classRenamed: anObject classRenamed := anObject! ! !ClassRenamed methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:33'! newName ^newName! ! !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 ^oldName! ! !ClassRenamed methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:33'! oldName: anObject oldName := anObject! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ClassRenamed class instanceVariableNames: ''! !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! ! SystemAnnouncement subclass: #ClassReorganized instanceVariableNames: 'classReorganized' classVariableNames: '' poolDictionaries: '' category: 'System-Announcements'! !ClassReorganized commentStamp: 'cyrilledelaunay 1/18/2011 15:03' prior: 0! 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 instanceVariableNames: ''! !ClassReorganized class methodsFor: 'instance creation' stamp: 'GuillermoPolito 8/2/2012 00:36'! class: aClass ^self new classReorganized: aClass; yourself! ! SystemAnnouncement subclass: #ClassRepackaged instanceVariableNames: 'classRepackaged newPackage oldPackage' classVariableNames: '' poolDictionaries: '' category: 'RPackage-SystemIntegration'! !ClassRepackaged methodsFor: 'accessing' stamp: 'GuillermoPolito 8/17/2012 17:18'! classRepackaged ^ classRepackaged! ! !ClassRepackaged methodsFor: 'accessing' stamp: 'GuillermoPolito 8/17/2012 17:18'! classRepackaged: anObject classRepackaged := anObject! ! !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 methodsFor: 'accessing' stamp: 'GuillermoPolito 8/17/2012 17:18'! oldPackage ^ oldPackage! ! !ClassRepackaged methodsFor: 'accessing' stamp: 'GuillermoPolito 8/17/2012 17:18'! oldPackage: anObject oldPackage := anObject! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ClassRepackaged class instanceVariableNames: ''! !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.! ! TestCase subclass: #ClassTest instanceVariableNames: 'className renamedName' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Classes'! !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: '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: '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! ! !ClassTest methodsFor: 'classcreation' stamp: 'NouryBouraqadi 12/16/2011 15:13'! unclassifiedCategory ^#Unclassified! ! !ClassTest methodsFor: 'setup' stamp: 'Janniklaval 10/23/2010 13:35'! categoryNameForTemporaryClasses "Answer the category where to classify temporarily created classes" ^'Dummy-Tests-Class'! ! !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: '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: 'setup' stamp: 'NouryBouraqadi 12/16/2011 15:15'! tearDown self deleteClass. self deleteRenamedClass. {self unclassifiedCategory. self categoryNameForTemporaryClasses} do: [:category| Smalltalk organization removeCategory: category]! ! !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: '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' 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' 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: '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 - access' stamp: 'StephaneDucasse 12/13/2011 17:04'! 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" self shouldnt: [ Date class sharedPools] raise: Error. 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 - 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: '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 - access' stamp: 'StephaneDucasse 12/13/2011 16:51'! 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" self shouldnt: [ Date class sharedPools] raise: Error. 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: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 - 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 - compiling' stamp: 'sd 6/5/2005 08:25'! testCompileAll self shouldnt: [ClassTest compileAll] raise: Error.! ! !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 - 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). ! ! TestCase subclass: #ClassTestCase instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Core-Utilities'! !ClassTestCase commentStamp: 'brp 7/26/2003 16:57' prior: 0! 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/27/2003 12:39'! classToBeTested self subclassResponsibility! ! !ClassTestCase methodsFor: 'coverage' stamp: 'brp 7/26/2003 16:35'! selectorsNotTested ^ self selectorsToBeTested difference: self selectorsTested. ! ! !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: 'coverage' stamp: 'brp 7/26/2003 17:22'! selectorsToBeIgnored ^ #(#DoIt #DoItIn:)! ! !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: 'tests' stamp: 'marcus.denker 7/29/2009 15:27'! testClassComment self should: [self targetClass organization hasComment].! ! !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: 'tests' stamp: 'md 3/25/2003 23:07'! testNew self shouldnt: [self targetClass new] raise: Error.! ! !ClassTestCase methodsFor: 'tests' stamp: 'md 3/26/2003 17:24'! testUnCategorizedMethods | categories slips | categories := self categoriesForClass: self targetClass. slips := categories select: [:each | each = #'as yet unclassified']. self should: [slips isEmpty]. ! ! !ClassTestCase methodsFor: 'private' stamp: 'md 1/28/2004 11:32'! categoriesForClass: aClass ^ aClass organization allMethodSelectors collect: [:each | aClass organization categoryOfElement: each]. ! ! !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 class instanceVariableNames: ''! !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 ! ! !ClassTestCase class methodsFor: 'testing' stamp: 'brp 12/14/2003 15:50'! mustTestCoverage ^ false! ! TraitDescription subclass: #ClassTrait uses: TApplyingOnClassSide instanceVariableNames: 'baseTrait' classVariableNames: '' poolDictionaries: '' category: 'Traits-Kernel'! !ClassTrait commentStamp: '' prior: 0! 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: '*Fuel' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^aGeneralMapper visitClassTrait: self ! ! !ClassTrait methodsFor: '*Monticello' stamp: 'damiencassou 7/30/2009 12:10'! asMCDefinition ^MCClassTraitDefinition baseTraitName: self baseTrait name classTraitComposition: self traitCompositionString category: self category ! ! !ClassTrait methodsFor: '*Ring-Core-Kernel' stamp: 'VeronicaUquillas 9/19/2011 16:45'! asFullRingDefinition ^ self theNonMetaClass asFullRingDefinition theMetaClass! ! !ClassTrait methodsFor: '*Ring-Core-Kernel' stamp: 'VeronicaUquillas 9/19/2011 16:45'! asRingDefinition ^ self theNonMetaClass asRingDefinition theMetaClass! ! !ClassTrait methodsFor: '*refactoring-core' stamp: 'md 3/14/2006 16:45'! includesBehavior: aClass ^false! ! !ClassTrait methodsFor: '*refactoring-core' stamp: 'md 3/14/2006 16:37'! soleInstance ^baseTrait! ! !ClassTrait methodsFor: 'accessing' stamp: 'damiencassou 8/6/2009 11:37'! category ^ self baseTrait category! ! !ClassTrait methodsFor: 'accessing' stamp: 'al 4/21/2004 09:38'! name ^self baseTrait name , ' classTrait'! ! !ClassTrait methodsFor: 'accessing parallel hierarchy' stamp: 'al 3/16/2004 10:38'! baseTrait ^baseTrait! ! !ClassTrait methodsFor: 'accessing parallel hierarchy' stamp: 'jannik.laval 5/1/2010 16:02'! baseTrait: aTrait [aTrait isBaseTrait] assert. baseTrait := aTrait ! ! !ClassTrait methodsFor: 'accessing parallel hierarchy' stamp: 'al 3/16/2004 10:38'! classTrait ^self! ! !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 parallel hierarchy' stamp: 'al 3/16/2004 10:41'! hasClassTrait ^false! ! !ClassTrait methodsFor: 'accessing parallel hierarchy' stamp: 'al 3/16/2004 10:48'! isBaseTrait ^false! ! !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: 'composition'! 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: 'composition'! 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: 'composition' stamp: 'EstebanLorenzano 7/27/2012 16:30'! uses: aTraitCompositionOrArray | copyOfOldTrait newComposition | copyOfOldTrait := self copy. newComposition := aTraitCompositionOrArray asTraitComposition. self assertConsistantCompositionsForNew: newComposition. self setTraitComposition: newComposition. SystemAnnouncer uniqueInstance traitDefinitionChangedFrom: copyOfOldTrait to: self.! ! !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: '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: 'initialize' stamp: 'al 7/18/2004 12:11'! baseClass: aTrait traitComposition: aComposition methodDict: aMethodDict localSelectors: aSet organization: aClassOrganization self baseTrait: aTrait. self traitComposition: aComposition methodDict: aMethodDict localSelectors: aSet organization: aClassOrganization ! ! !ClassTrait methodsFor: 'initialize' stamp: 'dvf 8/30/2005 16:48'! initializeFrom: anotherClassTrait traitComposition := self traitComposition copyTraitExpression. methodDict := self methodDict copy. localSelectors := self localSelectors copy. organization := 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: 'initialize' stamp: 'al 7/17/2004 22:56'! traitComposition: aComposition methodDict: aMethodDict localSelectors: aSet organization: aClassOrganization "Used by copy of Trait" localSelectors := aSet. methodDict := aMethodDict. traitComposition := aComposition. self organization: aClassOrganization! ! !ClassTrait methodsFor: 'testing' stamp: 'nice 11/5/2009 21:51'! isSelfEvaluating "Return true if the receiver printString is evaluating back to self." ^baseTrait isObsolete not! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ClassTrait class uses: TApplyingOnClassSide classTrait instanceVariableNames: ''! !ClassTrait class methodsFor: 'instance creation' stamp: 'al 3/23/2004 19:41'! for: aTrait ^self new initializeWithBaseTrait: aTrait; yourself! ! TraitsTestCase subclass: #ClassTraitTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Traits'! !ClassTraitTest methodsFor: 'testing' stamp: 'CamilloBruni 5/30/2012 12:40'! 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 methodDict includesKey: #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 shouldnt: [self c2 m1ClassSide] raise: Error. 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: 'dvf 8/26/2005 14:32'! 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! ! !ClassTraitTest methodsFor: 'testing' stamp: 'GuillermoPolito 7/22/2012 16:25'! testInitialization "self run: #testInitialization" | classTrait | classTrait := self t1 classTrait. self assert: self t1 hasClassTrait. 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 hasClassTrait. self assert: self t5 hasClassTrait. self assert: (self t2 classSide includesLocalSelector: #m2ClassSide:). self assert: (self t4 classSide methodDict includesKey: #m2ClassSide:). self assert: (self t5 classSide methodDict includesKey: #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! ! MorphTreeModel subclass: #ClassTreeExample instanceVariableNames: 'rootClass' classVariableNames: '' poolDictionaries: '' category: 'Morphic-MorphTreeWidget-Examples'! !ClassTreeExample commentStamp: 'AlainPlantec 1/18/2010 16:20' prior: 0! ClassTreeExample new openOn: Object ! !ClassTreeExample methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 2/13/2010 08:39'! expandAllFromNode: aNode self changed: {#rootNodes. #expandAllFromNode:. aNode}! ! !ClassTreeExample methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 2/25/2011 17:04'! keyStroke: anEvent from: aTreeMorph self selectedNode ifNotNil: [:current | current keyStroke: anEvent from: aTreeMorph]! ! !ClassTreeExample methodsFor: 'as yet unclassified' 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! ! !ClassTreeExample methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 1/16/2010 09:50'! open ^ self openOn: Object ! ! !ClassTreeExample methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'AlainPlantec 1/16/2010 09:50'! rootClass ^ rootClass ifNil: [rootClass := Object]! ! !ClassTreeExample methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 1/16/2010 09:50'! rootClass: aClass rootClass := aClass! ! !ClassTreeExample methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 1/15/2010 13:53'! rootItems ^ OrderedCollection with: self rootClass! ! !ClassTreeExample methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 2/7/2010 22:44'! rootNodeClassFromItem: anItem ^ ClassTreeNodeExample! ! !ClassTreeExample methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 10/3/2011 01:26'! treeMorph | treeMorph | treeMorph := (LazyMorphTreeMorph 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! ! MorphTreeNodeModel subclass: #ClassTreeNodeExample instanceVariableNames: 'contents' classVariableNames: '' poolDictionaries: '' category: 'Morphic-MorphTreeWidget-Examples'! !ClassTreeNodeExample methodsFor: 'accessing' stamp: 'StephaneDucasse 10/15/2011 20:54'! browseItem Smalltalk tools browser fullOnClass: self item selector: nil ! ! !ClassTreeNodeExample methodsFor: 'accessing' stamp: 'AlainPlantec 1/16/2010 09:51'! exploreItem self explore! ! !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: '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: 'AlainPlantec 1/15/2010 13:44'! childrenItems ^ (self item subclasses asArray sort: [:a :b | a name < b name]) asOrderedCollection ! ! !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: 'menu' stamp: 'FernandoOlivero 4/12/2011 09:41'! commentText ^ ( self theme newTextIn: World text: self item comment) unlock; wrapFlag: true; yourself! ! !ClassTreeNodeExample methodsFor: 'menu' stamp: 'AlainPlantec 1/15/2010 13:43'! contents ^ contents ifNil: [contents := super contents]! ! !ClassTreeNodeExample methodsFor: 'menu' stamp: 'FernandoOlivero 4/12/2011 09:41'! icon ^ self theme smallExpertIcon! ! Object subclass: #Clipboard instanceVariableNames: 'contents recent' classVariableNames: 'Default' poolDictionaries: '' category: 'System-Clipboard'! !Clipboard commentStamp: 'AlainPlantec 1/15/2010 11:42' prior: 0! 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: '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: '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: '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: 'initialize' stamp: 'alain.plantec 5/28/2009 09:47'! initialize super initialize. contents := '' asText. recent := OrderedCollection new! ! !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: '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 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 class instanceVariableNames: ''! !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: 'ar 1/15/2001 18:35'! clipboardText "Clipboard clipboardText" ^self default clipboardText.! ! !Clipboard class methodsFor: 'accessing' stamp: 'ar 1/15/2001 18:35'! clipboardText: aText ^self default clipboardText: aText! ! !Clipboard class methodsFor: 'accessing' stamp: 'michael.rueger 3/2/2009 11:12'! default ^Default ifNil: [Default := OSPlatform current clipboardClass new].! ! !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: '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: '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]! ! PluggableCanvas subclass: #ClippingCanvas instanceVariableNames: 'canvas clipRect' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Support'! !ClippingCanvas commentStamp: '' prior: 0! A modified canvas which clips all drawing commands.! !ClippingCanvas methodsFor: 'accessing' stamp: 'ls 3/25/2000 22:56'! clipRect ^clipRect! ! !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: 'accessing' stamp: 'ls 3/20/2000 21:15'! shadowColor ^canvas shadowColor! ! !ClippingCanvas methodsFor: 'initialization' stamp: 'ls 3/20/2000 20:44'! canvas: aCanvas clipRect: aRectangle canvas := aCanvas. clipRect := aRectangle.! ! !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: '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 class instanceVariableNames: ''! !ClippingCanvas class methodsFor: 'instance creation' stamp: 'ls 3/20/2000 20:45'! canvas: aCanvas clipRect: aRectangle ^self new canvas: aCanvas clipRect: aRectangle! ! TestCase subclass: #ClosureCompilerTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CompilerTests'! !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: 'MarcusDenker 8/2/2011 17:30'! doTestDebuggerTempAccessWith: one with: two "Test debugger access for temps" | outerContext local1 remote1 | outerContext := thisContext. local1 := 3. remote1 := 1/2. self assert: (self class evaluatorClass new evaluate: 'one' in: thisContext to: self) == one. self assert: (self class evaluatorClass new evaluate: 'two' in: thisContext to: self) == two. self assert: (self class evaluatorClass new evaluate: 'local1' in: thisContext to: self) == local1. self assert: (self class evaluatorClass new evaluate: 'remote1' in: thisContext to: self) == remote1. self class evaluatorClass new 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 evaluatorClass new evaluate: 'one' in: thisContext to: self) == one. self assert: (r2 := self new evaluate: 'two' in: thisContext to: self) == two. self assert: (r3 := self class evaluatorClass new evaluate: 'i' in: thisContext to: self) == i. self assert: (r4 := self class evaluatorClass new evaluate: 'local2' in: thisContext to: self) == local2. self assert: (r4 := self class evaluatorClass new evaluate: 'remote1' in: thisContext to: self) == remote1. self assert: (r4 := self class evaluatorClass new evaluate: 'remote1' in: outerContext to: self) == remote1. self class evaluatorClass new evaluate: 'local2 := 15' in: thisContext to: self. self assert: local2 = 15. self class evaluatorClass new 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: '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 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: '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 10/9/2012 17:54'! 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| Scanner new scanTokens: string]. 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: [(ctxt abstractPC = 2)]) not]]) or: [ctxt willReturn]]]) ifTrue: [debugTokens := debugTokenSequence at: (debugCount := debugCount + 1) ifAbsent: [#(bogusToken)]. self assert: (sourceMap includesKey: ctxt abstractPC). range := sourceMap at: ctxt abstractPC ifAbsent: [(1 to: 0)]. self assert: (Scanner new scanTokens: (source copyFrom: range first to: range last)) = debugTokens]]. self assert: evaluationCount = 2! ! !ClosureCompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 4/29/2012 14:11'! testBlockDoitDecompilation "Tests that decompile of a doit block with remote vars executes correcly" "Tests that decompilation of a Block, when 'method' of block is equivalent to that compiled by a DoIt, preserves the temp names " |blockSourceStream methodNode compiledMethod block decompiledBlock| blockSourceStream := '|x y| [:a :b | x := a. y := b. x + y]' readStream. methodNode := nil class evaluatorClass new from: blockSourceStream class: nil class context: nil notifying: nil; translate: blockSourceStream noPattern: true ifFail: [nil]. compiledMethod := methodNode generateWithSource. block := nil withArgs: #() executeMethod: compiledMethod. self shouldnt: [decompiledBlock := block decompile] raise: Error. self assert: '{[:a :b | x := a. y := b. x + y]}' equals: decompiledBlock printString ! ! !ClosureCompilerTest methodsFor: 'tests' stamp: 'BenjaminVanRyseghem 9/27/2011 13:59'! 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 startpcsToBlockExtents values asSet! ! !ClosureCompilerTest methodsFor: 'tests' stamp: 'nice 1/16/2010 17:12'! 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 generate. tempRefs := methodNode encoder blockExtentsToTempsMap. self assert: tempRefs keys asSet = method startpcsToBlockExtents 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: 'tests' stamp: 'MarcusDenker 8/20/2011 13:41'! testDebuggerTempAccess self doTestDebuggerTempAccessWith: 1 with: 2! ! !ClosureCompilerTest methodsFor: 'tests' stamp: 'MarcusDenke 4/29/2012 20:41'! testDecompiledDoitMethodTempNames "self new testDecompiledDoitMethodTempNames" "Test that a decompiled doit that has been copied with temps decompiles to the input" | removeComments | removeComments := [:n| n comment: nil]. self closureCases do: [:source| | mns m mps mnps | "Need to compare an ungenerated tree with the generated method's methodNode because generating code alters the tree when it introduces remote temp vectors." mns := #(first last) collect: [:ignored| source first isLetter ifTrue: [self class compilerClass new compile: source in: self class notifying: nil ifFail: [self error: 'compilation error']] ifFalse: [self class compilerClass new compileNoPattern: source in: self class context: nil notifying: nil ifFail: [self error: 'compilation error']]]. m := (mns last generateWithSource). removeComments value: mns first. mns first nodesDo: removeComments. self assert: (mnps := mns first printString) = (mps := (m methodNode nodesDo: removeComments) printString)]! ! !ClosureCompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 8/20/2011 13:41'! testInjectIntoDecompilations "Test various compilations decompile to the same code for a method sufficiently simple that this is possible and sufficiently complex that the code generated varies between the compilations." "self new testInjectIntoDecompilations" | source | source := (Collection sourceCodeAt: #inject:into:) asString. { Encoder. EncoderForV3. EncoderForLongFormV3. EncoderForV3PlusClosures. EncoderForLongFormV3PlusClosures } do: [:encoderClass| | method | method := (Parser new encoderClass: encoderClass; parse: source class: Collection) generate. self assert: (Scanner new scanTokens: method decompileString) = #(inject: t1 into: t2 | t3 | t3 ':=' t1 . self do: [ ':t4' | t3 ':=' t2 value: t3 value: t4 ] . ^ t3)]! ! !ClosureCompilerTest methodsFor: 'tests' stamp: 'MarcusDenker 8/20/2011 13:41'! testInjectIntoDecompiledDebugs "Test various debugs of the decompiled form debug correctly." "self new testInjectIntoDecompiledDebugs" | source | source := (Collection sourceCodeAt: #inject:into:) asString. { Encoder. EncoderForV3PlusClosures. EncoderForLongFormV3PlusClosures } do: [:encoderClass| | method | method := (Parser new encoderClass: encoderClass; parse: source class: Collection) generate. self supportTestSourceRangeAccessForDecompiledInjectInto: method source: method decompileString]! ! !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 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: '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 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: '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 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: '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: '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: '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 class instanceVariableNames: ''! !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 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)"! ! !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/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: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 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"! ! TestCase subclass: #ClosureTests instanceVariableNames: 'collection' classVariableNames: '' poolDictionaries: '' category: 'CompilerTests'! !ClosureTests methodsFor: 'running' stamp: 'lr 3/9/2009 16:48'! setUp super setUp. collection := OrderedCollection new! ! !ClosureTests methodsFor: 'testing' stamp: 'lr 3/11/2009 17:35'! methodArgument: anObject ^ [ anObject ] ! ! !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' 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' 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' 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' 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-empty' stamp: 'jb 7/1/2011 10:38'! testEmptyBlockOneArgument self assert: (self class evaluatorClass evaluate: '[ :a ] value: 1') isNil description: 'Empty blocks in ST-80 should return nil'. self assert: (self class evaluatorClass evaluate: '[ :a | ] value: 1') isNil description: 'Empty blocks in ST-80 should return nil'. self assert: (self class evaluatorClass evaluate: '[ :a | | t | ] value: 1') isNil description: 'Empty blocks in ST-80 should return nil'! ! !ClosureTests methodsFor: 'testing-empty' stamp: 'jb 7/1/2011 10:42'! testEmptyBlockTwoArguments self assert: (self class evaluatorClass evaluate: '[ :a :b ] value: 1 value: 2') isNil description: 'Empty blocks in ST-80 should return nil'. self assert: (self class evaluatorClass evaluate: '[ :a :b | ] value: 1 value: 2') isNil description: 'Empty blocks in ST-80 should return nil'. self assert: (self class evaluatorClass evaluate: '[ :a :b | | t | ] value: 1 value: 2') isNil description: 'Empty blocks in ST-80 should return nil'! ! !ClosureTests methodsFor: 'testing-empty' stamp: 'jb 7/1/2011 10:42'! testEmptyBlockZeroArguments self assert: (self class evaluatorClass evaluate: '[ ] value') isNil description: 'Empty blocks in ST-80 should return nil'. self assert: (self class evaluatorClass evaluate: '[ | t | ] value') isNil description: 'Empty blocks in ST-80 should return nil'! ! !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-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'! testToDoInsideTemp 1 to: 5 do: [ :index | | temp | temp := index. collection add: [ temp ] ]. self assertValues: #(1 2 3 4 5)! ! !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-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-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: '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-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: '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: '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-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: '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]! ! StringMorph subclass: #CodeAnnotationMorph instanceVariableNames: 'codeHolder process' classVariableNames: '' poolDictionaries: '' category: 'Tools-Browser'! !CodeAnnotationMorph commentStamp: 'LaurentLaffont 2/13/2011 16:46' prior: 0! 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: 'accessing' stamp: 'AlainPlantec 11/13/2009 23:42'! codeHolder: aCodeHolder codeHolder := aCodeHolder. aCodeHolder ifNotNil: [aCodeHolder addDependent: self]! ! !CodeAnnotationMorph methodsFor: 'initialization' stamp: 'AlainPlantec 11/14/2009 00:03'! initialize super initialize. self borderWidth: 0. self contents: ''. ! ! !CodeAnnotationMorph methodsFor: 'updating' stamp: 'Igor.Stasenko 5/9/2010 23:01'! syncContents | ch | process ifNotNil: [ process terminate ]. process := nil. ch := codeHolder ifNil: [ ^ self contents: '' ]. process := [ | ann | ann := ch annotation ifNil: ['']. WorldState addDeferredUIMessage: [ self contents: ann ]. ] newProcess. process priority: Processor userBackgroundPriority. process resume. ! ! !CodeAnnotationMorph methodsFor: 'updating' stamp: 'Igor.Stasenko 10/12/2010 23:29'! update: anAspect super update: anAspect. anAspect == #contents ifFalse: [ ^self ]. self syncContents. ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CodeAnnotationMorph class instanceVariableNames: ''! !CodeAnnotationMorph class methodsFor: 'instance creation' stamp: 'AlainPlantec 11/13/2009 23:34'! on: aCodeHolder ^ self new codeHolder: aCodeHolder! ! ComposableModel subclass: #CodeCriticBrowser instanceVariableNames: 'environment listModel1 listModel2 listModel3 process status textModel' classVariableNames: '' poolDictionaries: '' category: 'NautilusRefactoring-Utilities'! !CodeCriticBrowser commentStamp: '' prior: 0! A CodeCriticBrowser is a UI made to browse code critics refactor! !CodeCriticBrowser methodsFor: 'accessing'! environment ^ environment! ! !CodeCriticBrowser methodsFor: 'accessing'! environment: anObject environment := anObject! ! !CodeCriticBrowser methodsFor: 'accessing'! listModel1 ^ listModel1! ! !CodeCriticBrowser methodsFor: 'accessing'! listModel1: anObject listModel1 := anObject! ! !CodeCriticBrowser methodsFor: 'accessing'! listModel2 ^ listModel2! ! !CodeCriticBrowser methodsFor: 'accessing'! listModel2: anObject listModel2 := anObject! ! !CodeCriticBrowser methodsFor: 'accessing'! listModel3 ^ listModel3! ! !CodeCriticBrowser methodsFor: 'accessing'! listModel3: anObject listModel3 := anObject! ! !CodeCriticBrowser methodsFor: 'accessing'! process ^ process! ! !CodeCriticBrowser methodsFor: 'accessing'! process: anObject process := anObject! ! !CodeCriticBrowser methodsFor: 'accessing'! status ^ status! ! !CodeCriticBrowser methodsFor: 'accessing'! status: anObject status := anObject! ! !CodeCriticBrowser methodsFor: 'accessing'! textModel ^ textModel! ! !CodeCriticBrowser methodsFor: 'accessing'! textModel: anObject textModel := anObject! ! !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: 'initialization' stamp: 'BenjaminVanRyseghem 6/12/2012 17:54'! initializeWidgets self instantiateModels: #( listModel1 ListComposableModel listModel2 ListComposableModel listModel3 ListComposableModel textModel TextModel ). listModel1 displayBlock: [:rule | rule name ]. listModel2 displayBlock: [:rule | rule name ]. listModel3 displayBlock: [:rule | rule name ].! ! !CodeCriticBrowser methodsFor: 'processing'! 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: 'protocol'! rules: aCollection listModel1 items: aCollection! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CodeCriticBrowser class instanceVariableNames: ''! !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'! 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. }}! ! Object subclass: #CodeDeclaration instanceVariableNames: 'contents' classVariableNames: '' poolDictionaries: '' category: 'CodeImport'! !CodeDeclaration commentStamp: '' prior: 0! I'm the abstract superclass of all the code declarations that should exist in an exported file.! !CodeDeclaration methodsFor: 'accessing' stamp: 'GuillermoPolito 5/5/2012 16:02'! contents ^ contents! ! !CodeDeclaration methodsFor: 'accessing' stamp: 'GuillermoPolito 5/5/2012 16:02'! contents: anObject contents := anObject! ! !CodeDeclaration methodsFor: 'printing' stamp: 'GuillermoPolito 5/5/2012 20:21'! printOn: aStream super printOn: aStream. aStream nextPut: $(. aStream nextPutAll: contents. aStream nextPut: $).! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CodeDeclaration class instanceVariableNames: ''! !CodeDeclaration class methodsFor: 'instance creation' stamp: 'GuillermoPolito 5/5/2012 16:02'! contents: someContents ^self new contents: someContents; yourself! ! StringHolder subclass: #CodeHolder instanceVariableNames: 'currentCompiledMethod contentsSymbol' classVariableNames: 'AnnotationRequests BrowseWithPrettyPrint DecorateBrowserButtons DiffsInChangeList DiffsWithPrettyPrint OptionalButtons ShowAnnotationPane SmartUpdating' poolDictionaries: '' category: 'Tools-Base'! !CodeHolder commentStamp: '' prior: 0! 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: '*Shout-Styling'! shoutIsModeStyleable ^ self showingSource or: [self showingPrettyPrint]! ! !CodeHolder methodsFor: '*necompletion-override' stamp: 'EstebanLorenzano 4/11/2012 17:11'! contentsChanged super contentsChanged. self changed: #annotation.! ! !CodeHolder methodsFor: 'accessing' stamp: 'StephaneDucasse 2/23/2012 14:24'! receiverClass ^ self selectedClassOrMetaClass! ! !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: '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: '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: '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: '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 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: '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: 'annotation' stamp: 'AlainPlantec 12/21/2009 22:23'! annotationRequests ^ self class annotationRequests! ! !CodeHolder methodsFor: 'annotation' stamp: 'sw 2/22/2001 10:02'! annotationSeparator "Answer the separator to be used between annotations" ^ ' · '! ! !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: '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: 'categories' stamp: 'nice 1/5/2010 15:59'! categoryFromUserWithPrompt: aPrompt for: aClass "self new categoryFromUserWithPrompt: 'testing' for: SystemDictionary" | labels myCategories reject lines newName menuIndex | labels := OrderedCollection new. labels addAll: (myCategories := aClass organization categories asSortedCollection: [:a :b | a asLowercase < b asLowercase]). reject := myCategories asSet. reject add: ClassOrganizer nullCategory; add: ClassOrganizer default. 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: '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: '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: '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: '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: '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: 'commands' stamp: 'nk 6/26/2003 21:43'! 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: #browseAllCallsOn: to: self systemNavigation! ! !CodeHolder methodsFor: 'commands' stamp: 'StephaneDucasse 2/25/2011 18:40'! copyUpOrCopyDown "Used to copy down code from a superclass to a subclass or vice-versa in one easy step, if you know what you're doing. Prompt the user for which class to copy down or copy up to, then spawn a fresh browser for that class, with the existing code planted in it, and with the existing method category also established." | aClass aSelector allClasses implementors aMenu | ((aClass := self selectedClassOrMetaClass) isNil or: [(aSelector := self selectedMessageName) == nil]) ifTrue: [^ Beeper beep]. allClasses := self systemNavigation hierarchyOfClassesSurrounding: aClass. implementors := self systemNavigation hierarchyOfImplementorsOf: aSelector forClass: aClass. aMenu := UIManager default newMenuIn: self for: self. aMenu title: aClass name, '.', aSelector, ' Choose where to insert a copy of this method (blue = current, black = available, red = other implementors'. allClasses do: [:cl | | aColor | aColor := cl == aClass ifTrue: [#blue] ifFalse: [(implementors includes: cl) ifTrue: [#red] ifFalse: [#black]]. (aColor == #red) ifFalse: [aMenu add: cl name selector: #spawnToClass: argument: cl] ifTrue: [aMenu add: cl name selector: #spawnToCollidingClass: argument: cl]. aMenu lastItem color: (Color colorFrom: aColor)]. aMenu popUpInWorld! ! !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 2/27/2001 12:15'! offerUnshiftedClassListMenu "Offer the shifted class-list menu." ^ self offerMenuFrom: #classListMenu:shifted: shifted: false! ! !CodeHolder methodsFor: 'commands' stamp: 'sd 11/20/2005 21:27'! 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: [Beeper beep. ^ 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: 'commands' stamp: 'sw 3/6/2001 15:18'! shiftedYellowButtonActivity "Offer the shifted selector-list menu" ^ self offerMenuFrom: #messageListMenu:shifted: shifted: true! ! !CodeHolder methodsFor: 'commands' stamp: 'IgorStasenko 4/26/2011 16:44'! spawnToClass: aClass "Used to copy down code from a superclass to a subclass in one easy step, if you know what you're doing. Spawns a new message-category browser for the indicated class, populating it with the source code seen in the current tool." | aCategory newBrowser org | (aCategory := self categoryOfCurrentMethod) ifNil: [self buildClassBrowserEditString: self contents] ifNotNil: [((org := aClass organization) categories includes: aCategory) ifFalse: [org addCategory: aCategory]. newBrowser := Smalltalk tools browser new setClass: aClass selector: nil. newBrowser selectMessageCategoryNamed: aCategory. Smalltalk tools browser openBrowserView: (newBrowser openMessageCatEditString: self contents) label: 'category "', aCategory, '" in ', newBrowser selectedClassOrMetaClassName]! ! !CodeHolder methodsFor: 'commands' stamp: 'sw 3/20/2001 15:11'! spawnToCollidingClass: aClass "Potentially used to copy down code from a superclass to a subclass in one easy step, in the case where the given class already has its own version of code, which would consequently be clobbered if the spawned code were accepted." self inform: 'That would be destructive of some pre-existing code already in that class for this selector. For the moment, we will not let you do this to yourself.'! ! !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: '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: 'construction' stamp: 'StephaneDucasse 12/19/2012 16:17'! 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 divider | 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: 'construction' stamp: 'IgorStasenko 4/26/2011 16:45'! buildClassBrowserEditString: aString "Create and schedule a new class browser for the current selection, with initial textual contents set to aString. This is used specifically in spawning where a class is established but a method-category is not." | newBrowser | newBrowser := Smalltalk tools browser new. newBrowser setClass: self selectedClassOrMetaClass selector: nil. newBrowser editSelection: #newMessage. Smalltalk tools browser openBrowserView: (newBrowser openOnClassWithEditString: aString) label: 'Class Browser: ', self selectedClassOrMetaClass name ! ! !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: '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: '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: 'contents' stamp: 'sd 11/20/2005 21:27'! commentContents "documentation for the selected method" | poss aClass aSelector | ^ (poss := (aClass := self selectedClassOrMetaClass) ifNil: ['----'] ifNotNil: [(aSelector := self selectedMessageName) ifNil: ['---'] ifNotNil: [(aClass precodeCommentOrInheritedCommentFor: aSelector)", String cr, String cr, self timeStamp" "which however misses comments that are between the temps declaration and the body of the method; those are picked up by ·aClass commentOrInheritedCommentFor: aSelector· but that method will get false positives from comments *anywhere* in the method source"]]) isEmptyOrNil ifTrue: [aSelector ifNotNil: [((aClass methodHeaderFor: aSelector), ' Has no comment') asText makeSelectorBoldIn: aClass] ifNil: ['Hamna']] ifFalse: [aSelector ifNotNil: [((aClass methodHeaderFor: aSelector), ' ', poss) asText makeSelectorBoldIn: aClass] ifNil: [poss]]! ! !CodeHolder methodsFor: 'contents' stamp: 'di 10/1/2001 22:25'! contents "Answer the source code or documentation for the selected method" self showingByteCodes ifTrue: [^ self selectedBytecodes]. self showingDocumentation ifTrue: [^ self commentContents]. ^ self selectedMessage! ! !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: '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: 'contents' stamp: 'gvc 6/21/2010 11:42'! contentsSymbolChanged "Inform any dependents of a change in the contents symbol." self changed: #showingAnyKindOfDiffs; changed: #showingBytecodes; changed: #showingDecompile; changed: #showingDiffs; changed: #showingDocumentation; changed: #showingPlainSource; changed: #showingPrettyDiffs; changed: #showingPrettyPrint; changed: #showingRegularDiffs! ! !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: '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: '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: '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: 'controls' stamp: 'tbn 7/29/2010 22:17'! 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') (documentation toggleShowDocumentation showingDocumentationString 'Documentation' 'The first comment in the method') - (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') - (decompile toggleDecompile showingDecompileString 'Decompile' 'Source code decompiled from byteCodes') (byteCodes toggleShowingByteCodes showingByteCodesString 'ByteCodes' 'The bytecodes that comprise the compiled method'))! ! !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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: 'sw 5/19/2001 00:07'! showingPrettyDiffs "Answer whether the receiver is showing pretty diffs of source code" ^ contentsSymbol == #prettyDiffs ! ! !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: '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: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'! 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: '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: '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: '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: '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: 'diffs' stamp: 'sw 11/13/2001 07:24'! wantsDiffFeedback "Answer whether the receiver is showing diffs of source code" ^ self showingAnyKindOfDiffs! ! !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: 'message list' stamp: 'StephaneDucasse 1/18/2012 19:32'! decompiledSourceIntoContents "Obtain a source string by decompiling the method's code, and place that source string into my contents. Also return the string. Get temps from source file if shift key is pressed." | class | class := self selectedClassOrMetaClass. "Was method deleted while in another project?" currentCompiledMethod := (class compiledMethodAt: self selectedMessageName ifAbsent: [^ '']). contents := (World activeHand shiftPressed not) ifTrue: [[currentCompiledMethod decompileWithTemps] ifError: [currentCompiledMethod decompile]] ifFalse: [currentCompiledMethod decompile]. contents := contents decompileString asText makeSelectorBoldIn: class. ^ contents copy! ! !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: 'message list' stamp: 'md 2/20/2006 15:02'! 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]. self showingDecompile ifTrue:[^ self decompiledSourceIntoContents]. 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 showComment ifFalse: [self sourceStringPrettifiedAndDiffed] ifTrue: [ self commentContents]) copy asText makeSelectorBoldIn: class! ! !CodeHolder methodsFor: 'message list' stamp: 'alain.plantec 5/18/2009 15:44'! 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 prettyPrinterClass format: sourceString in: class notifying: nil]. self showingAnyKindOfDiffs ifTrue: [sourceString := self diffFromPriorSourceFor: sourceString]. ^sourceString! ! !CodeHolder methodsFor: 'message list' stamp: 'CamilloBruni 5/4/2012 21:26'! validateMessageSource: sourceString forSelector: aSelector "Check whether there is evidence that method source is invalid" | sourcesName | (self selectedClass parserClass new 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 list menu' stamp: 'MarcusDenker 7/13/2012 23:51'! 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: #browseAllCallsOn: 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: '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: '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: 'misc' stamp: 'StephaneDucasse 1/13/2010 14:22'! initialExtent ^ 700@500! ! !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: '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: '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: 'alain.plantec 2/6/2009 16:46'! okayToAccept "Answer whether it is okay to accept the receiver's input" self showingDocumentation ifTrue: [self inform: 'Sorry, for the moment you can only submit changes here when you are showing source. Later, you will be able to edit the isolated comment here and save it back, but only if you implement it!!.' translated. ^ false]. 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: '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: 'misc' stamp: 'MarcusDenker 11/26/2009 09:56'! 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]] ifNone: [nil]) ifNotNil: [:aPane | aPane hasUnacceptedEdits ifFalse: [aPane update: #annotation]]! ! !CodeHolder methodsFor: 'misc' stamp: 'stephane.ducasse 10/26/2008 15:13'! refusesToAcceptCode "Answer whether receiver, given its current contentsSymbol, could accept code happily if asked to" ^ (#(byteCodes documentation) includes: self contentsSymbol)! ! !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: '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: 'misc' stamp: 'rbb 3/1/2005 10:31'! 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." | aSelector | incomingSelector ifNotNil: [queryPerformer perform: querySelector with: incomingSelector] ifNil: [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: '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 10/19/1999 08:37'! stepIn: aSystemWindow self updateListsAndCodeIn: aSystemWindow! ! !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: 'self-updating' stamp: 'sw 10/19/1999 14:14'! updateListsAndCodeIn: aWindow super updateListsAndCodeIn: aWindow. self updateCodePaneIfNeeded! ! !CodeHolder methodsFor: 'self-updating' stamp: 'AlainPlantec 12/1/2009 22:36'! wantsStepsIn: aWindow ^ self class smartUpdating! ! !CodeHolder methodsFor: 'setting' stamp: 'AlainPlantec 11/27/2009 09:24'! browseWithPrettyPrint ^ self class browseWithPrettyPrint ! ! !CodeHolder methodsFor: 'setting' stamp: 'AlainPlantec 11/24/2009 16:59'! showAnnotationPane ^ self class showAnnotationPane! ! !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: '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: '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: '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: '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: 'traits' stamp: 'MarcusDenker 10/30/2012 16:40'! spawnHierarchy "Create and schedule a new hierarchy browser on the currently selected class or meta." | newBrowser aSymbol aBehavior messageCatIndex selectedClassOrMetaClass | (selectedClassOrMetaClass := self selectedClassOrMetaClass) ifNil: [^ self]. selectedClassOrMetaClass isTrait ifTrue: [^ self]. newBrowser := HierarchyBrowser new initHierarchyForClass: selectedClassOrMetaClass. ((aSymbol := self selectedMessageName) notNil and: [(Smalltalk tools messageList isPseudoSelector: aSymbol) not]) ifTrue: [aBehavior := selectedClassOrMetaClass. messageCatIndex := aBehavior organization numberOfCategoryOfElement: aSymbol. newBrowser messageCategoryListIndex: messageCatIndex + 1. newBrowser messageListIndex: ((aBehavior organization listAtCategoryNumber: messageCatIndex) indexOf: aSymbol)]. Smalltalk tools browser openBrowserView: (newBrowser openSystemCatEditString: nil) label: newBrowser labelString. newBrowser assureSelectionsShow! ! !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: '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: '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: '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: '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: 'what to show' stamp: 'sw 12/5/2000 11:32'! showComment "Answer whether the receiver should show documentation rather than, say, source code" ^ self contentsSymbol == #documentation ! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/20/2001 09:14'! showDecompile: aBoolean "Set the decompile toggle as indicated" self contentsSymbol: (aBoolean ifFalse: [#source] ifTrue: [#decompile])! ! !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: 'what to show' stamp: 'sw 5/18/2001 18:05'! showingByteCodes "Answer whether the receiver is showing bytecodes" ^ contentsSymbol == #byteCodes! ! !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: 'what to show' stamp: 'sw 5/20/2001 06:52'! showingDecompile "Answer whether the receiver should show decompile rather than, say, source code" ^ self contentsSymbol == #decompile ! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/20/2001 06:50'! showingDecompileString "Answer a string characerizing whether decompilation is showing" ^ (self showingDecompile ifTrue: [''] ifFalse: ['']), 'decompile'! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 12/5/2000 12:12'! showingDocumentation "Answer whether the receiver should show documentation rather than, say, source code" ^ self contentsSymbol == #documentation ! ! !CodeHolder methodsFor: 'what to show' stamp: 'sw 5/18/2001 20:05'! showingDocumentationString "Answer a string characerizing whether documentation is showing" ^ (self showingDocumentation ifTrue: [''] ifFalse: ['']), 'documentation'! ! !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: '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: '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: 'what to show' stamp: 'marcus.denker 9/20/2008 20:31'! toggleDecompile "Toggle the setting of the showingDecompile flag, unless there are unsubmitted edits that the user declines to discard" | wasShowing | self okToChange ifTrue: [wasShowing := self showingDecompile. self showDecompile: wasShowing not. self setContentsToForceRefetch. self contentsChanged] ! ! !CodeHolder methodsFor: 'what to show' stamp: 'marcus.denker 9/20/2008 20:32'! toggleShowDocumentation "Toggle the setting of the showingDocumentation flag, unless there are unsubmitted edits that the user declines to discard" | wasShowing | self okToChange ifTrue: [wasShowing := self showingDocumentation. self showDocumentation: wasShowing not. 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 class instanceVariableNames: ''! !CodeHolder class methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 12/1/2009 22:55'! decorateBrowserButtons ^ DecorateBrowserButtons ifNil: [DecorateBrowserButtons := false]! ! !CodeHolder class methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 12/1/2009 22:55'! decorateBrowserButtons: aBoolean DecorateBrowserButtons := 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/21/2009 22:21'! annotationRequests: aList "see annotationRequests comment" AnnotationRequests := aList! ! !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/21/2009 22:21'! defaultAnnotationInfo "see annotationRequests comment" ^ #(timeStamp messageCategory sendersCount implementorsCount allChangeSets)! ! !CodeHolder class methodsFor: 'settings' stamp: 'AlainPlantec 12/1/2009 21:50'! diffsInChangeList ^ DiffsInChangeList ifNil: [DiffsInChangeList := true]! ! !CodeHolder class methodsFor: 'settings' stamp: 'AlainPlantec 12/1/2009 21:51'! diffsInChangeList: aBoolean DiffsInChangeList := 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 21:58'! diffsWithPrettyPrint: aBoolean DiffsWithPrettyPrint := aBoolean! ! !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:45'! optionalButtons: aBoolean OptionalButtons := 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 11/24/2009 17:01'! showAnnotationPane: aBoolean ShowAnnotationPane := aBoolean! ! !CodeHolder class methodsFor: 'settings' stamp: 'AlainPlantec 12/1/2009 22:34'! smartUpdating ^ SmartUpdating ifNil: [SmartUpdating := true]! ! !CodeHolder class methodsFor: 'settings' stamp: 'AlainPlantec 12/1/2009 22:34'! smartUpdating: aBoolean SmartUpdating := aBoolean! ! Object subclass: #CodeHolderSystemSettings instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Settings-Tools'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CodeHolderSystemSettings class instanceVariableNames: ''! !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: 'AlainPlantec 2/11/2011 21:55'! 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: #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. ] ! ! Object subclass: #CodeImporter instanceVariableNames: 'readStream codeDeclarations parserClass' classVariableNames: '' poolDictionaries: '' category: 'CodeImport'! !CodeImporter commentStamp: '' prior: 0! 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: '*System-CommandLine' stamp: 'CamilloBruni 6/14/2012 23:26'! evaluate " stripped down version of evaluateDeclarations" | value | self codeDeclarations do: [ :decl | value := decl import ]. 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'! file: aFileStream self readStream: aFileStream. self selectTextConverterForCode.! ! !CodeImporter methodsFor: 'accessing' stamp: 'GuillermoPolito 5/5/2012 01:39'! readStream: aReadStream readStream := aReadStream.! ! !CodeImporter methodsFor: 'evaluating' stamp: 'GuillermoPolito 5/5/2012 16:45'! evaluateDeclarations "Evaluates the declarations from the text in the file and answers the last result" | value | self parseDeclarations. self codeDeclarations do: [ :decl | value := decl import ]. self flushChangesFile. ^value! ! !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: 'evaluating' stamp: 'GuillermoPolito 5/5/2012 17:17'! parseDeclarations codeDeclarations := (parserClass for: readStream) parseDeclarations.! ! !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: 'initialize-release' stamp: 'GuillermoPolito 5/5/2012 17:06'! initialize codeDeclarations := OrderedCollection new. parserClass := ChunkFileFormatParser.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CodeImporter class instanceVariableNames: ''! !CodeImporter class methodsFor: 'evaluating' stamp: 'GuillermoPolito 5/5/2012 17:23'! evaluateFileNamed: aFileName ^(self fileNamed: aFileName) evaluateDeclarations! ! !CodeImporter class methodsFor: 'evaluating' stamp: 'GuillermoPolito 5/5/2012 17:23'! evaluateFileStream: aFileStream ^(self fileStream: aFileStream) evaluateDeclarations! ! !CodeImporter class methodsFor: 'evaluating' stamp: 'GuillermoPolito 5/5/2012 17:25'! evaluateReadStream: aReadStream ^(self readStream: aReadStream) evaluateDeclarations! ! !CodeImporter class methodsFor: 'evaluating' stamp: 'GuillermoPolito 5/5/2012 17:25'! evaluateString: aString ^(self fromString: aString) evaluateDeclarations! ! !CodeImporter class methodsFor: 'instance creation' stamp: 'GuillermoPolito 5/5/2012 17:23'! fileNamed: aFileName ^self file: (FileStream readOnlyFileNamed: aFileName). ! ! !CodeImporter class methodsFor: 'instance creation' stamp: 'GuillermoPolito 5/5/2012 17:23'! fileStream: aFileStream ^self new file: aFileStream; yourself! ! !CodeImporter class methodsFor: 'instance creation' stamp: 'GuillermoPolito 5/5/2012 17:25'! fromString: aByteString ^self readStream: aByteString readStream! ! !CodeImporter class methodsFor: 'instance creation' stamp: 'GuillermoPolito 5/5/2012 17:24'! readStream: aReadStream ^self new readStream: aReadStream; yourself! ! TestCase subclass: #CodeSimulationTests instanceVariableNames: '' classVariableNames: 'log' poolDictionaries: '' category: 'KernelTests-Methods'! !CodeSimulationTests methodsFor: 'tests' stamp: 'dik 5/23/2010 18:00'! methodWithError self error: 'my error'! ! !CodeSimulationTests methodsFor: 'tests' stamp: 'dik 5/23/2010 17:58'! methodWithHalt self halt! ! !CodeSimulationTests methodsFor: 'tests' stamp: 'dik 5/23/2010 18:09'! methodWithSourceGetting | node | node := [:some | some + 3] decompile. self assert: node notNil description: 'getting source failed'! ! !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:39'! testDNU self should: [ self runSimulated: [self absentMethod] ] raise: MessageNotUnderstood! ! !CodeSimulationTests methodsFor: 'tests' stamp: 'ToonVerwaest 6/8/2010 00:35'! testError self should: [ self runSimulated: [self methodWithError] ] raise: Error! ! !CodeSimulationTests methodsFor: 'tests' stamp: 'ToonVerwaest 6/7/2010 22:30'! testErrorWithErrorHandler self runSimulated: [[self methodWithError] on: Error do: [:err | ]] ! ! !CodeSimulationTests methodsFor: 'tests' stamp: 'ToonVerwaest 6/7/2010 22:30'! testGettingSourceFromFile self runSimulated: [self methodWithSourceGetting] ! ! !CodeSimulationTests methodsFor: 'tests' stamp: 'ToonVerwaest 6/7/2010 22:30'! testGoodSimulation self runSimulated: [ 1 + 2 ].! ! !CodeSimulationTests methodsFor: 'tests' stamp: 'ToonVerwaest 6/8/2010 00:35'! testHalt self should: [ self runSimulated: [self methodWithHalt] ] raise: Halt! ! !CodeSimulationTests methodsFor: 'tests' stamp: 'ToonVerwaest 6/7/2010 22:30'! testHaltWithHaltHandler self runSimulated: [[self methodWithHalt] on: Halt do: [:err |]] ! ! !CodeSimulationTests methodsFor: 'tests' stamp: 'ToonVerwaest 6/7/2010 22:30'! testTranscriptPrinting self runSimulated: [self methodWithTranscript] ! ! !CodeSimulationTests methodsFor: 'tests' stamp: 'ToonVerwaest 6/7/2010 22:30'! testTranscriptPrintingWithOpenedTranscriptExists self runSimulated: [self methodWithTranscript] ! ! !CodeSimulationTests methodsFor: 'tests - primitives'! 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 - primitives'! 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 - primitives'! 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: 'private'! indexedBasicAt: index ^ code ! ! !CodeSimulationTests methodsFor: 'private'! veryBasicAt: index ^ code ! ! SystemWindow subclass: #CollapsedMorph instanceVariableNames: 'uncollapsedMorph' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Windows'! !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: '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! ! !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: '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: 'resize/collapse' stamp: 'sw 6/5/2001 22:55'! wantsExpandBox "Answer whether I'd like an expand box" ^ false! ! AbstractEnumerationVisitor subclass: #CollectVisitor instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Core-Implementation'! !CollectVisitor commentStamp: 'cwp 11/18/2009 12:32' prior: 0! 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 instanceVariableNames: ''! !CollectVisitor class methodsFor: 'instance creation' stamp: 'cwp 11/16/2009 10:33'! breadthFirst: aReference ^ self breadthFirst: 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: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:35'! postorder: aReference collect: aBlock ^ (self collect: aBlock) postorder: aReference! ! !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:36'! preorder: aReference collect: aBlock ^ (self collect: aBlock) preorder: aReference! ! AbstractEnumerationVisitorTest subclass: #CollectVisitorTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Tests-Core'! !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'! 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'! 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' )! ! Object subclass: #Collection instanceVariableNames: '' classVariableNames: 'MutexForPicking RandomForPicking' poolDictionaries: '' category: 'Collections-Abstract'! !Collection commentStamp: '' prior: 0! I am the abstract superclass of all classes that represent a group of elements.! !Collection methodsFor: '*CI-Core' stamp: 'Integrator 6/21/2012 17:59'! do: aBlock inParallel: threadCount "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." | addSyncronization finishSync threadBlock | finishSync := Semaphore forMutualExclusion. threadBlock := Semaphore new. (threadCount max: 1) timesRepeat: [ threadBlock signal ]. self do: [:each | threadBlock wait. [ aBlock value: each. finishSync signal. threadBlock signal] fork]. "consume all signals" self size timesRepeat: [ finishSync wait ]. ^ self! ! !Collection methodsFor: '*CI-Core' stamp: 'Integrator 6/21/2012 17:59'! doWithIndex: aBlock inParallel: threadCount "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." | addSyncronization finishSync threadBlock | finishSync := Semaphore forMutualExclusion. threadBlock := Semaphore new. (threadCount max: 1) timesRepeat: [ threadBlock signal ]. self doWithIndex: [:each :index | threadBlock wait. [ aBlock value: each value: index. finishSync signal. threadBlock signal] fork]. "consume all signals" self size timesRepeat: [ finishSync wait ]. ^ self! ! !Collection methodsFor: '*CI-Core' stamp: 'Integrator 6/21/2012 17:59'! select: aBlock inParallel: threadCount "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." | addSyncronization finishSync threadBlock count addCount results| finishSync := Semaphore forMutualExclusion. threadBlock := Semaphore new. (threadCount max: 1) timesRepeat: [ threadBlock signal ]. count := 0. addCount := 1. results := Array new: self size. ^ self class streamContents: [ :stream| self do: [:each | |blockCount| threadBlock wait. count := count + 1. blockCount := count. [(aBlock value: each) ifTrue: [ stream nextPut: each]. finishSync signal. threadBlock signal] fork]. "consume all signals" count timesRepeat: [ finishSync wait ]]! ! !Collection methodsFor: '*Collections-arithmetic' stamp: 'G.C 10/23/2008 10:12'! * arg ^ arg adaptToCollection: self andSend: #*! ! !Collection methodsFor: '*Collections-arithmetic' stamp: 'di 11/6/1998 13:53'! + arg ^ arg adaptToCollection: self andSend: #+! ! !Collection methodsFor: '*Collections-arithmetic' stamp: 'di 11/6/1998 13:53'! - arg ^ arg adaptToCollection: self andSend: #-! ! !Collection methodsFor: '*Collections-arithmetic' stamp: 'di 11/6/1998 13:53'! / arg ^ arg adaptToCollection: self andSend: #/! ! !Collection methodsFor: '*Collections-arithmetic' stamp: 'di 11/6/1998 13:54'! // arg ^ arg adaptToCollection: self andSend: #//! ! !Collection methodsFor: '*Collections-arithmetic' stamp: 'di 11/6/1998 13:54'! \\ arg ^ arg adaptToCollection: self andSend: #\\! ! !Collection methodsFor: '*Collections-arithmetic' stamp: 'TAG 11/6/1998 15:57'! average ^ self sum / self size! ! !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' stamp: 'TAG 11/6/1998 16:00'! min ^ self inject: self anyOne into: [:min :each | min min: each]! ! !Collection methodsFor: '*Collections-arithmetic' stamp: 'raok 10/22/2002 00:17'! raisedTo: arg ^ arg adaptToCollection: self andSend: #raisedTo:! ! !Collection methodsFor: '*Collections-arithmetic' stamp: 'TAG 11/6/1998 16:00'! range ^ self max - self min! ! !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: '*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: '*Collections-arithmetic-collectors' stamp: 'raok 10/22/2002 00:20'! arcCos ^self collect: [:each | each arcCos]! ! !Collection methodsFor: '*Collections-arithmetic-collectors' stamp: 'raok 10/22/2002 00:20'! arcSin ^self collect: [:each | each arcSin]! ! !Collection methodsFor: '*Collections-arithmetic-collectors' stamp: 'raok 10/22/2002 00:20'! arcTan ^self collect: [:each | each arcTan]! ! !Collection methodsFor: '*Collections-arithmetic-collectors' stamp: 'TAG 11/6/1998 15:51'! ceiling ^ self collect: [:a | a ceiling]! ! !Collection methodsFor: '*Collections-arithmetic-collectors' stamp: 'raok 10/22/2002 00:20'! cos ^self collect: [:each | each cos]! ! !Collection methodsFor: '*Collections-arithmetic-collectors' stamp: 'raok 10/22/2002 00:20'! degreeCos ^self collect: [:each | each degreeCos]! ! !Collection methodsFor: '*Collections-arithmetic-collectors' stamp: 'raok 10/22/2002 00:21'! degreeSin ^self collect: [:each | each degreeSin]! ! !Collection methodsFor: '*Collections-arithmetic-collectors' stamp: 'raok 10/22/2002 00:21'! exp ^self collect: [:each | each exp]! ! !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:21'! ln ^self collect: [:each | each ln]! ! !Collection methodsFor: '*Collections-arithmetic-collectors' stamp: 'TAG 11/6/1998 15:52'! log ^ self collect: [:each | each log]! ! !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: '*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: '*Collections-arithmetic-collectors' stamp: 'nk 12/30/2003 15:47'! roundTo: quantum ^self collect: [ :ea | ea roundTo: quantum ]! ! !Collection methodsFor: '*Collections-arithmetic-collectors' stamp: 'TAG 11/6/1998 15:53'! rounded ^ self collect: [:a | a rounded]! ! !Collection methodsFor: '*Collections-arithmetic-collectors' stamp: 'raok 10/22/2002 00:23'! sign ^self collect: [:each | each sign]! ! !Collection methodsFor: '*Collections-arithmetic-collectors' stamp: 'raok 10/22/2002 00:22'! sin ^self collect: [:each | each sin]! ! !Collection methodsFor: '*Collections-arithmetic-collectors' stamp: 'TAG 11/6/1998 15:53'! sqrt ^ self collect: [:each | each sqrt]! ! !Collection methodsFor: '*Collections-arithmetic-collectors' stamp: 'TAG 11/6/1998 15:53'! squared ^ self collect: [:each | each * each]! ! !Collection methodsFor: '*Collections-arithmetic-collectors' stamp: 'raok 10/22/2002 00:22'! tan ^self collect: [:each | each tan]! ! !Collection methodsFor: '*Collections-arithmetic-collectors' stamp: 'TAG 11/6/1998 15:54'! truncated ^ self collect: [:a | a truncated]! ! !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: '*Morphic-Basic' stamp: 'CamilloBruni 10/21/2012 23:39'! asDraggableMorph ^ (String streamContents: [ :s| self do: [ :each | s print: each ] separatedBy: [ s space ]]) asStringMorph! ! !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: '*Tools-Explorer' stamp: 'yo 8/27/2008 23:29'! explorerContentsWithIndexCollect: twoArgBlock ^ self asOrderedCollection withIndexCollect: twoArgBlock ! ! !Collection methodsFor: '*keymapping-shortcuts' stamp: 'GuillermoPolito 11/2/2011 22:33'! asShortcut | shortcut | self size = 1 ifTrue: [ ^self first asShortcut ]. shortcut := KMChainedShortcut new. self do: [ :each | shortcut addShortcut: each asShortcut ]. ^shortcut.! ! !Collection methodsFor: '*metacello-core' stamp: 'dkh 6/6/2009 11:45'! addToMetacelloPackages: aMetacelloPackagesSpec self do: [:each | each addToMetacelloPackages: aMetacelloPackagesSpec ] ! ! !Collection methodsFor: '*metacello-core' stamp: 'dkh 9/6/2012 10:03:17'! asMetacelloAttributeList ^ self! ! !Collection methodsFor: '*metacello-core' stamp: 'dkh 9/6/2012 10:03:17'! asMetacelloAttributePath ^ MetacelloMethodSectionPath withAll: self! ! !Collection methodsFor: '*metacello-core' stamp: 'dkh 6/6/2009 11:46'! mergeIntoMetacelloPackages: aMetacelloPackagesSpec self do: [:each | each mergeIntoMetacelloPackages: aMetacelloPackagesSpec ] ! ! !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/6/2012 07:42'! setForDo: aBlock withInMetacelloConfig: aMetacelloConstructore aMetacelloConstructore setFor: self do: aBlock! ! !Collection methodsFor: '*metacello-core' stamp: 'dkh 9/6/2012 07:43'! setForVersion: aString withInMetacelloConfig: aMetacelloConstructore aMetacelloConstructore setFor: self version: aString! ! !Collection methodsFor: '*metacello-core' stamp: 'dkh 9/23/2009 08:46'! setIncludesInMetacelloPackage: aMetacelloPackageSpec aMetacelloPackageSpec setIncludes: self asArray.! ! !Collection methodsFor: '*metacello-core' stamp: 'dkh 6/8/2009 19:02'! setLoadsInMetacelloProject: aMetacelloPackageSpec aMetacelloPackageSpec setLoads: self asArray.! ! !Collection methodsFor: '*metacello-core' stamp: 'dkh 6/6/2009 10:08'! setRequiresInMetacelloPackage: aMetacelloPackageSpec aMetacelloPackageSpec setRequires: self asArray.! ! !Collection methodsFor: '*metacello-mc' stamp: 'dkh 6/7/2009 10:16'! addToMetacelloRepositories: aMetacelloRepositoriesSpec self do: [:each | each addToMetacelloRepositories: aMetacelloRepositoriesSpec ] ! ! !Collection methodsFor: '*metacello-mc' stamp: 'DaleHenrichs 3/7/2010 08:26'! fetchRequiredForMetacelloMCVersion: aMetacelloMCVersion ^aMetacelloMCVersion doFetchRequiredFromArray: self.! ! !Collection methodsFor: '*metacello-mc' stamp: 'DaleHenrichs 3/4/2010 15:37'! loadRequiredForMetacelloMCVersion: aMetacelloMCVersion ^aMetacelloMCVersion doLoadRequiredFromArray: self.! ! !Collection methodsFor: '*metacello-mc' stamp: 'dkh 6/7/2009 10:19'! mergeIntoMetacelloRepositories: aMetacelloRepositoriesSpec self do: [:each | each mergeIntoMetacelloRepositories: aMetacelloRepositoriesSpec ] ! ! !Collection methodsFor: '*metacello-mc' stamp: 'DaleHenrichs 3/11/2010 10:06'! recordRequiredForMetacelloMCVersion: aMetacelloMCVersion ^aMetacelloMCVersion doRecordRequiredFromArray: self.! ! !Collection methodsFor: '*metacello-mc' stamp: 'dkh 6/7/2009 10:23'! removeFromMetacelloRepositories: aMetacelloRepositoriesSpec self do: [:each | each removeFromMetacelloRepositories: aMetacelloRepositoriesSpec ] ! ! !Collection methodsFor: '*metacello-mc' stamp: 'dkh 10/21/2009 19:18'! resolvePackageSpecsNamedForMetacelloMCVersion: aMetacelloMCVersion visited: visited ifAbsent: aBlock ^ aMetacelloMCVersion allPackagesForSpecs: (self collect: [:ea | aMetacelloMCVersion spec packageNamed: ea ifAbsent: aBlock]) visited: visited! ! !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: '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: '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: 'accessing' stamp: 'sma 5/12/2000 11:41'! capacity "Answer the current capacity of the receiver." ^ self size! ! !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: 'adapting' stamp: 'di 11/6/1998 13:34'! 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 & 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: '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: '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: '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: 'adding'! add: newObject "Include newObject as one of the receiver's elements. Answer newObject. ArrayedCollections cannot respond to this message." self subclassResponsibility! ! !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: '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: '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: '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: '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: '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: '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: '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: 'converting' stamp: 'MarcusDenker 11/28/2009 11:40'! asDictionary ^ self as: Dictionary! ! !Collection methodsFor: 'converting' stamp: 'ar 9/22/2000 10:12'! asIdentitySet ^(IdentitySet new: self size) addAll: self; yourself! ! !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: '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: '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: '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: 'copying' stamp: 'al 12/12/2003 14:31'! , aCollection ^self copy addAll: aCollection; yourself! ! !Collection methodsFor: 'copying' stamp: 'CamilloBruni 10/20/2012 21:49'! copyEmpty ^ self species new! ! !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: '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: '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: '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: 'enumerating' stamp: 'CamilloBruni 9/7/2011 19:23'! & aCollection ^ self intersection: aCollection! ! !Collection methodsFor: 'enumerating' stamp: 'CamilloBruni 9/7/2011 19:24'! \ aCollection ^ self difference: aCollection! ! !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: '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: 'enumerating'! 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: '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: '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: '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: 'dgd 9/13/2004 23:42'! collect: collectBlock thenDo: doBlock "Utility method to improve readability." ^ (self collect: collectBlock) do: doBlock! ! !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 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: '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: 'enumerating' stamp: 'sma 5/12/2000 11:52'! 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! ! !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: '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'! 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: 'enumerating' stamp: 'TudorGirba 3/20/2012 09:07'! difference: aCollection "Answer the set theoretic difference of two collections." | set| set := self asSet. aCollection do: [ :each| set remove: each ifAbsent: []]. ^ self species withAll: set asArray! ! !Collection methodsFor: 'enumerating'! do: aBlock "Evaluate aBlock with each of the receiver's elements as the argument." self subclassResponsibility! ! !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 8/7/2012 13:27'! 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. [ :item | 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: [ProgressNotification signal: '' extra: (oldLabel := newLabel)]. lastUpdate := Time millisecondClockValue ]. aBlock value: each. count := count + 1]]! ! !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 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: '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: '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: 'enumerating' stamp: 'ab 9/30/2002 19:26'! gather: aBlock ^ Array streamContents: [:stream | self do: [:ea | stream nextPutAll: (aBlock value: ea)]]! ! !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: '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: '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: 'enumerating'! 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: '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: '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: 'StephaneDucasse 5/20/2012 18:50'! 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: '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: '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'! 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: 'enumerating' stamp: 'dgd 9/13/2004 23:42'! reject: rejectBlock thenDo: doBlock "Utility method to improve readability." ^ (self reject: rejectBlock) do: doBlock! ! !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: 'sma 5/12/2000 11:59'! select: selectBlock thenCollect: collectBlock "Utility method to improve readability." ^ (self select: selectBlock) collect: collectBlock! ! !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: 'enumerating' stamp: 'CamilloBruni 10/20/2012 18:12'! 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 ]! ! !Collection methodsFor: 'enumerating' 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: '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: 'enumerating' stamp: 'CamilloBruni 9/7/2011 19:24'! | aCollection ^ self union: aCollection! ! !Collection methodsFor: 'filter streaming' stamp: 'sma 5/12/2000 12:07'! contents ^ self! ! !Collection methodsFor: 'filter streaming' stamp: 'sma 5/12/2000 12:07'! write: anObject ^ self add: anObject! ! !Collection methodsFor: 'math functions' stamp: 'TAG 11/6/1998 16:00'! median ^ self asSortedCollection median! ! !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: '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: '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: '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: '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: '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: '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: 'printing' stamp: 'sma 6/1/2000 09:41'! printNameOn: aStream super printOn: aStream! ! !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: '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: '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: 'printing'! 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: '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: '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: '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: '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: '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: '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'! contains: aBlock "VW compatibility" ^self anySatisfy: aBlock! ! !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: '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: '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: '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: '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: '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: '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: '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: '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: '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: 'testing' stamp: 'CamilloBruni 9/8/2011 14:20'! includesAllOf: aCollection self flag: 'use includesAll instead'. ^ self includesAll: aCollection.! ! !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: 'testing' stamp: 'CamilloBruni 9/8/2011 14:20'! includesAnyOf: aCollection self flag: 'use includesAny: instead'. ^ self includesAny: aCollection. ! ! !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: '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: 'testing'! isEmpty "Answer whether the receiver contains any elements." ^self size = 0! ! !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: 'testing' stamp: 'di 11/6/1998 09:16'! isSequenceable ^ false! ! !Collection methodsFor: 'testing' stamp: 'sma 5/12/2000 17:49'! notEmpty "Answer whether the receiver contains any elements." ^ self isEmpty not! ! !Collection methodsFor: 'testing'! 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: 'private'! emptyCheck self isEmpty ifTrue: [self errorEmptyCollection]! ! !Collection methodsFor: 'private' stamp: 'SvenVanCaekenberghe 4/18/2011 14:59'! errorEmptyCollection "Signal a CollectionIsEmpty exception" CollectionIsEmpty signalWith: self! ! !Collection methodsFor: 'private' stamp: 'SvenVanCaekenberghe 4/18/2011 14:58'! errorNoMatch "Signal a SizeMismatch exception" SizeMismatch signal! ! !Collection methodsFor: 'private' stamp: 'SvenVanCaekenberghe 4/18/2011 14:37'! errorNotFound: anObject "Raise a NotFound exception." NotFound signalFor: anObject! ! !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: '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: 'private'! 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 class instanceVariableNames: ''! !Collection class methodsFor: '*Nautilus' stamp: 'BenjaminVanRyseghem 1/2/2013 12:07'! nautilusIcon ^ self nautilusIconClass iconNamed: #collection! ! !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: '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! ! !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 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: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: '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: '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: 'lr 11/4/2003 12:08'! mutexForPicking ^ MutexForPicking! ! !Collection class methodsFor: 'private' stamp: 'sma 5/12/2000 12:31'! randomForPicking ^ RandomForPicking! ! Object subclass: #CollectionCombinator instanceVariableNames: 'resultProcessingBlock collectionOfArrays buffer' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Methods'! !CollectionCombinator commentStamp: '' prior: 0! 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: 'as yet unclassified' 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. "! ! !CollectionCombinator methodsFor: 'as yet unclassified' 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 ! ! Error subclass: #CollectionIsEmpty instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Abstract'! !CollectionIsEmpty commentStamp: 'SvenVanCaekenberghe 4/18/2011 14:53' prior: 0! 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: '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 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 class instanceVariableNames: ''! !CollectionIsEmpty class methodsFor: 'instance creation' stamp: 'SvenVanCaekenberghe 4/18/2011 14:53'! signalWith: aCollection ^ self new collection: aCollection; signal! ! ClassTestCase subclass: #CollectionRootTest uses: TIterateTest + TEmptyTest + TSizeTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Abstract'! !CollectionRootTest commentStamp: 'stephane.ducasse 1/12/2009 17:41' prior: 0! I'm the root of the hierarchy of the collection tests. ! !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: 'requirements' stamp: 'damienpollet 1/30/2009 17:20'! doWithoutNumber ^ 2! ! !CollectionRootTest methodsFor: 'requirements' stamp: 'damienpollet 1/30/2009 17:32'! element ^ 3! ! !CollectionRootTest methodsFor: 'requirements' stamp: 'damienpollet 1/30/2009 17:14'! elementTwiceIn ^ 1 "12332312322"! ! !CollectionRootTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 10:36'! empty self subclassResponsibility! ! !CollectionRootTest methodsFor: 'requirements' stamp: 'damienpollet 1/21/2009 18:25'! expectedElementByDetect ^ -2! ! !CollectionRootTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 10:35'! nonEmpty self subclassResponsibility! ! !CollectionRootTest methodsFor: 'requirements'! sizeCollection "Answers a collection not empty" ^ self explicitRequirement! ! !CollectionRootTest methodsFor: 'test - fixture'! test0FixtureIterateTest | res | self shouldnt: [ self collectionWithoutNilElements ] raise: Error. 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 - empty'! testIfEmpty self nonEmpty ifEmpty: [ self assert: false] . self empty ifEmpty: [ self assert: true] . ! ! !CollectionRootTest methodsFor: 'tests - empty'! testIfEmptyifNotEmpty self assert: (self empty ifEmpty: [true] ifNotEmpty: [false]). self assert: (self nonEmpty ifEmpty: [false] ifNotEmpty: [true]). ! ! !CollectionRootTest methodsFor: 'tests - empty'! testIfEmptyifNotEmptyDo "self debug #testIfEmptyifNotEmptyDo" self assert: (self empty ifEmpty: [true] ifNotEmptyDo: [:s | false]). self assert: (self nonEmpty ifEmpty: [false] ifNotEmptyDo: [:s | true]). self assert: (self nonEmpty ifEmpty: [false] ifNotEmptyDo: [:s | s]) == self nonEmpty.! ! !CollectionRootTest methodsFor: 'tests - empty'! testIfNotEmpty self empty ifNotEmpty: [self assert: false]. self nonEmpty ifNotEmpty: [self assert: true]. self assert: (self nonEmpty ifNotEmpty: [:s | s ]) = self nonEmpty ! ! !CollectionRootTest methodsFor: 'tests - empty'! testIfNotEmptyDo self empty ifNotEmptyDo: [:s | self assert: false]. self assert: (self nonEmpty ifNotEmptyDo: [:s | s]) == self nonEmpty ! ! !CollectionRootTest methodsFor: 'tests - empty'! testIfNotEmptyDoifNotEmpty self assert: (self empty ifNotEmptyDo: [:s | false] ifEmpty: [true]). self assert: (self nonEmpty ifNotEmptyDo: [:s | s] ifEmpty: [false]) == self nonEmpty! ! !CollectionRootTest methodsFor: 'tests - empty'! testIfNotEmptyifEmpty self assert: (self empty ifNotEmpty: [false] ifEmpty: [true]). self assert: (self nonEmpty ifNotEmpty: [true] ifEmpty: [false]). ! ! !CollectionRootTest methodsFor: 'tests - empty'! testIsEmpty self assert: (self empty isEmpty). self deny: (self nonEmpty isEmpty).! ! !CollectionRootTest methodsFor: 'tests - empty'! testIsEmptyOrNil self assert: (self empty isEmptyOrNil). self deny: (self nonEmpty isEmptyOrNil).! ! !CollectionRootTest methodsFor: 'tests - empty'! testNotEmpty self assert: (self nonEmpty notEmpty). self deny: (self empty notEmpty).! ! !CollectionRootTest methodsFor: 'tests - fixture'! test0FixtureEmptyTest self shouldnt: [ self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self empty ] raise: Error. self assert: self empty isEmpty.! ! !CollectionRootTest methodsFor: 'tests - fixture'! test0TSizeTest self shouldnt: [self empty] raise: Error. self shouldnt: [self sizeCollection] raise: Error. self assert: self empty isEmpty. self deny: self sizeCollection isEmpty.! ! !CollectionRootTest methodsFor: 'tests - iterate' stamp: 'delaunay 5/14/2009 11:03'! 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 - 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 - iterating'! 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: 'tests - iterating'! testAllSatisfyEmpty self assert: ( self empty allSatisfy: [:each | false]). ! ! !CollectionRootTest methodsFor: 'tests - iterating'! 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'! 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 = self collectionWithoutNilElements size. ! ! !CollectionRootTest methodsFor: 'tests - iterating'! testBasicCollectEmpty | res | res := self empty collect: [:each | each class]. self assert: res isEmpty ! ! !CollectionRootTest methodsFor: 'tests - iterating'! testCollectOnEmpty self assert: (self empty collect: [:e | self fail]) isEmpty! ! !CollectionRootTest methodsFor: 'tests - iterating'! testCollectThenSelectOnEmpty self assert: (self empty collect: [:e | self fail] thenSelect: [:e | self fail]) isEmpty! ! !CollectionRootTest methodsFor: 'tests - iterating'! testDetect | res element | element := self collectionWithoutNilElements anyOne . res := self collectionWithoutNilElements detect: [:each | each = element]. self assert: (res = element). ! ! !CollectionRootTest methodsFor: 'tests - iterating'! 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: 'tests - iterating'! 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 - iterating'! 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: 'tests - iterating'! 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'! 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'! testNoneSatisfyEmpty self assert: ( self empty noneSatisfy: [:each | false]). ! ! !CollectionRootTest methodsFor: 'tests - iterating'! 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: 'tests - iterating'! testRejectEmpty | res | res := self empty reject: [:each | each odd]. self assert: res size = self empty size ! ! !CollectionRootTest methodsFor: 'tests - iterating'! testSelect | res element | res := self collectionWithoutNilElements select: [:each | each notNil]. self assert: res size = self collectionWithoutNilElements size. element := self collectionWithoutNilElements anyOne. res := self collectionWithoutNilElements select: [:each | (each = element) not]. self assert: res size = (self collectionWithoutNilElements size - 1). ! ! !CollectionRootTest methodsFor: 'tests - iterating'! testSelectOnEmpty self assert: (self empty select: [:e | self fail]) isEmpty ! ! !CollectionRootTest methodsFor: 'tests - size capacity'! testSize | size | self assert: self empty size = 0. size := 0. self sizeCollection do: [ :each | size := size + 1]. self assert: self sizeCollection size = size.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CollectionRootTest class instanceVariableNames: ''! !CollectionRootTest class methodsFor: 'as yet unclassified' stamp: 'damienpollet 1/13/2009 15:28'! isAbstract ^ self name = #CollectionRootTest! ! NewValueHolder subclass: #CollectionValueHolder instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Spec-Core'! !CollectionValueHolder commentStamp: '' prior: 0! A CollectionValueHolder is s a value holder designed for collections! !CollectionValueHolder methodsFor: 'override' stamp: 'BenjaminVanRyseghem 11/27/2012 01:06'! at: anObject ^ contents at: anObject! ! !CollectionValueHolder methodsFor: 'override' stamp: 'BenjaminVanRyseghem 11/27/2012 01:30'! at: key put: value contents at: key put: value. self contentsChanged: value! ! !CollectionValueHolder methodsFor: 'override'! size ^ contents size! ! !CollectionValueHolder methodsFor: 'protocol'! add: newObject | result | result := contents add: newObject. self contentsChanged: newObject. ^ result! ! !CollectionValueHolder methodsFor: 'protocol'! add: newObject after: oldObject | result | result := contents add: newObject after: oldObject. self contentsChanged: newObject. ^ result! ! !CollectionValueHolder methodsFor: 'protocol'! add: newObject afterIndex: index | result | result := contents add: newObject afterIndex: index. self contentsChanged: newObject. ^ result! ! !CollectionValueHolder methodsFor: 'protocol'! add: newObject before: oldObject | result | result := contents add: newObject before: oldObject. self contentsChanged: newObject. ^ result! ! !CollectionValueHolder methodsFor: 'protocol'! add: newObject beforeIndex: index | result | result := contents add: newObject beforeIndex: index. self contentsChanged: newObject. ^ result! ! !CollectionValueHolder methodsFor: 'protocol'! addAll: aCollection | result | result := contents addAll: aCollection. self contentsChanged: aCollection. ^ result! ! !CollectionValueHolder methodsFor: 'protocol'! addAllFirst: anOrderedCollection | result | result := contents addAllFirst: anOrderedCollection. self contentsChanged: anOrderedCollection. ^ result! ! !CollectionValueHolder methodsFor: 'protocol'! addAllFirstUnlessAlreadyPresent: anOrderedCollection | result | result := contents addAllFirstUnlessAlreadyPresent: anOrderedCollection. self contentsChanged: anOrderedCollection. ^ result! ! !CollectionValueHolder methodsFor: 'protocol'! addAllLast: aCollection | result | result := contents addAllLast: aCollection. self contentsChanged: aCollection. ^ result! ! !CollectionValueHolder methodsFor: 'protocol'! addFirst: newObject | result | result := contents addFirst: newObject . self contentsChanged: newObject. ^ result! ! !CollectionValueHolder methodsFor: 'protocol'! addLast: newObject | result | result := contents addLast: newObject . self contentsChanged: newObject. ^ result! ! !CollectionValueHolder methodsFor: 'protocol'! at: index ifAbsentPut: block | result | result := contents at: index ifAbsentPut: block. self contentsChanged: block value. ^ result! ! !CollectionValueHolder methodsFor: 'protocol'! atAll: aCollection put: anObject | result | result := contents atAll: aCollection put: anObject . self contentsChanged: anObject. ^ result! ! !CollectionValueHolder methodsFor: 'protocol'! atAll: indexArray putAll: valueArray | result | result := contents atAll: indexArray putAll: valueArray. self contentsChanged: valueArray. ^ result! ! !CollectionValueHolder methodsFor: 'protocol'! atAllPut: anObject | result | result := contents atAllPut: anObject. self contentsChanged: anObject. ^ result! ! !CollectionValueHolder methodsFor: 'protocol'! atLast: indexFromEnd put: obj | result | result := contents atLast: indexFromEnd put: obj. self contentsChanged: obj. ^ result! ! !CollectionValueHolder methodsFor: 'protocol'! atWrap: index put: value | result | result := contents atWrap: index put: value. self contentsChanged: value. ^ result! ! !CollectionValueHolder methodsFor: 'protocol'! insert: anObject before: spot | result | result := contents insert: anObject before: spot. self contentsChanged: anObject. ^ result! ! !CollectionValueHolder methodsFor: 'protocol'! remove: oldObject ifAbsent: absentBlock | result | result := contents remove: oldObject ifAbsent: absentBlock. self contentsChanged: oldObject. ^ result! ! !CollectionValueHolder methodsFor: 'protocol'! removeAll contents removeAll. self contentsChanged! ! !CollectionValueHolder methodsFor: 'protocol'! removeAt: index | result | result := contents removeAt: index. self contentsChanged: result. ^ result! ! !CollectionValueHolder methodsFor: 'protocol'! removeFirst | result | result := contents removeFirst. self contentsChanged: result. ^ result! ! !CollectionValueHolder methodsFor: 'protocol'! removeFirst: n | result | result := contents removeFirst: n . self contentsChanged: result. ^ result! ! !CollectionValueHolder methodsFor: 'protocol'! removeIndex: removedIndex | result | result := contents removeIndex: removedIndex. self contentsChanged: result. ^ result! ! !CollectionValueHolder methodsFor: 'protocol'! removeLast | result | result := contents removeLast. self contentsChanged: result. ^ result! ! !CollectionValueHolder methodsFor: 'protocol'! removeLast: n | result | result := contents removeLast: n. self contentsChanged: result. ^ result! ! !CollectionValueHolder methodsFor: 'protocol'! replace: aBlock contents replace: aBlock . self contentsChanged! ! !CollectionValueHolder methodsFor: 'protocol'! replaceAll: oldObject with: newObject contents replaceAll: oldObject with: newObject . self contentsChanged: oldObject! ! !CollectionValueHolder methodsFor: 'protocol'! reset contents reset. self contentsChanged! ! !CollectionValueHolder methodsFor: 'protocol'! resetTo: index contents resetTo: index. self contentsChanged! ! !CollectionValueHolder methodsFor: 'protocol'! sort: aSortBlock contents sort: aSortBlock . self contentsChanged! ! !CollectionValueHolder methodsFor: 'private'! doesNotUnderstand: aMessage ^ (contents respondsTo: aMessage selector) ifTrue: [ contents perform: aMessage selector withEnoughArguments: aMessage arguments ] ifFalse: [ super doesNotUnderstand: aMessage ]! ! Object subclass: #CollectionsArithmeticReadme instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Arithmetic'! !CollectionsArithmeticReadme methodsFor: 'as yet unclassified' stamp: 'simondenier 11/30/2009 23:11'! readme "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 collections."! ! Object subclass: #Color instanceVariableNames: 'rgb cachedDepth cachedBitPattern' classVariableNames: 'Black Blue BlueShift Brown CachedColormaps ColorNames ComponentMask ComponentMax Cyan DarkGray Gray GrayToIndexMap Green GreenShift HalfComponentMask HighLightBitmaps IndexedColors LightBlue LightBrown LightCyan LightGray LightGreen LightMagenta LightOrange LightRed LightYellow Magenta MaskingMap Orange PureBlue PureCyan PureGreen PureMagenta PureRed PureYellow RandomStream Red RedShift TranslucentPatterns Transparent VeryDarkGray VeryLightGray VeryVeryDarkGray VeryVeryLightGray White Yellow' poolDictionaries: '' category: 'Graphics-Primitives'! !Color commentStamp: '' prior: 0! 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: '*Morphic' stamp: 'dgd 10/17/2003 12:10'! 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: '*Morphic' stamp: 'ar 10/5/2000 18:50'! 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: '*Morphic' stamp: 'ar 7/8/2006 21:00'! 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: '*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! ! !Color methodsFor: '*System-CommandLine' stamp: 'CamilloBruni 7/1/2012 15:03'! 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: 'access'! alpha "Return the opacity ('alpha') value of opaque so that normal colors can be compared to TransparentColors." ^ 1.0 ! ! !Color methodsFor: 'access'! blue "Return the blue component of this color, a float in the range [0.0..1.0]." ^ self privateBlue asFloat / ComponentMax! ! !Color methodsFor: 'access'! 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: 'access'! green "Return the green component of this color, a float in the range [0.0..1.0]." ^ self privateGreen asFloat / ComponentMax! ! !Color methodsFor: 'access' stamp: 'lr 7/4/2009 10:42'! 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: 'access'! 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: 'access'! red "Return the red component of this color, a float in the range [0.0..1.0]." ^ self privateRed asFloat / ComponentMax! ! !Color methodsFor: 'access' stamp: 'lr 7/4/2009 10:42'! 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: 'ar 11/2/1998 12:19'! asColor "Convert the receiver into a color" ^self! ! !Color methodsFor: 'conversions' stamp: 'TBn 6/15/2000 20:37'! asColorref "Convert the receiver into a colorref" ^(self red * 255) asInteger + ((self green * 255) asInteger << 8) + ((self green * 255) asInteger << 16)! ! !Color methodsFor: 'conversions' stamp: 'bf 2/19/2008 12:10'! 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: 'sw 10/27/1999 10:51'! asNontranslucentColor ^ self! ! !Color methodsFor: 'conversions' stamp: 'nice 4/19/2011 00:27'! balancedPatternForDepth: depth "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 | (depth = cachedDepth and: [ cachedBitPattern size = 2 ]) ifTrue: [ ^ cachedBitPattern ]. (depth between: 4 and: 16) ifFalse: [ ^ self bitPatternForDepth: depth ]. cachedDepth := depth. pv1 := self 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 := self - ((Color colorFromPixelValue: pv1 depth: depth) - self)) 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" ^ cachedBitPattern := Bitmap with: mask1 * pv1 + (mask2 * pv2) with: mask1 * pv3 + (mask2 * pv1)! ! !Color methodsFor: 'conversions' stamp: 'nice 4/19/2011 00:28'! 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 ]. 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: 'conversions'! 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: 'conversions' stamp: 'lr 7/4/2009 10:42'! 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: 'conversions' stamp: 'lr 7/4/2009 10:42'! 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 = PureRed privateRGB ifTrue: [ ^ 4 ]. rgb = PureGreen privateRGB ifTrue: [ ^ 5 ]. rgb = PureBlue privateRGB ifTrue: [ ^ 6 ]. rgb = PureCyan privateRGB ifTrue: [ ^ 7 ]. rgb = PureYellow privateRGB ifTrue: [ ^ 8 ]. rgb = PureMagenta 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: 'conversions'! 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: 'gvc 4/17/2007 11:41'! contrastingColor "Answer black or white depending on the luminance." self isTransparent ifTrue: [^Color black]. ^self luminance > 0.5 ifTrue: [Color black] ifFalse: [Color white]! ! !Color methodsFor: 'conversions' stamp: 'di 9/2/97 20:21'! dominantColor ^ self! ! !Color methodsFor: 'conversions' stamp: 'lr 7/4/2009 10:42'! 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: 'conversions' stamp: 'lr 7/4/2009 10:42'! 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: 'tk 4/24/97'! 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: 'conversions' stamp: 'bf 4/18/2001 16:25'! makeForegroundColor "Make a foreground color contrasting with me" ^self luminance >= 0.5 ifTrue: [Color black] ifFalse: [Color white]! ! !Color methodsFor: 'conversions' stamp: 'ar 5/15/2001 16:12'! pixelValue32 "Note: pixelWord not pixelValue so we include translucency" ^self pixelWordForDepth: 32! ! !Color methodsFor: 'conversions' stamp: 'HenrikSperreJohansen 5/27/2010 23:15'! pixelValueForDepth: 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: 'conversions' stamp: 'gvc 9/21/2006 09:48'! pixelWord32 "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 | "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: 16rFF. "opaque alpha" ^val ! ! !Color methodsFor: 'conversions' stamp: 'lr 7/4/2009 10:42'! 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: 'conversions' stamp: 'lr 7/4/2009 10:42'! 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 | pixelValue := self pixelValueForDepth: depth. ^ self pixelWordFor: depth filledWith: pixelValue! ! !Color methodsFor: 'conversions' stamp: 'ar 1/14/1999 15:28'! scaledPixelValue32 "Return the alpha scaled pixel value for depth 32" ^self pixelWordForDepth: 32! ! !Color methodsFor: 'copying' stamp: 'tk 8/19/1998 16:12'! veryDeepCopyWith: deepCopier "Return self. I am immutable in the Morphic world. Do not record me."! ! !Color methodsFor: 'equality' stamp: 'di 1/6/1999 20:26'! = aColor "Return true if the receiver equals the given color. This method handles TranslucentColors, too." aColor isColor ifFalse: [^ false]. ^ aColor privateRGB = rgb and: [aColor privateAlpha = self privateAlpha] ! ! !Color methodsFor: 'equality' stamp: 'di 9/27/2000 08:07'! 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: 'equality'! hash ^ rgb! ! !Color methodsFor: 'groups of shades' stamp: 'tk 6/18/96'! 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: 'groups of shades' stamp: 'tk 6/18/96'! 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: 'groups of shades' stamp: 'nice 1/5/2010 15:59'! 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 := Color 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: 'groups of shades' stamp: 'nice 1/5/2010 15:59'! 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 := Color 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: 'html' stamp: 'stephane.ducasse 5/25/2008 18:10'! 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: 'other' stamp: 'sw 2/16/98 03:42'! colorForInsets ^ self! ! !Color methodsFor: 'other' stamp: 'jm 12/4/97 10:24'! name "Return this color's name, or nil if it has no name. Only returns a name if it exactly matches the named color." ColorNames do: [:name | (Color perform: name) = self ifTrue: [^ name]]. ^ nil ! ! !Color methodsFor: 'other' stamp: 'ar 8/16/2001 12:47'! raisedColor ^ self! ! !Color methodsFor: 'other' stamp: 'jm 12/4/97 10:27'! 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: 'printing' stamp: 'lr 7/4/2009 10:42'! printOn: aStream | name | (name := self name) ifNotNil: [ ^ aStream nextPutAll: 'Color '; nextPutAll: name ]. self storeOn: aStream! ! !Color methodsFor: 'printing' stamp: 'PeterHugossonMiller 9/3/2009 00:56'! 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: 'printing' stamp: 'mir 7/21/1999 11:41'! storeArrayOn: aStream aStream nextPutAll: '#('. self storeArrayValuesOn: aStream. aStream nextPutAll: ') ' ! ! !Color methodsFor: 'printing' stamp: 'mir 7/21/1999 11:41'! storeArrayValuesOn: aStream (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. ! ! !Color methodsFor: 'printing' stamp: 'di 9/27/2000 13:34'! storeOn: aStream 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: ')'. ! ! !Color methodsFor: 'queries' stamp: 'ar 1/14/1999 15:27'! isBitmapFill ^false! ! !Color methodsFor: 'queries' stamp: 'ar 11/12/1998 19:43'! isBlack "Return true if the receiver represents black" ^rgb = 0! ! !Color methodsFor: 'queries'! isColor ^ true ! ! !Color methodsFor: 'queries' stamp: 'ar 6/18/1999 06:58'! isGradientFill ^false! ! !Color methodsFor: 'queries' stamp: 'ar 11/12/1998 19:44'! isGray "Return true if the receiver represents a shade of gray" ^(self privateRed = self privateGreen) and:[self privateRed = self privateBlue]! ! !Color methodsFor: 'queries' stamp: 'ar 4/20/2001 04:33'! isOpaque ^true! ! !Color methodsFor: 'queries' stamp: 'ar 6/18/1999 07:57'! isOrientedFill "Return true if the receiver keeps an orientation (e.g., origin, direction, and normal)" ^false! ! !Color methodsFor: 'queries' stamp: 'ar 11/7/1998 20:20'! isSolidFill ^true! ! !Color methodsFor: 'queries' stamp: 'di 12/30/1998 14:33'! isTranslucent ^ false ! ! !Color methodsFor: 'queries' stamp: 'di 1/3/1999 12:23'! isTranslucentColor "This means: self isTranslucent, but isTransparent not" ^ false! ! !Color methodsFor: 'queries'! isTransparent ^ false ! ! !Color methodsFor: 'self evaluating' stamp: 'nice 11/9/2009 00:44'! isSelfEvaluating ^ true! ! !Color methodsFor: 'transformations' stamp: 'fbs 2/3/2005 13:09'! * 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." "(Color brown * 2) display" "(Color brown * #(1 0 1)) display" | multipliers | multipliers := aNumberOrArray isCollection ifTrue: [aNumberOrArray] ifFalse: [Array with: aNumberOrArray with: aNumberOrArray with: aNumberOrArray]. ^ Color basicNew setPrivateRed: (self privateRed * multipliers first) asInteger green: (self privateGreen * multipliers second) asInteger blue: (self privateBlue * multipliers third) asInteger.! ! !Color methodsFor: 'transformations' stamp: 'di 11/2/97 14:05'! + aColor "Answer this color mixed with the given color in an additive color space. " "(Color blue + Color green) display" ^ Color basicNew setPrivateRed: self privateRed + aColor privateRed green: self privateGreen + aColor privateGreen blue: self privateBlue + aColor privateBlue ! ! !Color methodsFor: 'transformations' stamp: 'di 11/2/97 14:05'! - aColor "Answer aColor is subtracted from the given color in an additive color space. " "(Color white - Color red) display" ^ Color basicNew setPrivateRed: self privateRed - aColor privateRed green: self privateGreen - aColor privateGreen blue: self privateBlue - aColor privateBlue ! ! !Color methodsFor: 'transformations' stamp: 'di 11/2/97 14:07'! / aNumber "Answer this color with its RGB divided by the given number. " "(Color red / 2) display" ^ Color basicNew setPrivateRed: (self privateRed / aNumber) asInteger green: (self privateGreen / aNumber) asInteger blue: (self privateBlue / aNumber) asInteger ! ! !Color methodsFor: 'transformations' stamp: 'dew 3/19/2002 23:50'! adjustBrightness: brightness "Adjust the relative brightness of this color. (lowest value is 0.005 so that hue information is not lost)" ^ Color h: self hue s: self saturation v: (self brightness + brightness min: 1.0 max: 0.005) alpha: self alpha! ! !Color methodsFor: 'transformations' stamp: 'dew 3/19/2002 23:51'! 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)" ^ Color 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: 'transformations' stamp: 'sma 6/25/2000 15:36'! alpha: alphaValue "Answer a new Color with the given amount of opacity ('alpha')." alphaValue = 1.0 ifFalse: [^ TranslucentColor basicNew setRgb: rgb alpha: alphaValue]! ! !Color methodsFor: 'transformations' stamp: 'lr 7/4/2009 10:42'! 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. ^ Color 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: 'transformations' stamp: 'lr 7/4/2009 10:42'! atLeastAsLuminentAs: aFloat | revisedColor | revisedColor := self. [ revisedColor luminance < aFloat ] whileTrue: [ revisedColor := revisedColor slightlyLighter ]. ^ revisedColor! ! !Color methodsFor: 'transformations' stamp: 'lr 7/4/2009 10:42'! atMostAsLuminentAs: aFloat | revisedColor | revisedColor := self. [ revisedColor luminance > aFloat ] whileTrue: [ revisedColor := revisedColor slightlyDarker ]. ^ revisedColor! ! !Color methodsFor: 'transformations' stamp: 'dew 3/23/2002 01:38'! blacker ^ self alphaMixed: 0.8333 with: Color black ! ! !Color methodsFor: 'transformations' stamp: 'dew 3/19/2002 23:54'! 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)" ^ Color h: self hue s: self saturation v: (self brightness - 0.16 max: 0.0)! ! !Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:40'! darker "Answer a darker shade of this color." ^ self adjustBrightness: -0.08! ! !Color methodsFor: 'transformations' stamp: 'StephaneDucasse 7/21/2010 17:27'! 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: 'transformations' stamp: 'dew 1/23/2002 20:19'! lighter "Answer a lighter shade of this color." ^ self adjustSaturation: -0.03 brightness: 0.08! ! !Color methodsFor: 'transformations' stamp: 'lr 7/4/2009 10: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. ^ Color r: self red * frac1 + (aColor red * frac2) g: self green * frac1 + (aColor green * frac2) b: self blue * frac1 + (aColor blue * frac2)! ! !Color methodsFor: 'transformations' stamp: 'dew 1/19/2002 01:29'! muchDarker ^ self alphaMixed: 0.5 with: Color black ! ! !Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 12:07'! muchLighter ^ self alphaMixed: 0.233 with: Color white ! ! !Color methodsFor: 'transformations' stamp: 'ar 6/19/1999 00:36'! negated "Return an RGB inverted color" ^Color r: 1.0 - self red g: 1.0 - self green b: 1.0 - self blue! ! !Color methodsFor: 'transformations' stamp: 'di 9/27/2000 08:14'! 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: 'transformations' stamp: 'dew 3/4/2002 01:42'! paler "Answer a paler shade of this color." ^ self adjustSaturation: -0.09 brightness: 0.09 ! ! !Color methodsFor: 'transformations' stamp: 'JuanVuletich 10/11/2010 22:21'! quiteBlacker ^ self alphaMixed: 0.8 with: Color black! ! !Color methodsFor: 'transformations' stamp: 'JuanVuletich 10/11/2010 22:21'! quiteWhiter ^ self alphaMixed: 0.6 with: Color white! ! !Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:43'! slightlyDarker ^ self adjustBrightness: -0.03 ! ! !Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:43'! slightlyLighter ^ self adjustSaturation: -0.01 brightness: 0.03! ! !Color methodsFor: 'transformations' stamp: 'dew 1/19/2002 01:25'! slightlyWhiter ^ self alphaMixed: 0.85 with: Color white ! ! !Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:44'! twiceDarker "Answer a significantly darker shade of this color." ^ self adjustBrightness: -0.15! ! !Color methodsFor: 'transformations' stamp: 'dew 3/4/2002 01:45'! twiceLighter "Answer a significantly lighter shade of this color." ^ self adjustSaturation: -0.06 brightness: 0.15! ! !Color methodsFor: 'transformations' stamp: 'tk 7/4/2000 12:07'! veryMuchLighter ^ self alphaMixed: 0.1165 with: Color white ! ! !Color methodsFor: 'transformations' stamp: 'dew 3/23/2002 01:38'! whiter ^ self alphaMixed: 0.8333 with: Color white ! ! !Color methodsFor: 'private'! 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: 'private' stamp: 'lr 7/4/2009 10:42'! flushCache "Flush my cached bit pattern." cachedDepth := nil. cachedBitPattern := nil! ! !Color methodsFor: 'private'! privateAlpha "Private!! Return the raw alpha value for opaque. Used only for equality testing." ^ 255! ! !Color methodsFor: 'private'! privateBlue "Private!! Return the internal representation of my blue component." ^ rgb bitAnd: ComponentMask! ! !Color methodsFor: 'private' stamp: 'CamilloBruni 8/1/2012 16:13'! privateGreen "Private!! Return the internal representation of my green component." ^ (rgb bitShift: 0 - GreenShift) bitAnd: ComponentMask! ! !Color methodsFor: 'private'! privateRGB "Private!! Return the internal representation of my RGB components." ^ rgb ! ! !Color methodsFor: 'private'! privateRed "Private!! Return the internal representation of my red component." ^ (rgb bitShift: 0 - RedShift) bitAnd: ComponentMask! ! !Color methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 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: 'private' stamp: 'lr 7/4/2009 10:42'! 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: 'private' stamp: 'lr 7/4/2009 10:42'! setRGB: rgb0 rgb == nil ifFalse: [ self attemptToMutateError ]. rgb := rgb0! ! !Color methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! 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: 'private' stamp: 'lr 7/4/2009 10:42'! 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 class instanceVariableNames: ''! !Color class methodsFor: '*System-Settings-Browser' stamp: 'AlainPlantec 3/5/2010 09:33'! settingInputWidgetForNode: aSettingNode ^ aSettingNode inputWidgetForColor! ! !Color class methodsFor: 'class initialization' stamp: 'lr 7/4/2009 10:42'! initializeNames "Name some colors." "Color initializeNames" ColorNames := OrderedCollection new. self named: #black put: (Color r: 0 g: 0 b: 0). self named: #veryVeryDarkGray put: (Color r: 0.125 g: 0.125 b: 0.125). self named: #veryDarkGray put: (Color r: 0.25 g: 0.25 b: 0.25). self named: #darkGray put: (Color r: 0.375 g: 0.375 b: 0.375). self named: #gray put: (Color r: 0.5 g: 0.5 b: 0.5). self named: #lightGray put: (Color r: 0.625 g: 0.625 b: 0.625). self named: #veryLightGray put: (Color r: 0.75 g: 0.75 b: 0.75). self named: #veryVeryLightGray put: (Color r: 0.875 g: 0.875 b: 0.875). self named: #white put: (Color r: 1.0 g: 1.0 b: 1.0). self named: #red put: (Color r: 1.0 g: 0 b: 0). self named: #yellow put: (Color r: 1.0 g: 1.0 b: 0). self named: #green put: (Color r: 0 g: 1.0 b: 0). self named: #cyan put: (Color r: 0 g: 1.0 b: 1.0). self named: #blue put: (Color r: 0 g: 0 b: 1.0). self named: #magenta put: (Color r: 1.0 g: 0 b: 1.0). self named: #brown put: (Color r: 0.6 g: 0.2 b: 0). self named: #orange put: (Color r: 1.0 g: 0.6 b: 0). self named: #lightRed put: (Color r: 1.0 g: 0.8 b: 0.8). self named: #lightYellow put: (Color r: 1.0 g: 1.0 b: 0.8). self named: #lightGreen put: (Color r: 0.8 g: 1.0 b: 0.6). self named: #lightCyan put: (Color r: 0.4 g: 1.0 b: 1.0). self named: #lightBlue put: (Color r: 0.8 g: 1.0 b: 1.0). self named: #lightMagenta put: (Color r: 1.0 g: 0.8 b: 1.0). self named: #lightBrown put: (Color r: 1.0 g: 0.6 b: 0.2). self named: #lightOrange put: (Color r: 1.0 g: 0.8 b: 0.4). self named: #transparent put: (TranslucentColor new alpha: 0.0)! ! !Color class methodsFor: 'color from user' stamp: 'JuanVuletich 10/10/2010 19:39'! 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: Color white. palette fill: (x@y extent: 1@1) fillColor: c. y := y + 1]. 1 to: vSteps do: [ :n | | c | c := Color 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 := Color black mixed: (n asFloat / (vSteps*2) asFloat) with: Color white. palette fill: (x@y extent: 10@1) fillColor: c. y := y + 1]. ^ palette! ! !Color class methodsFor: 'colormaps' stamp: 'AlainPlantec 12/18/2009 16:48'! 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: 'colormaps' stamp: 'lr 7/4/2009 10:42'! 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: 'colormaps'! 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]. ^ Color cachedColormapFrom: sourceDepth to: destDepth ! ! !Color class methodsFor: 'colormaps' stamp: 'jmv 8/2/2009 21:32'! 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: 'colormaps' stamp: 'lr 7/4/2009 10:42'! 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: 'colormaps' stamp: 'nice 1/5/2010 15:59'! 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: Color 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: 'colormaps' stamp: 'AlainPlantec 12/18/2009 16:49'! 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: [ Color 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: Color white ] ] ] ifFalse: [ Color 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: 'colormaps' stamp: 'lr 7/4/2009 10:42'! 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 := Color 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: (Color transparent pixelWordForDepth: destDepth). "zero always transparent" ^ map! ! !Color class methodsFor: 'examples'! wheel: thisMany "Return a collection of thisMany colors evenly spaced around the color wheel." "Color showColors: (Color wheel: 12)" ^ Color wheel: thisMany saturation: 0.9 brightness: 0.7 ! ! !Color class methodsFor: 'examples'! 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)" ^ (Color h: 0.0 s: s v: v) wheel: thisMany ! ! !Color class methodsFor: 'initialization' stamp: 'lr 7/4/2009 10:42'! initialize "Color 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. PureRed := self r: 1 g: 0 b: 0. PureGreen := self r: 0 g: 1 b: 0. PureBlue := self r: 0 g: 0 b: 1. PureYellow := self r: 1 g: 1 b: 0. PureCyan := self r: 0 g: 1 b: 1. PureMagenta := self r: 1 g: 0 b: 1. RandomStream := Random new. self initializeIndexedColors. self initializeGrayToIndexMap. self initializeNames. self initializeHighLights! ! !Color class methodsFor: 'initialization' stamp: 'lr 7/4/2009 10:42'! 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: 'initialization' stamp: 'lr 7/4/2009 10:42'! initializeHighLights "Create a set of Bitmaps for quickly reversing areas of the screen without converting colors. " "Color initializeHighLights" | t | t := Array new: 32. t at: 1 put: (Bitmap with: 4294967295). t at: 2 put: (Bitmap with: 4294967295). t at: 4 put: (Bitmap with: 1431655765). t at: 8 put: (Bitmap with: 117901063). t at: 16 put: (Bitmap with: 4294967295). t at: 32 put: (Bitmap with: 4294967295). HighLightBitmaps := t! ! !Color class methodsFor: 'initialization' stamp: 'lr 7/4/2009 10:42'! 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: (Color r: 1.0 g: 1.0 b: 1.0). "white or transparent" a at: 2 put: (Color r: 0.0 g: 0.0 b: 0.0). "black" "additional colors for 2-bit color" a at: 3 put: (Color r: 1.0 g: 1.0 b: 1.0). "opaque white" a at: 4 put: (Color r: 0.5 g: 0.5 b: 0.5). "1/2 gray" "additional colors for 4-bit color" a at: 5 put: (Color r: 1.0 g: 0.0 b: 0.0). "red" a at: 6 put: (Color r: 0.0 g: 1.0 b: 0.0). "green" a at: 7 put: (Color r: 0.0 g: 0.0 b: 1.0). "blue" a at: 8 put: (Color r: 0.0 g: 1.0 b: 1.0). "cyan" a at: 9 put: (Color r: 1.0 g: 1.0 b: 0.0). "yellow" a at: 10 put: (Color r: 1.0 g: 0.0 b: 1.0). "magenta" a at: 11 put: (Color r: 0.125 g: 0.125 b: 0.125). "1/8 gray" a at: 12 put: (Color r: 0.25 g: 0.25 b: 0.25). "2/8 gray" a at: 13 put: (Color r: 0.375 g: 0.375 b: 0.375). "3/8 gray" a at: 14 put: (Color r: 0.625 g: 0.625 b: 0.625). "5/8 gray" a at: 15 put: (Color r: 0.75 g: 0.75 b: 0.75). "6/8 gray" a at: 16 put: (Color 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: (Color r: r g: g b: b range: 5) ] ] ]. IndexedColors := a! ! !Color class methodsFor: 'initialization' stamp: 'nice 1/5/2010 15:59'! initializeTranslucentPatterns "Color 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 ]! ! !Color class methodsFor: 'initialization' stamp: 'StephaneDucasse 3/25/2012 17:12'! named: newName put: aColor "Add a new color to the list and create an access message and a class variable for it. The name should start with a lowercase letter. (The class variable will start with an uppercase letter.) (Color colorNames) returns a list of all color names. " | str cap sym accessor csym | str := newName asString. sym := str asSymbol. cap := str capitalized. csym := cap asSymbol. (self classPool includesKey: csym) ifFalse: [ self addClassVarNamed: cap ]. (ColorNames includes: sym) ifFalse: [ ColorNames add: sym ]. ^ self classPool at: csym put: aColor! ! !Color class methodsFor: 'instance creation' stamp: 'ar 4/10/2005 18:45'! 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: 'instance creation' stamp: 'lr 7/4/2009 10:42'! 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: [ ^ Color transparent ]. b = 1 ifTrue: [ ^ Color black ] ]. ^ Color 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: [ ^ Color transparent ]. (r = 0 and: [ g = 0 and: [ b = 0 ] ]) ifTrue: [ ^ Color transparent ]. alpha < 255 ifTrue: [ ^ (Color r: r g: g b: b range: 255) alpha: alpha asFloat / 255.0 ] ifFalse: [ ^ Color 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. ^ Color 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. ^ Color r: r g: g b: b range: 7 ]. self error: 'unknown pixel depth: ' , d printString! ! !Color class methodsFor: 'instance creation' stamp: 'StephaneDucasse 5/28/2011 13:32'! fromArray: colorDef colorDef size = 3 ifTrue: [^self r: (colorDef at: 1) g: (colorDef at: 2) b: (colorDef at: 3)]. colorDef size = 0 ifTrue: [^Color transparent]. colorDef size = 4 ifTrue: [^(TranslucentColor r: (colorDef at: 1) g: (colorDef at: 2) b: (colorDef at: 3)) alpha: (colorDef at: 4)]. self error: 'Undefined color definition'! ! !Color class methodsFor: 'instance creation' stamp: 'JavierPimas 9/30/2011 12:12'! 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: 'instance creation' stamp: 'sw 8/8/97 22:03'! fromRgbTriplet: list ^ self r: list first g: list second b: list last! ! !Color class methodsFor: 'instance creation' stamp: 'nice 2/20/2012 18:43'! 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." (ColorNames detect: [:each | each sameAs: aColorHex] ifNone: [ nil ]) ifNotNil: [:colorSymbol | ^self perform: colorSymbol]. (aColorHex size = 6 and: [ aColorHex allSatisfy: [ :character | '0123456789ABCDEFabcdef' includes: character ] ]) ifTrue: [ ^self fromHexString: aColorHex ] ifFalse: [ ^self white ]! ! !Color class methodsFor: 'instance creation' stamp: 'jm 12/4/97 13:05'! gray: brightness "Return a gray shade with the given brightness in the range [0.0..1.0]." ^ self basicNew setRed: brightness green: brightness blue: brightness ! ! !Color class methodsFor: 'instance creation'! 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 basicNew setHue: hue saturation: saturation brightness: brightness! ! !Color class methodsFor: 'instance creation' stamp: 'dew 3/19/2002 23:49'! h: h s: s v: v alpha: alpha ^ (self h: h s: s v: v) alpha: alpha! ! !Color class methodsFor: 'instance creation'! new ^ self r: 0.0 g: 0.0 b: 0.0! ! !Color class methodsFor: 'instance creation' stamp: 'jm 12/4/97 13:04'! 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 basicNew setRed: r green: g blue: b ! ! !Color class methodsFor: 'instance creation'! r: r g: g b: b alpha: alpha ^ (self r: r g: g b: b) alpha: alpha! ! !Color class methodsFor: 'instance creation'! 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 setRed: r green: g blue: b range: range! ! !Color class methodsFor: 'instance creation'! random "Return a random color that isn't too dark or under-saturated." ^ self basicNew setHue: (360.0 * RandomStream next) saturation: (0.3 + (RandomStream next * 0.7)) brightness: (0.4 + (RandomStream next * 0.6))! ! !Color class methodsFor: 'named colors'! black ^Black! ! !Color class methodsFor: 'named colors'! blue ^Blue! ! !Color class methodsFor: 'named colors'! brown ^Brown! ! !Color class methodsFor: 'named colors'! cyan ^Cyan! ! !Color class methodsFor: 'named colors'! darkGray ^DarkGray! ! !Color class methodsFor: 'named colors'! gray ^Gray! ! !Color class methodsFor: 'named colors'! green ^Green! ! !Color class methodsFor: 'named colors'! lightBlue ^LightBlue! ! !Color class methodsFor: 'named colors'! lightBrown ^LightBrown! ! !Color class methodsFor: 'named colors' stamp: 'AlexandreBergel 4/14/2011 12:49'! lightColors ^OrderedCollection new "red" add: (Color h: Color red hue s: 0.3 v: Color red brightness); "blue" add: (Color h: Color blue hue s: 0.3 v: Color blue brightness); "orange" add: (Color h: Color orange hue s: 0.3 v: Color orange brightness); "cyan" add: (Color h: Color cyan hue s: 0.3 v: Color cyan brightness ); "green" add: (Color h: Color lightGreen hue s: 0.1 v: 0.7); "pink" add: (Color h: Color pink hue s: 0.1 v: Color pink brightness); "brown" add: (Color h: Color brown hue s: 0.2 v: 1 ); "purple" add: (Color h: Color purple hue s: 0.2 v: Color purple brightness ); "yellow" add: (Color h: Color yellow hue s: 0.3 v: Color yellow brightness); "gray" add: (Color veryLightGray); yourself; yourself! ! !Color class methodsFor: 'named colors'! lightCyan ^LightCyan! ! !Color class methodsFor: 'named colors'! lightGray ^LightGray! ! !Color class methodsFor: 'named colors'! lightGreen ^LightGreen! ! !Color class methodsFor: 'named colors'! lightMagenta ^LightMagenta! ! !Color class methodsFor: 'named colors'! lightOrange ^LightOrange! ! !Color class methodsFor: 'named colors'! lightRed ^LightRed! ! !Color class methodsFor: 'named colors'! lightYellow ^LightYellow! ! !Color class methodsFor: 'named colors'! magenta ^Magenta! ! !Color class methodsFor: 'named colors'! orange ^Orange! ! !Color class methodsFor: 'named colors' stamp: 'yo 8/28/2008 01:06'! paleBlue ^(Color r: 0.87 g: 0.976 b: 0.995) ! ! !Color class methodsFor: 'named colors' stamp: 'yo 8/28/2008 01:07'! paleBuff ^(Color r: 0.995 g: 0.979 b: 0.921)! ! !Color class methodsFor: 'named colors' stamp: 'yo 8/28/2008 01:06'! paleGreen ^(Color r: 0.874 g: 1.0 b: 0.835)! ! !Color class methodsFor: 'named colors' stamp: 'yo 8/28/2008 01:05'! paleMagenta ^(Color r: 1.0 g: 0.901 b: 1.0)! ! !Color class methodsFor: 'named colors' stamp: 'yo 8/28/2008 01:03'! paleOrange ^ (Color r: 0.991 g: 0.929 b: 0.843) ! ! !Color class methodsFor: 'named colors' stamp: 'yo 8/28/2008 01:03'! palePeach ^(Color r: 1.0 g: 0.929 b: 0.835)! ! !Color class methodsFor: 'named colors' stamp: 'yo 8/28/2008 01:07'! paleRed ^(Color r: 1.0 g: 0.901 b: 0.901)! ! !Color class methodsFor: 'named colors' stamp: 'yo 8/28/2008 01:02'! paleTan ^(Color r: 0.921 g: 0.878 b: 0.78) ! ! !Color class methodsFor: 'named colors' stamp: 'yo 8/28/2008 01:05'! paleYellow ^(Color r: 1.0 g: 1.0 b: 0.85)! ! !Color class methodsFor: 'named colors' stamp: 'AlexandreBergel 4/14/2011 12:49'! pink ^ self r: 1.0 g: 0.752899 b: 0.796118.! ! !Color class methodsFor: 'named colors' stamp: 'AlexandreBergel 4/14/2011 12:49'! purple ^ self r: 0.4 g: 0.0 b: 0.6.! ! !Color class methodsFor: 'named colors'! red ^Red! ! !Color class methodsFor: 'named colors' stamp: 'AlexandreBergel 4/14/2011 12:49'! strongColors ^(OrderedCollection new) add: self red; add: self blue; add: self orange; add: self cyan; add: self green; add: self pink; add: self brown; add: self purple; add: self yellow; add: self gray; yourself! ! !Color class methodsFor: 'named colors' stamp: 'wod 5/24/1998 01:56'! tan ^ Color r: 0.8 g: 0.8 b: 0.5! ! !Color class methodsFor: 'named colors'! transparent ^Transparent! ! !Color class methodsFor: 'named colors'! veryDarkGray ^VeryDarkGray! ! !Color class methodsFor: 'named colors'! veryLightGray ^VeryLightGray! ! !Color class methodsFor: 'named colors' stamp: 'yo 8/28/2008 01:06'! veryPaleRed ^(Color r: 1.0 g: 0.948 b: 0.948)! ! !Color class methodsFor: 'named colors'! veryVeryDarkGray ^VeryVeryDarkGray! ! !Color class methodsFor: 'named colors'! veryVeryLightGray ^VeryVeryLightGray! ! !Color class methodsFor: 'named colors'! white ^White! ! !Color class methodsFor: 'named colors'! yellow ^Yellow! ! !Color class methodsFor: 'other'! colorNames "Return a collection of color names." ^ ColorNames! ! !Color class methodsFor: 'other' stamp: 'BG 3/16/2005 08:18'! 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: 'other'! indexedColors ^ IndexedColors! ! !Color class methodsFor: 'other' stamp: 'lr 7/4/2009 10:42'! 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: 'other' stamp: 'lr 7/4/2009 10:42'! 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: 'other' stamp: 'CamilloBruni 8/1/2012 16:13'! quickHighLight: depth "Quickly return a Bitblt-ready raw colorValue for highlighting areas." ^ HighLightBitmaps at: depth! ! !Color class methodsFor: 'other' stamp: 'IgorStasenko 12/29/2011 15:18'! 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: 'other' stamp: 'ar 2/16/2000 21:56'! translucentMaskFor: alphaValue depth: d "Return a pattern representing a mask usable for stipple transparency" ^(TranslucentPatterns at: d) at: ((alphaValue min: 1.0 max: 0.0) * 4) rounded + 1! ! AbstractApiSetter subclass: #ColorApiSetter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Spec-Tools-Editor'! !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.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ColorApiSetter class instanceVariableNames: ''! !ColorApiSetter class methodsFor: 'as yet unclassified' stamp: 'BenjaminVanRyseghem 7/16/2012 19:24'! spec ^ SpecLayout composed newRow: [:r | r add: #selector; newColumn: [:c | c add: #choice ] width: 75] height: 25; yourself! ! ArrayedCollection variableWordSubclass: #ColorArray instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Display Objects'! !ColorArray methodsFor: 'accessing' stamp: 'ar 3/3/2001 20:03'! at: index ^(super at: index) asColorOfDepth: 32! ! !ColorArray methodsFor: 'accessing' stamp: 'ar 3/3/2001 20:04'! at: index put: aColor ^super at: index put: (aColor pixelWordForDepth: 32).! ! !ColorArray methodsFor: 'converting' stamp: 'ar 3/3/2001 20:06'! asColorArray ^self! ! Announcement subclass: #ColorChanged instanceVariableNames: 'newColor' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Windows'! !ColorChanged commentStamp: 'LaurentLaffont 4/15/2011 20:19' prior: 0! 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 instanceVariableNames: ''! !ColorChanged class methodsFor: 'instance creation' stamp: 'dik 6/27/2010 16:26'! to: aColor ^self new newColor: aColor! ! ColorPresenterMorph subclass: #ColorChooserMorph uses: TEnableOnHaloMenu instanceVariableNames: 'setColorSelector enabled getEnabledSelector' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !ColorChooserMorph commentStamp: 'gvc 5/18/2007 13:45' prior: 0! ColorPresenter that opens a colour selector when clicked.! !ColorChooserMorph methodsFor: 'accessing' stamp: 'gvc 10/12/2006 13:47'! getEnabledSelector "Answer the value of getEnabledSelector" ^ getEnabledSelector! ! !ColorChooserMorph methodsFor: 'accessing' stamp: 'gvc 10/12/2006 13:51'! getEnabledSelector: anObject "Set the value of getEnabledSelector" getEnabledSelector := anObject. self updateEnabled! ! !ColorChooserMorph methodsFor: 'as yet unclassified'! addToggleItemsToHaloMenu: aCustomMenu "Add toggle-items to the halo menu" super addToggleItemsToHaloMenu: aCustomMenu. aCustomMenu addUpdating: #enabledString target: self action: #toggleEnabled! ! !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 10/12/2006 13:46'! enabled "Answer the enabled state of the receiver." ^enabled! ! !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: 'StephaneDucasse 4/22/2012 16:45'! 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: 'gvc 5/22/2007 11:44'! initialize "Initialize the receiver." enabled := true. super initialize! ! !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/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: 'as yet unclassified' stamp: 'gvc 2/14/2009 18:41'! setColorSelector "Answer the value of setColorSelector" ^ setColorSelector! ! !ColorChooserMorph methodsFor: 'as yet unclassified' stamp: 'gvc 2/14/2009 18:41'! setColorSelector: anObject "Set the value of setColorSelector" setColorSelector := anObject! ! !ColorChooserMorph methodsFor: 'as yet unclassified'! toggleEnabled "Toggle the enabled state." self enabled: self enabled not! ! !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 9/8/2009 13:25'! updateEnabled "Update the enablement state." self model ifNotNil: [ self getEnabledSelector ifNotNil: [ self enabled: (self model perform: self getEnabledSelector)]]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ColorChooserMorph class uses: TEnableOnHaloMenu classTrait instanceVariableNames: ''! !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! ! ComposableModel subclass: #ColorEditor instanceVariableNames: 'a b color g morph r' classVariableNames: '' poolDictionaries: '' category: 'Spec-Tools-Editor'! !ColorEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/16/2012 19:18'! a ^ a! ! !ColorEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/16/2012 19:18'! b ^ b! ! !ColorEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/16/2012 19:05'! color ^ color contents! ! !ColorEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/16/2012 19:06'! color: anObject color contents: anObject! ! !ColorEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/16/2012 19:18'! g ^ g! ! !ColorEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/16/2012 19:06'! morph ^ morph! ! !ColorEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/16/2012 19:05'! morph: anObject morph := anObject! ! !ColorEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/16/2012 19:18'! r ^ r! ! !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: 'initialization' stamp: 'BenjaminVanRyseghem 7/18/2012 16:54'! updateColor | newColor | newColor := TranslucentColor 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: 'initialize' stamp: 'BenjaminVanRyseghem 7/16/2012 19:15'! initialize "Initialization code for ColorEditor" super initialize. color := Color black asValueHolder. morph := Morph new color: self color; extent: 25@25; yourself! ! !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 methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 19:27'! setAbsoluteAlpha: aFloat a absoluteValue: aFloat ! ! !ColorEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 19:27'! setAbsoluteBlue: aFloat b absoluteValue: aFloat ! ! !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'! setAbsoluteRed: aFloat r absoluteValue: aFloat ! ! !ColorEditor methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/16/2012 19:08'! whenColorChangedDo: aBlock color whenChangedDo: aBlock ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ColorEditor class instanceVariableNames: ''! !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! ! SolidFillStyle subclass: #ColorFillStyle instanceVariableNames: 'origin extent' classVariableNames: '' poolDictionaries: '' category: 'Balloon-Fills'! !ColorFillStyle commentStamp: 'gvc 12/8/2008 13:05' prior: 0! 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: '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! ! !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! ! Form subclass: #ColorForm instanceVariableNames: 'colors cachedDepth cachedColormap' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Display Objects'! !ColorForm commentStamp: '' prior: 0! 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: 'jm 11/14/97 17:39'! colors "Return my color palette." self ensureColorArrayExists. ^ colors ! ! !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: '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: '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: '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: '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 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: '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: '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: '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: '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: '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: '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: '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: '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: 'copying' stamp: 'MarcusDenker 4/10/2011 09:45'! asCursorForm ^ (self asFormOfDepth: 32) offset: offset! ! !ColorForm methodsFor: 'copying' stamp: 'ar 10/24/2005 22:25'! blankCopyOf: aRectangle scaledBy: scale ^Form extent: (aRectangle extent * scale) truncated depth: 32! ! !ColorForm methodsFor: 'copying' stamp: 'ar 5/28/2000 12:06'! 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 current 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: 'copying' stamp: 'jm 2/27/98 09:38'! deepCopy ^ self shallowCopy bits: bits copy; offset: offset copy; colors: colors ! ! !ColorForm methodsFor: 'displaying' stamp: 'di 7/17/97 10:04'! displayOnPort: port at: location port copyForm: self to: location rule: Form paint! ! !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: '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: '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: '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: 'filein/out' stamp: 'ar 3/3/2001 20:07'! unhibernate colors ifNotNil:[colors := colors asArray]. ^super unhibernate. ! ! !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 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: '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: '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: 'pixel accessing' stamp: 'ar 5/28/2000 12:06'! 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 current bitPeekerFromForm: self) colorMap: nil; pixelAt: aPoint ! ! !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: '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: 'testing' stamp: 'ar 5/27/2001 16:34'! isColorForm ^true! ! !ColorForm methodsFor: 'testing' stamp: 'ar 2/10/2004 17:18'! isTranslucent "Answer whether this form may be translucent" ^true! ! !ColorForm methodsFor: 'testing' stamp: 'JuanVuletich 10/12/2010 12:44'! mightBeTranslucent "Answer whether this form may be translucent" ^true! ! !ColorForm methodsFor: 'private' stamp: 'jm 11/16/97 09:07'! clearColormapCache cachedDepth := nil. cachedColormap := nil. ! ! !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: '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: '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: '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: '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 class instanceVariableNames: ''! !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 ! ! !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] ! ! Object subclass: #ColorMap instanceVariableNames: 'shifts masks colors' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Primitives'! !ColorMap commentStamp: 'LaurentLaffont 5/4/2011 21:28' prior: 0! 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: 'accessing' stamp: 'ar 1/16/2000 15:54'! alphaMask ^masks at: 4! ! !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 ^shifts at: 4! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:31'! alphaShift: value shifts at: 4 put: value! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:39'! at: index ^colors at: index! ! !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:31'! blueMask ^masks at: 3! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:31'! blueMask: value masks at: 3 put: value! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:31'! blueShift ^shifts at: 3! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:32'! blueShift: value shifts at: 3 put: value! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 2/10/2000 17:12'! colors ^colors! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:32'! greenMask ^masks at: 2! ! !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:32'! greenShift ^shifts at: 2! ! !ColorMap methodsFor: 'accessing' stamp: 'ar 1/16/2000 15:36'! greenShift: value shifts at: 2 put: value.! ! !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 5/27/2000 19:16'! masks ^masks! ! !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:37'! redShift ^shifts at: 1! ! !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 20:48'! rgbaBitMasks "Return the rgba bit masks for the receiver" ^masks asArray with: shifts collect:[:m :s| m bitShift: s]! ! !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: '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: '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: '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: '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: 'testing' stamp: 'ar 5/25/2000 19:41'! isColormap ^true! ! !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: 'testing' stamp: 'ar 5/27/2000 19:06'! isIndexed "Return true if the receiver uses a lookup mechanism for pixel mapping" ^colors notNil! ! !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 class instanceVariableNames: ''! !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: '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: '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)! ! !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: 'ar 1/16/2000 16:02'! shifts: shiftArray masks: maskArray ^self shifts: shiftArray masks: maskArray colors: nil.! ! !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! ! Canvas subclass: #ColorMappingCanvas instanceVariableNames: 'myCanvas' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Support'! !ColorMappingCanvas commentStamp: 'LaurentLaffont 2/23/2011 20:17' prior: 0! 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: 'accessing' stamp: 'ar 6/22/1999 17:40'! clipRect ^myCanvas clipRect! ! !ColorMappingCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 17:39'! depth ^myCanvas depth! ! !ColorMappingCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 17:39'! extent ^myCanvas extent! ! !ColorMappingCanvas methodsFor: 'accessing' stamp: 'ar 6/24/1999 17:54'! form ^myCanvas form! ! !ColorMappingCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 17:39'! origin ^myCanvas origin! ! !ColorMappingCanvas methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 5/4/2012 16:47'! encryptedParagraph: paragraph bounds: bounds color: c "Draw the given paragraph" myCanvas encryptedParagraph: paragraph bounds: bounds color: (self mapColor: c)! ! !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' 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-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-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: '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-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-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: '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: '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-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: '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: '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-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-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: '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: 'initialization' stamp: 'ar 6/22/1999 18:24'! flush myCanvas flush.! ! !ColorMappingCanvas methodsFor: 'initialization' stamp: 'ar 8/8/2001 14:14'! on: aCanvas myCanvas := aCanvas.! ! !ColorMappingCanvas methodsFor: 'initialization' stamp: 'ar 6/22/1999 18:23'! reset myCanvas reset.! ! !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: 'testing' stamp: 'ar 8/8/2001 14:16'! isShadowDrawing ^myCanvas isShadowDrawing! ! !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: 'private' stamp: 'ar 8/8/2001 14:15'! mapColor: aColor ^aColor! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ColorMappingCanvas class instanceVariableNames: ''! !ColorMappingCanvas class methodsFor: 'instance creation' stamp: 'ar 6/22/1999 18:23'! on: aCanvas ^self new on: aCanvas! ! MorphicModel subclass: #ColorPresenterMorph instanceVariableNames: 'contentMorph labelMorph solidLabelMorph getColorSelector' classVariableNames: 'HatchForm' poolDictionaries: '' category: 'Polymorph-Widgets'! !ColorPresenterMorph commentStamp: 'gvc 5/18/2007 13:38' prior: 0! Displays a colour with alpha against a white, hatched and black background.! !ColorPresenterMorph methodsFor: 'accessing' stamp: 'gvc 9/22/2006 09:25'! contentMorph "Answer the value of contentMorph" ^ contentMorph! ! !ColorPresenterMorph methodsFor: 'accessing' stamp: 'gvc 9/22/2006 09:25'! contentMorph: anObject "Set the value of contentMorph" contentMorph := anObject! ! !ColorPresenterMorph methodsFor: 'accessing' stamp: 'gvc 9/18/2006 15:48'! getColorSelector "Answer the value of getColorSelector" ^ getColorSelector! ! !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'! labelMorph "Answer the value of labelMorph" ^ labelMorph! ! !ColorPresenterMorph methodsFor: 'accessing' stamp: 'gvc 9/18/2006 15:48'! labelMorph: anObject "Set the value of labelMorph" labelMorph := anObject! ! !ColorPresenterMorph methodsFor: 'accessing' stamp: 'gvc 9/18/2006 16:17'! solidLabelMorph "Answer the value of solidLabelMorph" ^ solidLabelMorph! ! !ColorPresenterMorph methodsFor: 'accessing' stamp: 'gvc 9/18/2006 16:17'! solidLabelMorph: anObject "Set the value of solidLabelMorph" solidLabelMorph := anObject! ! !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: '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: '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: '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: 'as yet unclassified' stamp: 'gvc 9/18/2006 16:20'! newLabelMorph "Answer a new label morph" ^Morph new! ! !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: '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 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 class instanceVariableNames: ''! !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)! ! !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! ! DialogWindow subclass: #ColorSelectorDialogWindow instanceVariableNames: 'selectedColor hsvaMorph' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Windows'! !ColorSelectorDialogWindow commentStamp: 'gvc 5/18/2007 13:35' prior: 0! Standard dialog for selecting a colour by HSVA colour selector, picking from the screen or editing of values.! !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: 'accessing' stamp: 'gvc 9/22/2006 10:04'! hsvaMorph "Answer the value of hsvaMorph" ^ hsvaMorph! ! !ColorSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 9/22/2006 10:04'! hsvaMorph: anObject "Set the value of hsvaMorph" hsvaMorph := anObject! ! !ColorSelectorDialogWindow methodsFor: 'accessing' stamp: 'gvc 9/22/2006 09:49'! selectedColor "Answer the value of selectedColor" ^ selectedColor! ! !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/22/2006 16:30'! alpha "Answer the alpha value of the selected color." ^(self selectedColor alpha * 255) asInteger! ! !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: '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: '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 16:38'! brightness "Answer the brightness value of the selected color." ^(self selectedColor brightness * 255) asInteger! ! !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: '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: '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:30'! green "Answer the green value of the selected color." ^(self selectedColor green * 255) asInteger! ! !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: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: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 10:06'! initialize "Initialize the receiver." self basicSelectedColor: Color blue. super initialize. self selectedColor: self 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: 'AlainPlantec 10/19/2010 20:25'! newColorPickerButtonMorph "Answer a button to enable picking of colour." ^self newButtonFor: self getState: nil action: #pickColor arguments: nil getEnabled: nil labelForm: ((self theme eyedropperIcon) scaledIntoFormOfSize: 16) help: 'Pick a color from the screen' translated! ! !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: '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/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: 'IgorStasenko 1/2/2012 19:02'! pickColor "Pick a colour from the screen." |p d c h| h := self activeHand. h showTemporaryCursor: self theme 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: '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: '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: '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: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)! ! ClassTestCase subclass: #ColorTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Tests-Primitives'! !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: '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: '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: '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.! ! !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: 'tests' stamp: 'sd 6/16/2006 13:12'! testPrintHtmlString "self debug: #testPrintHtmlString" self shouldnt: [Color white printHtmlString ] raise: Error. self assert: Color white printHtmlString = 'FFFFFF'. self assert: Color red printHtmlString = 'FF0000'. self assert: Color black printHtmlString = '000000'.! ! Object subclass: #CombinedChar instanceVariableNames: 'codes combined' classVariableNames: 'Compositions Decompositions Diacriticals' poolDictionaries: '' category: 'Kernel-BasicObjects'! !CombinedChar commentStamp: 'StephaneDucasse 3/27/2010 21:50' prior: 0! Compositions classVar is a: combined instVar is a ! !CombinedChar methodsFor: 'accessing' stamp: 'StephaneDucasse 3/27/2010 21:51'! base ^ codes first ! ! !CombinedChar methodsFor: 'accessing' stamp: 'StephaneDucasse 3/27/2010 21:51'! combined ^ combined ! ! !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 instanceVariableNames: ''! !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: '*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: '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. ! ! Object subclass: #CommandLineArguments instanceVariableNames: 'arguments' classVariableNames: '' poolDictionaries: '' category: 'System-CommandLine'! !CommandLineArguments commentStamp: '' prior: 0! 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 5/2/2012 12:33'! allFilesWithExtension: anExtension ^ self arguments select: [ :arg| arg endsWith: anExtension ]! ! !CommandLineArguments methodsFor: 'accessing' stamp: 'CamilloBruni 5/1/2012 19:57'! argumentAt: index ^ arguments at: index ! ! !CommandLineArguments methodsFor: 'accessing' stamp: 'CamilloBruni 4/28/2012 19:42'! arguments ^ arguments! ! !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: '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: '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: 'initialize-release' stamp: 'CamilloBruni 5/1/2012 20:01'! initializeWithArguments: aCollection super initialize. arguments := aCollection.! ! !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 5/1/2012 20:50'! hasArguments ^ arguments size > 0! ! !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: '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/2/2012 14:07'! includesSubCommand: aName self withFirstArgument: [ :arg| arg = aName ifTrue: [ ^ true ]]. ^ false! ! !CommandLineArguments methodsFor: 'testing' 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 12/4/2012 19:49'! longOptionAt: aString ^ self longOptionAt: aString ifAbsent: [ Error signal: 'Could not find long-form option: ', aString ]! ! !CommandLineArguments methodsFor: 'testing' stamp: 'CamilloBruni 12/4/2012 19:50'! longOptionAt: aString ifAbsent: absentBlock | option optionStart | optionStart := '--', aString, '='. option := self arguments detect: [ :arg| arg beginsWith: optionStart ] ifNone: [ ^ absentBlock value ]. ^ (option splitOn: '=') second! ! !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 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 class instanceVariableNames: 'singleton'! !CommandLineArguments class methodsFor: 'instance creation' stamp: 'CamilloBruni 5/2/2012 11:41'! default ^ singleton ifNil: [singleton := self new initialize]! ! !CommandLineArguments class methodsFor: 'instance creation' stamp: 'CamilloBruni 5/1/2012 20:00'! withArguments: aCollection ^ self basicNew initializeWithArguments: aCollection; yourself! ! TestCase subclass: #CommandLineArgumentsTest instanceVariableNames: 'commandLine' classVariableNames: '' poolDictionaries: '' category: 'Tests-System-CommandLine'! !CommandLineArgumentsTest commentStamp: 'AdrienBarreau 2/12/2011 15:55' prior: 0! 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: '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: 'running' stamp: 'CamilloBruni 5/2/2012 12:31'! setUp commandLine := CommandLineArguments withArguments: self parameters.! ! !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 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/2/2012 12:51'! testAllParameters self assert: self commandLine arguments equals: self parameters! ! !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: 'tests' stamp: 'CamilloBruni 5/1/2012 20:50'! testHasParameters self assert: (self commandLine hasArguments)! ! !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: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.! ! Object subclass: #CommandLineHandler instanceVariableNames: 'commandLine stdout stderr' classVariableNames: '' poolDictionaries: '' category: 'System-CommandLine'! !CommandLineHandler commentStamp: '' prior: 0! 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: $PATH_TO_VM myImage.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: $PATH_TO_VM myImage.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:43'! allHandlers ^ CommandLineHandler allHandlers ! ! !CommandLineHandler methodsFor: 'accessing' stamp: 'CamilloBruni 4/28/2012 19:28'! commandLine ^ commandLine! ! !CommandLineHandler methodsFor: 'accessing' stamp: 'CamilloBruni 4/28/2012 19:28'! commandLine: aCommandLine commandLine := aCommandLine! ! !CommandLineHandler methodsFor: 'accessing' stamp: 'CamilloBruni 5/1/2012 13:42'! commandName ^ self class commandName! ! !CommandLineHandler methodsFor: 'accessing' stamp: 'CamilloBruni 5/1/2012 13:52'! description ^ self class description! ! !CommandLineHandler methodsFor: 'accessing' stamp: 'CamilloBruni 10/13/2012 13:31'! stderr ^ stderr! ! !CommandLineHandler methodsFor: 'accessing' stamp: 'CamilloBruni 4/28/2012 19:47'! stdout ^ stdout! ! !CommandLineHandler methodsFor: 'accessing arguments' stamp: 'CamilloBruni 10/13/2012 13:13'! argumentAt: anInteger ^ self commandLine argumentAt: anInteger! ! !CommandLineHandler methodsFor: 'accessing arguments' stamp: 'CamilloBruni 10/13/2012 13:13'! arguments ^ self commandLine arguments! ! !CommandLineHandler methodsFor: 'accessing arguments' stamp: 'CamilloBruni 10/13/2012 13:13'! hasOption: aString ^ self commandLine hasOption: aString! ! !CommandLineHandler methodsFor: 'accessing arguments' stamp: 'CamilloBruni 10/13/2012 14:07'! optionAt: aString ^ self commandLine optionAt: aString! ! !CommandLineHandler methodsFor: 'accessing arguments' stamp: 'CamilloBruni 12/4/2012 19:52'! optionAt: aString ifAbsent: absentBlock ^ self commandLine optionAt: aString ifAbsent: absentBlock! ! !CommandLineHandler methodsFor: 'actions' stamp: 'CamilloBruni 10/13/2012 15:45'! help "This is a crude default help implementation." self printHelp. Smalltalk isInteractive ifFalse: [ self exitSuccess ]! ! !CommandLineHandler methodsFor: 'activation' stamp: 'CamilloBruni 4/28/2012 19:46'! activate self subclassResponsibility! ! !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: 'initialize-release' stamp: 'CamilloBruni 10/13/2012 13:45'! initialize super initialize. self initializeStdout; initializeStderr. ! ! !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: '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: 'printing' stamp: 'CamilloBruni 12/5/2012 21:24'! printHelp self stderr nextPutAll: self class comment; lf! ! !CommandLineHandler methodsFor: 'testing' stamp: 'CamilloBruni 10/13/2012 15:39'! hasArguments ^ self commandLine hasArguments! ! !CommandLineHandler methodsFor: 'utility' stamp: 'CamilloBruni 4/29/2012 16:33'! << aString ^ self stdout nextPutAll: aString; yourself! ! !CommandLineHandler methodsFor: 'utility' stamp: 'CamilloBruni 10/13/2012 15:44'! exitFailure ^ self exitFailure: 'Commandline failed'! ! !CommandLineHandler methodsFor: 'utility' stamp: 'CamilloBruni 10/13/2012 15:44'! exitFailure: aMessage Smalltalk isInteractive ifTrue: [ Error signal: aMessage ] ifFalse: [ Smalltalk exitFailure ].! ! !CommandLineHandler methodsFor: 'utility' stamp: 'CamilloBruni 10/13/2012 16:06'! exitSuccess Smalltalk isInteractive ifTrue: [ self inform: self class name, ' finished' ] ifFalse: [ Smalltalk exitSuccess ]! ! !CommandLineHandler methodsFor: 'utility' stamp: 'CamilloBruni 7/25/2012 10:53'! quit Smalltalk exitSuccess.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CommandLineHandler class instanceVariableNames: ''! !CommandLineHandler class methodsFor: 'accessing' stamp: 'CamilloBruni 4/29/2012 17:38'! allHandlers ^ self allSubclasses reject: [ :handler| handler isAbstract ]! ! !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: '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: 'accessing' stamp: 'CamilloBruni 4/29/2012 17:39'! isAbstract ^ self = CommandLineHandler! ! !CommandLineHandler class methodsFor: 'handler selection' stamp: 'CamilloBruni 5/2/2012 14:06'! isResponsibleFor: aCommandLineArguments ^ aCommandLineArguments includesSubCommand: self commandName! ! !CommandLineHandler class methodsFor: 'handler selection' stamp: 'CamilloBruni 4/28/2012 01:51'! priority ^ 0! ! !CommandLineHandler class methodsFor: 'handler selection' stamp: 'CamilloBruni 5/2/2012 11:30'! selectHandlersFor: aCommandLine ^ self allHandlers select: [ :handlerClass| handlerClass isResponsibleFor: aCommandLine ]! ! !CommandLineHandler class methodsFor: 'instance creation' stamp: 'CamilloBruni 5/2/2012 11:25'! activateWith: aCommandLine ^ self new commandLine: (self prepareSubcommand: aCommandLine); activate! ! !CommandLineHandler class methodsFor: 'instance creation' stamp: 'CamilloBruni 10/13/2012 13:18'! commandLine: aCommandLine ^ self new commandLine: aCommandLine; yourself! ! !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! ! TestCase subclass: #CommandLineHandlerTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-System-CommandLine'! !CommandLineHandlerTest methodsFor: 'tests' stamp: 'CamilloBruni 5/2/2012 14:02'! testResponsibilityDefault | args | args := self argumentsWith: #('--help'). self assert: (DefaultCommandLineHandler isResponsibleFor: args). self deny: (BasicCodeLoader isResponsibleFor: args). self deny: (EvaluateCommandLineHandler isResponsibleFor: args).! ! !CommandLineHandlerTest methodsFor: 'tests' stamp: 'CamilloBruni 5/2/2012 14:04'! testResponsibilityEval | args | args := self argumentsWith: #('eval' '1+2'). self assert: (DefaultCommandLineHandler isResponsibleFor: args). self deny: (BasicCodeLoader isResponsibleFor: args). self assert: (EvaluateCommandLineHandler isResponsibleFor: args). args := self argumentsWith: #('-e' '1+2'). self assert: (DefaultCommandLineHandler isResponsibleFor: args). self deny: (BasicCodeLoader isResponsibleFor: args). self assert: (EvaluateCommandLineHandler isResponsibleFor: args). args := self argumentsWith: #('--evaluate' '1+2'). self assert: (DefaultCommandLineHandler isResponsibleFor: args). self deny: (BasicCodeLoader isResponsibleFor: args). self assert: (EvaluateCommandLineHandler isResponsibleFor: args).! ! !CommandLineHandlerTest methodsFor: 'tests' stamp: 'CamilloBruni 5/2/2012 14:02'! testResponsibilitySt | args | args := self argumentsWith: #('/foo/bar/myScript.st'). self assert: (DefaultCommandLineHandler isResponsibleFor: args). self assert: (BasicCodeLoader isResponsibleFor: args). self deny: (EvaluateCommandLineHandler isResponsibleFor: args). args := self argumentsWith: #('st' '/foo/bar/myScript.st'). self assert: (DefaultCommandLineHandler isResponsibleFor: args). self assert: (BasicCodeLoader isResponsibleFor: args). self deny: (EvaluateCommandLineHandler isResponsibleFor: args).! ! !CommandLineHandlerTest methodsFor: 'tests' stamp: 'CamilloBruni 5/2/2012 14:10'! testSelectHandlersCodeLoader | args handlers | args := self argumentsWith: #('/foo/bar/myScript.st'). handlers := CommandLineHandler selectHandlersFor: args. self assert: handlers first = BasicCodeLoader. args := self argumentsWith: #('/foo/bar/myScript.st' '--verbose'). handlers := CommandLineHandler selectHandlersFor: args. self assert: handlers first = BasicCodeLoader.! ! !CommandLineHandlerTest methodsFor: 'utility' stamp: 'CamilloBruni 5/2/2012 14:01'! argumentsWith: aCollection ^ CommandLineArguments withArguments: aCollection! ! HDTestReport subclass: #CommandLineTestRunner instanceVariableNames: 'stderr stdout currentTest maxTest shouldSerializeError' classVariableNames: '' poolDictionaries: '' category: 'SUnit-UI'! !CommandLineTestRunner commentStamp: '' prior: 0! I am command line test runner. I run a TestSuite and outpout the progress in a terminal friendly way.! !CommandLineTestRunner methodsFor: 'accessing' stamp: 'abc 10/20/2012 13:03'! shouldSerializeError ^ shouldSerializeError! ! !CommandLineTestRunner methodsFor: 'accessing' stamp: 'abc 10/20/2012 13:03'! shouldSerializeError: aBoolean shouldSerializeError := aBoolean.! ! !CommandLineTestRunner methodsFor: 'accessing' stamp: 'CamilloBruni 2/10/2013 14:58'! stderr ^ (stderr isNil or: [ stderr closed ]) ifTrue: [ stderr := VTermOutputDriver stderr ].! ! !CommandLineTestRunner methodsFor: 'accessing' stamp: 'CamilloBruni 2/10/2013 14:58'! stdout ^ (stdout isNil or: [ stdout closed ]) ifTrue: [ stdout := VTermOutputDriver stdout ].! ! !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: '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: '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: 'initialize-release' stamp: 'CamilloBruni 2/10/2013 14:48'! initialize super initialize. shouldSerializeError := false.! ! !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: '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: 'printing' stamp: 'CamilloBruni 2/10/2013 14:49'! printTestCase: aTestCase self stderr startOfLine; clearToEnd; green; print: aTestCase; clear. self printProgress.! ! !CommandLineTestRunner methodsFor: 'running' stamp: 'abc 10/19/2012 15:45'! done ! ! !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: 'running' stamp: 'abc 10/19/2012 15:20'! setUp currentTest := 0. maxTest := suite tests size.! ! !CommandLineTestRunner methodsFor: 'running' stamp: 'abc 10/19/2012 15:36'! tearDown self printReport! ! UIManager subclass: #CommandLineUIManager instanceVariableNames: 'doNotQuitOnRestart uiManager' classVariableNames: 'SnapshotErrorImage' poolDictionaries: '' category: 'UIManager'! !CommandLineUIManager methodsFor: 'accessing' stamp: 'CamilloBruni 2/13/2012 21:23'! headlessManager self class == CommandLineUIManager ifFalse: [ ^ self ]. ^ CommandLineUIManager replacing: uiManager! ! !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: 'accessing' stamp: 'CamilloBruni 2/13/2012 18:40'! stdin ^ FileStream stdin! ! !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 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: 'display' stamp: 'CamilloBruni 2/9/2012 00:21'! checkForNewDisplaySize "do nothing"! ! !CommandLineUIManager methodsFor: 'display' stamp: 'CamilloBruni 2/9/2012 00:21'! newDisplayDepthNoRestore: pixelSize "do nothing" ! ! !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: 'events' stamp: 'CamilloBruni 2/13/2012 19:11'! onPrimitiveError: aString " log error and quit " ^ self quitFrom: thisContext sender withMessage: aString! ! !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: 'initialize-release' stamp: 'CamilloBruni 2/9/2012 00:22'! initialize doNotQuitOnRestart := false.! ! !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 TEasilyThemed' stamp: 'SeanDeNigris 1/29/2013 15:40'! abort: aStringOrText self abort: aStringOrText title: 'Error'.! ! !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: '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: '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: 'ui TEasilyThemed' stamp: 'ChristopheDemarey 1/3/2013 11:42'! deny: aStringOrText "Open a denial 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: 'ChristopheDemarey 1/3/2013 11:43'! proceed: aStringOrText "Open a proceed dialog."! ! !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: 'ui TEasilyThemed' stamp: 'ChristopheDemarey 1/3/2013 11:43'! question: aStringOrText "Open a question dialog."! ! !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: 'ui TEasilyThemed' stamp: 'ChristopheDemarey 1/3/2013 11:43'! questionWithoutCancel: aStringOrText "Open a question 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 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'! textEntry: aStringOrText title: aString "Open a text entry dialog."! ! !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 2/14/2012 09:59'! choose: questionsAnswerDict title: queryString ! ! !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: '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: '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: 'ui requests' stamp: 'CamilloBruni 2/13/2012 18:29'! 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. self logYellowDuring: logBlock. Transcript show: aString; cr.! ! !CommandLineUIManager methodsFor: 'ui requests' stamp: 'CamilloBruni 8/30/2012 16:19'! informUserDuring: aBlock self displayProgress: '' from: 1 to: 100 during: aBlock! ! !CommandLineUIManager methodsFor: 'ui requests' stamp: 'SeanDeNigris 6/11/2012 11:28'! progressInitiationExceptionDefaultAction: anException | result | result := anException workBlock value: DummySystemProgressItem new. anException resume: result! ! !CommandLineUIManager methodsFor: 'ui requests' stamp: 'CamilloBruni 5/26/2012 13:08'! syntaxErrorNotificationDefaultAction: aSyntaxErrorNotification "log the syntax notificaiton and print a nicely formatted and colored syntax error on stderr" | contents position errorMessage lineNumber maxLineNumberSize errorLine | "log the error" Smalltalk logDuring: [ :logger | logger print: aSyntaxErrorNotification; cr. aSyntaxErrorNotification signalerContext errorReportOn: logger ]. "format the error" position := aSyntaxErrorNotification location. contents := aSyntaxErrorNotification errorCode. errorLine := contents lineNumberCorrespondingToIndex: position. "first gather the error title to be able to underline it properly" errorMessage := String streamContents: [ :s| s nextPutAll: 'Syntax Error on line '; print: errorLine; nextPutAll: ': '; print: aSyntaxErrorNotification errorMessage]. self logRedDuring: [ :s| s nextPutAll: errorMessage; cr; nextPutAll: ('' padLeftTo: errorMessage size with: $=); cr]. "print each source line and mark the found syntax error" maxLineNumberSize := (contents lines size) asString size. lineNumber := 0. contents lineIndicesDo: [:start :endWithoutDelimiters :end | lineNumber := lineNumber + 1. self logColored: (lineNumber == errorLine ifTrue:['31'] ifFalse:['33']) during: [ :s| "0 pad the line numbers to the same size" s nextPutAll: ( lineNumber asString padLeftTo: maxLineNumberSize with: $0); nextPutAll: ': ' ]. self stderr nextPutAll: (contents copyFrom: start to: endWithoutDelimiters); cr. "print the marker under the error line" (lineNumber == errorLine) ifTrue: [ self logRedDuring: [ :s| s nextPutAll:( '_^_' padLeftTo: position - start + maxLineNumberSize + 4); cr]]]. "in noninteractive mode simply quit" ^ self exitFailure! ! !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/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/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: 'utils' stamp: 'IgorStasenko 3/12/2012 17:49'! logDuring: aBlock Smalltalk logStdErrorDuring: [ :stderr | aBlock value: stderr ] ! ! !CommandLineUIManager methodsFor: 'utils' stamp: 'CamilloBruni 2/9/2012 12:55'! logGreenDuring: aBlock ^ self logColored: '32' during: aBlock! ! !CommandLineUIManager methodsFor: 'utils' stamp: 'CamilloBruni 2/9/2012 12:53'! logRedDuring: aBlock ^ self logColored: '31' during: aBlock! ! !CommandLineUIManager methodsFor: 'utils' stamp: 'CamilloBruni 2/9/2012 12:55'! logYellowDuring: aBlock ^ self logColored: '33' during: aBlock! ! !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: 'private' stamp: 'SeanDeNigris 1/29/2013 15:51'! logTitle: aString andDescription: aStringOrText to: aStream aStream nextPutAll: aString; nextPutAll: ': '; nextPutAll: aStringOrText asString; cr.! ! !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 class instanceVariableNames: ''! !CommandLineUIManager class methodsFor: 'accessing' stamp: 'CamilloBruni 2/13/2012 21:25'! snapshotErrorImage ^ SnapshotErrorImage == true! ! !CommandLineUIManager class methodsFor: 'accessing' stamp: 'CamilloBruni 2/13/2012 21:25'! snapshotErrorImage: aBoolean SnapshotErrorImage := aBoolean! ! !CommandLineUIManager class methodsFor: 'as yet unclassified' 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! ! CommentWindow subclass: #CommentFalsePositiveWindow instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Manifest-CriticBrowser'! !CommentFalsePositiveWindow commentStamp: '' prior: 0! To enter comment for false positives.! !CommentFalsePositiveWindow methodsFor: 'initialization' stamp: 'SimonAllier 2/1/2013 15:06'! initializeForFalsePositive self initializeTextForFalsePositive. okCancelToolBarModel okAction: [ | manifestBuilder rId rV| rId := rule class uniqueIdentifierName. rV := rule class identifierMinorVersionNumber. manifestBuilder := BuilderManifest of: critic. (manifestBuilder hasFalsePositiveOf: rId version: rV) ifFalse: [manifestBuilder installFalsePositiveOf: rId version: rV]. manifestBuilder addFalsePositive: critic withComment: (commentInputFieldModel getText) of: rId version: rV]! ! !CommentFalsePositiveWindow methodsFor: 'initialization' stamp: 'SimonAllier 2/8/2013 16:43'! initializeTextForFalsePositive | ruleId versionId manifestBuilder| manifestBuilder := BuilderManifest of: critic. ruleId := rule class uniqueIdentifierName. versionId := rule class identifierMinorVersionNumber. (manifestBuilder hasFalsePositiveOf: ruleId version: versionId) ifFalse: [^ self] . commentInputFieldModel text: ((BuilderManifest of: critic) commentOfFalsePositive: critic onRule: ruleId version: versionId) ! ! !CommentFalsePositiveWindow methodsFor: 'initialization' stamp: 'Sd 11/30/2012 16:43'! initializeWidgets ^ #()! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CommentFalsePositiveWindow class instanceVariableNames: ''! !CommentFalsePositiveWindow class methodsFor: 'instance creation' stamp: 'StephaneDucasse 11/21/2012 17:49'! openOnCritic: aCritc onRule: aRule self new critic: aCritc; rule: aRule; initializeForFalsePositive; openWithSpec. ! ! ParseNode subclass: #CommentNode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-ParseNodes'! !CommentNode methodsFor: 'visiting' stamp: 'eem 9/6/2009 12:33'! accept: aVisitor ^aVisitor visitCommentNode: self! ! CommentWindow subclass: #CommentToDoWindow instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Manifest-CriticBrowser'! !CommentToDoWindow commentStamp: '' prior: 0! To enter comment for todos.! !CommentToDoWindow methodsFor: 'initialization' stamp: 'SimonAllier 2/1/2013 15:06'! initializeForToDo self initializeTextForToDo. okCancelToolBarModel okAction: [ | manifestBuilder rId rV| rId := rule class uniqueIdentifierName. rV := rule class identifierMinorVersionNumber. manifestBuilder := BuilderManifest of: critic. (manifestBuilder hasToDoOf: rId version: rV) ifFalse: [manifestBuilder installToDoOf: rId version: rV]. manifestBuilder addToDo: critic withComment: (commentInputFieldModel getText) of: rId version: rV]! ! !CommentToDoWindow methodsFor: 'initialization' stamp: 'SimonAllier 2/1/2013 15:06'! initializeTextForToDo | ruleId versionId manifestBuilder| manifestBuilder := BuilderManifest of: critic. ruleId := rule class uniqueIdentifierName. versionId := rule class identifierMinorVersionNumber. (manifestBuilder hasToDoOf: ruleId version: versionId) ifFalse: [^ self] . commentInputFieldModel text: ((BuilderManifest of: critic) commentOfToDo: critic onRule: ruleId version: versionId) ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CommentToDoWindow class instanceVariableNames: ''! !CommentToDoWindow class methodsFor: 'instance creation' stamp: 'StephaneDucasse 11/21/2012 17:49'! openOnCritic: aCritc onRule: aRule self new critic: aCritc; rule: aRule; initializeForToDo; openWithSpec. ! ! ComposableModel subclass: #CommentWindow instanceVariableNames: 'okCancelToolBarModel commentInputFieldModel rule critic' classVariableNames: '' poolDictionaries: '' category: 'Manifest-CriticBrowser'! !CommentWindow commentStamp: '' prior: 0! A simple dialog to get a comment for the situation.! !CommentWindow methodsFor: 'accessing' stamp: 'SimonAllier 3/30/2012 14:58'! commentInputField ^ commentInputFieldModel! ! !CommentWindow methodsFor: 'accessing' stamp: 'SimonAllier 3/30/2012 15:50'! critic: aCritic critic := aCritic! ! !CommentWindow methodsFor: 'accessing' stamp: 'SimonAllier 3/30/2012 14:58'! okCancelToolBar ^ okCancelToolBarModel! ! !CommentWindow methodsFor: 'accessing' stamp: 'SimonAllier 3/30/2012 15:50'! rule: aRule rule := aRule! ! !CommentWindow methodsFor: 'initialization' stamp: 'SimonAllier 5/9/2012 16:42'! initialize super initialize. okCancelToolBarModel := self instantiate: OkCancelToolbar. commentInputFieldModel := self instantiate: TextModel. "commentInputFieldModel removeEntryCompletion " ! ! !CommentWindow methodsFor: 'initialization' stamp: 'Sd 11/29/2012 14:37'! initializeWidgets ^ self ! ! !CommentWindow methodsFor: 'protocol' stamp: 'StephaneDucasse 11/21/2012 17:48'! initialExtent ^ (465@225)! ! !CommentWindow methodsFor: 'protocol' stamp: 'SimonAllier 3/30/2012 16:02'! okAction: aBlock ^ okCancelToolBarModel okAction: aBlock! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CommentWindow class instanceVariableNames: ''! !CommentWindow class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/15/2013 13:29'! defaultSpec ^ { #Panel. #useProportionalLayout. #add:. {{#model . #commentInputField } . #layout: . #(FrameLayout bottomOffset: -25)}. #add:. {{#model. #okCancelToolBar } . #layout:. #(FrameLayout topFraction: 1 topOffset: -25)} . #hSpaceFill . #vSpaceFill }! ! !CommentWindow class methodsFor: 'specs' stamp: 'SimonAllier 3/30/2012 15:04'! title ^ 'Comment'! ! ByteArray variableByteSubclass: #CompiledMethod instanceVariableNames: '' classVariableNames: 'LargeFrame SmallFrame' poolDictionaries: '' category: 'Kernel-Methods'! !CompiledMethod commentStamp: 'ls 7/5/2003 13:48' prior: 0! 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: '*AST-Core' stamp: 'CamilloBruni 12/9/2011 13:59'! ast ^ ASTCache at: self! ! !CompiledMethod methodsFor: '*AST-Core' stamp: 'CamilloBruni 2/20/2012 15:34'! hasPragmaNamed: aSymbol ^ self pragmas anySatisfy: [ :pragma | pragma keyword = aSymbol ]! ! !CompiledMethod methodsFor: '*AST-Core' stamp: 'CamilloBruni 2/17/2012 14:33'! recompile ^ self methodClass recompile: self selector! ! !CompiledMethod methodsFor: '*Compiler-Kernel' stamp: 'MarcusDenker 2/4/2013 16:01'! compilerClass ^self methodClass ifNil: [Smalltalk compilerClass] ifNotNil: [:class | class compilerClass].! ! !CompiledMethod methodsFor: '*Compiler-Kernel' stamp: 'md 2/16/2006 17:08'! decompile "Return the decompiled parse tree that represents self" | class selector | class := self methodClass ifNil: [Object]. selector := self selector ifNil: [self defaultSelector]. ^class decompilerClass new decompile: selector in: class method: self.! ! !CompiledMethod methodsFor: '*Compiler-Kernel' stamp: 'md 2/16/2006 13:26'! decompileString ^self decompile decompileString! ! !CompiledMethod methodsFor: '*Compiler-Kernel' stamp: 'eem 8/12/2010 13:52'! decompileWithTemps "Return the decompiled parse tree that represents self, but get the temp names by compiling the sourcecode..." | class selector | class := self methodClass ifNil: [Object]. selector := self selector ifNil: [self defaultSelector]. (self fileIndex > 0 and: [(SourceFiles at: self fileIndex) isNil]) ifTrue: [ "Emergency or no source file -- decompile without temp names " ^self decompile. ]. ^((self decompilerClass new withTempNames: self methodNode schematicTempNamesString) decompile: selector in: class method: self)! ! !CompiledMethod methodsFor: '*Compiler-Kernel' stamp: 'eem 9/5/2009 14:17'! decompilerClass ^self compilerClass decompilerClass! ! !CompiledMethod methodsFor: '*Compiler-Kernel' stamp: 'MarcusDenker 4/27/2012 18:22'! methodNode "Return the parse tree that represents self" | aClass source | aClass := self methodClass. source := self sourceCode. ^(aClass parserClass new parse: source class: aClass) sourceText: source; yourself! ! !CompiledMethod methodsFor: '*Compiler-Kernel' stamp: 'MarcusDenker 2/2/2013 16:19'! parserClass ^self compilerClass parserClass! ! !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: '*Fuel' stamp: 'MartinDias 3/28/2012 16:11'! bytecodesHash "Answer a 16-bit checksum of the bytecodes." ^ self crc16from: self initialPC to: self endPC! ! !CompiledMethod methodsFor: '*Fuel' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^aGeneralMapper visitCompiledMethod: self! ! !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: '*FuelTests' stamp: 'MarianoMartinezPeck 4/20/2012 21:18'! isEqualRegardlessTrailerTo: aCompiledMethod ^ (self copyWithTrailerBytes: CompiledMethodTrailer empty) = (aCompiledMethod copyWithTrailerBytes: CompiledMethodTrailer empty)! ! !CompiledMethod methodsFor: '*FuelTests' stamp: 'MarianoMartinezPeck 4/20/2012 21:23'! sizeWithoutTrailer ^ self trailer endPC! ! !CompiledMethod methodsFor: '*GroupManagerUI' stamp: 'BenjaminVanRyseghem 2/25/2012 16:00'! elementsToAddInAGroup ^ { self }! ! !CompiledMethod methodsFor: '*GroupManagerUI' stamp: 'BenjaminVanRyseghem 2/25/2012 16:36'! prettyName ^ self methodClass printString, '>>#', self selector! ! !CompiledMethod methodsFor: '*NativeBoost-Core' stamp: 'IgorStasenko 11/9/2012 04:13'! forceJIT ^ self primitiveFailed! ! !CompiledMethod methodsFor: '*NativeBoost-Core' stamp: 'Igor.Stasenko 5/18/2010 08:20'! hasNativeCode ^ self trailerKind == #NativeCodeTrailer! ! !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: '*NautilusCommon' stamp: 'BenjaminVanRyseghem 4/7/2011 18:51'! containsFlag ^ self literals includesAnyOf: #( flag flag: ).! ! !CompiledMethod methodsFor: '*NautilusCommon' stamp: 'BenjaminVanRyseghem 4/7/2011 18:50'! containsHalt ^ self literals includesAnyOf: #( halt halt: halt:onCount: haltIf: haltIfNil haltIfShiftPressed haltOnCount: haltOnce haltOnce:).! ! !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: 'BenjaminVanRyseghem 1/18/2012 16:31'! 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 methodDict values detect: [:each | each selector asLowercase = sel ] ifNone: [ nil ]]]! ! !CompiledMethod methodsFor: '*NautilusCommon' stamp: 'CamilloBruni 10/21/2012 23:56'! dragAndDropPrint ^ self printString! ! !CompiledMethod methodsFor: '*NautilusCommon' stamp: 'BenjaminVanRyseghem 4/7/2011 18:10'! hasErrorTest ^ self methodClass methodRaisedError: (self selector)! ! !CompiledMethod methodsFor: '*NautilusCommon' stamp: 'BenjaminVanRyseghem 4/7/2011 18:11'! hasFailedTest ^ self methodClass methodFailed: (self selector)! ! !CompiledMethod methodsFor: '*NautilusCommon' stamp: 'BenjaminVanRyseghem 4/7/2011 18:11'! hasPassedTest ^ self methodClass methodPassed: (self selector)! ! !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: '*NautilusCommon' stamp: 'CamilloBruni 9/13/2012 14:21'! isOverriden self deprecated: 'Use isOverridden with 2 d`s' on: '2012-09-13' in: 'Pharo2.0'. ^ self isOverridden! ! !CompiledMethod methodsFor: '*NautilusCommon' stamp: 'StefanMarr 1/28/2013 22:43'! isTestMethod ^ (self methodClass inheritsFrom: TestCase) and: [ (self selector beginsWith: 'test') or: [ self selector beginsWith: 'should']]! ! !CompiledMethod methodsFor: '*NautilusCommon' stamp: 'BenjaminVanRyseghem 5/12/2011 11:28'! protocol " start to migrate to RING API " ^ self category! ! !CompiledMethod methodsFor: '*NautilusCommon' stamp: 'CamilloBruni 1/30/2013 21:09'! protocol: aString ^ self methodClass organization classify: self selector under: aString! ! !CompiledMethod methodsFor: '*RecentSubmissions'! stamp ^ self timeStamp! ! !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: '*Ring-Core-Kernel' stamp: 'VeronicaUquillas 9/19/2011 16:30'! 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. rgMethod package: (RGContainer packageOfMethod: rgMethod). rgClass addMethod: rgMethod. ^ rgMethod! ! !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: '*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: '*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: '*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: '*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: '*Ring-Core-Kernel' stamp: 'MarianoMartinezPeck 6/26/2012 10:41'! realClass "answer the class that I am installed in" ^ self methodClass! ! !CompiledMethod methodsFor: '*Tools' stamp: 'BenjaminVanRyseghem 1/23/2012 19:57'! browse ^ Smalltalk tools browser fullOnClass: self methodClass selector: self selector! ! !CompiledMethod methodsFor: '*Tools' stamp: 'CamilloBruni 1/30/2013 21:26'! callers ^ SystemNavigation default allCallsOn: self selector! ! !CompiledMethod methodsFor: '*Tools' stamp: 'eem 5/15/2008 13:14'! explorerContents "(CompiledMethod compiledMethodAt: #explorerContents) explore" ^Array streamContents: [:s| | tokens | tokens := Scanner new scanTokens: (self headerDescription readStream skipTo: $"; upTo: $"). 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: '*Tools' stamp: 'CamilloBruni 1/30/2013 21:26'! implementors ^ SystemNavigation default allImplementorsOf: self selector! ! !CompiledMethod methodsFor: '*Tools' stamp: 'ar 9/27/2005 18:32'! 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." ^ CompiledMethodInspector! ! !CompiledMethod methodsFor: '*Tools' stamp: 'CamilloBruni 1/30/2013 21:26'! senders ^ SystemNavigation default allSendersOf: self selector! ! !CompiledMethod methodsFor: '*ast-core' stamp: 'MarcusDenker 11/20/2012 14:48'! parseTree ^(RBExplicitVariableParser parseMethod: self sourceCode onError: [ :msg :pos | ^ nil ]) classBinding: self methodClass binding. ! ! !CompiledMethod methodsFor: '*deprecated20' stamp: 'MarcusDenker 4/29/2012 12:02'! getSourceFor: selector in: class self deprecated: 'just use #sourceCode' on: '29 April 2012' in: 'Pharo 2.0'. ^self sourceCode.! ! !CompiledMethod methodsFor: '*rpackage-core' stamp: 'EstebanLorenzano 6/1/2012 16:48'! handleUnpackaged: anRPackageOrganizer | tmpTrait | tmpTrait := self methodClass traitComposition traitProvidingSelector: self selector. tmpTrait isNil ifFalse: [ (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: '*rpackage-core' stamp: 'tg 3/13/2010 15:13'! isDefinedInPackage: anRPackage ^ anRPackage includesDefinedSelector: self selector ofClass: self methodClass! ! !CompiledMethod methodsFor: '*rpackage-core' stamp: 'tg 3/13/2010 13:50'! isExtensionInPackage: anRPackage ^ anRPackage includesExtensionSelector: self selector ofClass: self methodClass! ! !CompiledMethod methodsFor: '*rpackage-core' stamp: 'CamilloBruni 4/27/2012 17:07'! package ^ self packageFromOrganizer: RPackage organizer! ! !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: '*tools-debugger' stamp: 'emm 5/30/2002 09:22'! hasBreakpoint ^BreakpointManager methodHasBreakpoint: self! ! !CompiledMethod methodsFor: 'accessing' stamp: 'md 3/31/2007 19:45'! classBinding ^(self literalAt: self numLiterals) ! ! !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: '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: '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: 'accessing' stamp: 'Igor.Stasenko 12/20/2009 19:04'! endPC "Answer the index of the last bytecode." ^ self trailer endPC ! ! !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: '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: '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: '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: 'AdrianKuhn 12/22/2009 07:25'! methodClass "answer the class that I am installed in" ^self numLiterals > 0 ifTrue: [ (self literalAt: self numLiterals) value ] ifFalse: [ nil ]! ! !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: 'eem 11/29/2008 11:38'! methodClassAssociation "answer the association to the class that I am installed in, or nil if none." ^self literalAt: self numLiterals! ! !CompiledMethod methodsFor: 'accessing' stamp: 'GuillermoPolito 5/25/2010 16:26'! methodClassAssociation: aBinding "sets the association to the class that I am installed in" ^self literalAt: self numLiterals put: aBinding.! ! !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'! numLiterals "Answer the number of literals used by the receiver." ^ (self header bitShift: -9) bitAnd: 16rFF! ! !CompiledMethod methodsFor: 'accessing'! numTemps "Answer the number of temporary variables used by the receiver." ^ (self header bitShift: -18) bitAnd: 16r3F! ! !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: 'accessing' stamp: 'EstebanLorenzano 1/15/2013 18:56'! 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) methodDict at: selector. ! ! !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: '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: '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: '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: 'accessing'! 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: 'accessing' stamp: 'md 1/20/2006 16:09'! scanner ^ InstructionStream on: self! ! !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: '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: '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: '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: 'accessing' stamp: 'MarcusDenker 12/21/2012 12:06'! sourceCode "Retrieve or reconstruct the source code for this method." | trailer source class | trailer := self trailer. class := self methodClass. trailer sourceCode ifNotNil: [:code | ^ code ]. trailer hasSourcePointer ifFalse: [ "No source pointer -- decompile without temp names" ^ (class decompilerClass new decompile: self selector in: class method: self) decompileString]. "Situation normal; read the sourceCode from the file" source := [self getSourceFromFile] on: Error "An error can happen here if, for example, the changes file has been truncated by an aborted download. The present solution is to ignore the error and fall back on the decompiler. A more thorough solution should probably trigger a systematic invalidation of all source pointers past the end of the changes file. Consider that, as time goes on, the changes file will eventually grow large enough to cover the lost code, and then instead of falling into this error case, random source code will get returned." do: [ :ex | ex return: nil]. source isEmptyOrNil ifTrue: [ "Something really wrong -- decompile blind (no temps)" ^ (class decompilerClass new decompile: self selector in: class method: self) decompileString]. ^source! ! !CompiledMethod methodsFor: 'accessing' stamp: 'Igor.Stasenko 12/20/2009 19:02'! trailer "Answer the receiver's trailer" ^ CompiledMethodTrailer new method: self ! ! !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: 'accessing-pragmas & properties' stamp: 'eem 11/29/2008 16:36'! pragmas | selectorOrProperties | ^(selectorOrProperties := self penultimateLiteral) isMethodProperties ifTrue: [selectorOrProperties pragmas] ifFalse: [#()]! ! !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: '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: '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-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: '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: '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: 'authors' 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: 'class accessing' stamp: 'stephane.ducasse 3/30/2009 22:43'! category ^self methodClass organization categoryOfElement:self selector! ! !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: 'closures' stamp: 'md 1/20/2006 16:09'! method "polymorphic with closure" ^ self! ! !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: 'comparing' stamp: 'MarianoMartinezPeck 7/25/2012 14:24'! equivalentTo: aCompiledMethod | parseTree | ^self = aCompiledMethod or: [self class == aCompiledMethod class and: [self numArgs = aCompiledMethod numArgs and: [self numLiterals = aCompiledMethod numLiterals and: [parseTree := self decompile. (parseTree isKindOf: MethodNode) ifTrue: [parseTree asString = aCompiledMethod decompile asString "Standard compiler"] ifFalse: [parseTree = aCompiledMethod decompile "RB parse trees, we hope"]]]]]! ! !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: '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: '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: '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: 'debugger support' stamp: 'eem 6/5/2008 10:32'! abstractPCForConcretePC: concretePC "Answer the abstractPC matching concretePC." | abstractPC scanner client | self flag: 'belongs in DebuggerMethodMap?'. abstractPC := 1. scanner := InstructionStream on: self. client := InstructionClient new. [(scanner atEnd or: [scanner pc >= concretePC]) ifTrue: [^abstractPC]. abstractPC := abstractPC + 1. scanner interpretNextInstructionFor: client. true] whileTrue! ! !CompiledMethod methodsFor: 'debugger support' stamp: 'eem 6/3/2008 16:15'! blockExtentsInto: aDictionary from: initialPC to: endPC scanner: scanner numberer: numbererBlock "Support routine for startpcsToBlockExtents" | extentStart blockSizeOrLocator | self flag: 'belongs in DebuggerMethodMap'. 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! ! !CompiledMethod methodsFor: 'debugger support' stamp: 'MarcusDenker 11/16/2012 13:45'! debuggerMap ^self compilerClass debuggerMethodMapForMethod: self.! ! !CompiledMethod methodsFor: 'debugger support' stamp: 'eem 6/29/2009 09:48'! mapFromBlockKeys: keys toSchematicTemps: schematicTempNamesString "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! ! !CompiledMethod methodsFor: 'debugger support' stamp: 'eem 6/14/2008 18:58'! pcPreviousTo: pc | scanner client prevPc | self flag: 'belongs in DebuggerMethodMap?'. 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: 'debugger support' stamp: 'eem 6/29/2009 09:50'! startpcsToBlockExtents "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 | self flag: 'belongs in DebuggerMethodMap'. index := 0. ^self blockExtentsInto: Dictionary new from: self initialPC to: self endPC scanner: (InstructionStream on: self) numberer: [| value | value := index. index := index + 2. value]! ! !CompiledMethod methodsFor: 'debugger support' stamp: 'eem 7/1/2009 10:09'! 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)"! ! !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: '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: '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: 'literals' stamp: 'eem 5/6/2008 11:28'! allLiterals ^self literals! ! !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: '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 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: 'literals'! 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: '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: '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: 'literals'! literalAt: index "Answer the literal indexed by the argument." ^self objectAt: index + 1! ! !CompiledMethod methodsFor: 'literals'! 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: 'literals' stamp: 'eem 4/30/2009 18:03'! literalStrings | 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: '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: '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: 'literals'! 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: 'literals'! 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: '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: 'literals' stamp: 'dvf 11/12/2002 00:44'! sendsSelector: aSymbol ^ self messages includes: aSymbol! ! !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: 'printing' stamp: 'MarcusDenker 4/29/2012 10:33'! asString ^self sourceCode! ! !CompiledMethod methodsFor: 'printing' stamp: 'sw 7/29/2002 02:24'! dateMethodLastSubmitted "Answer a Date object indicating when a method was last submitted. If there is no date stamp, return nil" "(CompiledMethod compiledMethodAt: #dateMethodLastSubmitted) dateMethodLastSubmitted" | aStamp tokens | aStamp := self timeStamp. tokens := aStamp findBetweenSubStrs: ' '. "space is expected delimiter, but cr is sometimes seen, though of mysterious provenance" ^ tokens size > 1 ifTrue: [[tokens second asDate] ifError: [nil]] ifFalse: [nil]! ! !CompiledMethod methodsFor: 'printing' stamp: 'nice 11/1/2009 22:09'! isSelfEvaluating ^self methodClass notNil and: [(#(#DoIt #DoItIn: nil) includes: self selector) not]! ! !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: '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: '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: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: '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: '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: 'printing'! storeLiteralsOn: aStream forClass: aBehavior "Store the literals referenced by the receiver on aStream, each terminated by a space." | literal | 2 to: self numLiterals + 1 do: [:index | aBehavior storeLiteral: (self objectAt: index) on: aStream. aStream space]! ! !CompiledMethod methodsFor: 'printing'! 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: '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: '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: '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: 'printing' stamp: 'CamilloBruni 5/21/2012 15:21'! 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 findString: 'methodsFor:' startingAt: 1) > 0 ifTrue: [Scanner new scanTokens: preamble] 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: 'printing' stamp: 'MarcusDenker 4/26/2012 11:56'! who "Answer an Array of the class in which the receiver is defined and the selector to which it corresponds." ^{self methodClass. 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: '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: '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: '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: '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: 'scanning' stamp: 'dvf 11/12/2002 00:44'! messagesDo: aBlock ^ self messages do:aBlock.! ! !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: '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: 'scanning'! 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: 'scanning'! scanLongLoad: extension "Answer whether the receiver contains a long load whose extension is the argument." | scanner | scanner := InstructionStream on: self. ^scanner scanFor: [:instr | instr = 128 and: [scanner followingByte = extension]]! ! !CompiledMethod methodsFor: 'scanning'! scanLongStore: extension "Answer whether the receiver contains a long store whose extension is the argument." | scanner | scanner := InstructionStream on: self. ^scanner scanFor: [:instr | (instr = 129 or: [instr = 130]) and: [scanner followingByte = extension]]! ! !CompiledMethod methodsFor: 'scanning'! scanVeryLongLoad: extension offset: offset "Answer whether the receiver contains a long load whose extension is the argument." | scanner | scanner := InstructionStream on: self. ^ scanner scanFor: [:instr | (instr = 132 and: [scanner followingByte = extension]) and: [scanner thirdByte = offset]]! ! !CompiledMethod methodsFor: 'scanning' stamp: 'eem 6/11/2008 17:07'! scanVeryLongStore: extension offset: offset "Answer whether the receiver contains a long load with the given offset. Note that the constant +32 is the known difference between a store and a storePop for instVars, and it will always fail on literal variables, but these only use store (followed by pop) anyway." | scanner | scanner := InstructionStream on: self. ^scanner scanFor: [:instr | | ext | (instr = 132 and: [(ext := scanner followingByte) = extension or: ["might be a store/pop into rcvr" ext = (extension+32)]]) and: [scanner thirdByte = offset]]! ! !CompiledMethod methodsFor: 'scanning'! 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: '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: '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: 'source code management' stamp: 'MarcusDenker 12/21/2012 12:05'! argumentNames "Return an array with the argument names of the method's selector" | keywords stream argumentNames delimiters | delimiters := {Character space. Character cr}. keywords := self selector keywords. stream := self sourceCode readStream. argumentNames := OrderedCollection new. keywords do: [ :each | | argumentName | stream match: each. [stream peekFor: Character space] whileTrue. argumentName := ReadWriteStream on: String new. [(delimiters includes: stream peek) or: [stream peek isNil]] whileFalse: [argumentName nextPut: stream next]. argumentName isEmpty ifFalse: [ argumentNames add: argumentName contents trimBoth]]. ^(argumentNames copyFrom: 1 to: self numArgs) asArray! ! !CompiledMethod methodsFor: 'source code management' stamp: 'mf 4/29/2012 13:11'! copyWithSource: aString ^self copyWithTrailerBytes: (CompiledMethodTrailer new sourceCode: aString) ! ! !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 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: 'source code management' stamp: 'hmm 4/26/2000 20:44'! fileIndex ^SourceFiles fileIndexFromSourcePointer: self sourcePointer! ! !CompiledMethod methodsFor: 'source code management' stamp: 'hmm 4/26/2000 20:45'! filePosition ^SourceFiles filePositionFromSourcePointer: self sourcePointer! ! !CompiledMethod methodsFor: 'source code management' stamp: 'StephaneDucasse 3/22/2010 21:15'! getPreambleFrom: aFileStream at: position | writeStream | writeStream := String new writeStream. position to: 0 by: -1 do: [ :p | | c | aFileStream position: p. c := aFileStream basicNext. c == $!! ifTrue: [^ writeStream contents reversed] ifFalse: [writeStream nextPut: c]]! ! !CompiledMethod methodsFor: 'source code management' stamp: 'MarcusDenker 12/22/2012 17:45'! getSource "use #sourceCode instead" ^self sourceCode.! ! !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: '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: 'source code management'! putSource: sourceStr fromParseNode: methodNode class: class category: catName inFile: fileIndex priorMethod: priorMethod ^ self putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble: [:file | class printCategoryChunk: catName on: file priorMethod: priorMethod. file cr]! ! !CompiledMethod methodsFor: 'source code management' stamp: '6/5/97 di'! putSource: sourceStr fromParseNode: methodNode class: class category: catName withStamp: changeStamp inFile: fileIndex priorMethod: priorMethod ^ self putSource: sourceStr fromParseNode: methodNode inFile: fileIndex withPreamble: [:file | class printCategoryChunk: catName on: file withStamp: changeStamp priorMethod: priorMethod. file cr]! ! !CompiledMethod methodsFor: 'source code management' stamp: 'md 4/26/2012 12:03'! putSource: sourceStr fromParseNode: methodNode 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 | (SourceFiles == nil or: [(file := SourceFiles at: fileIndex) == nil]) ifTrue: [^self becomeForward: (self copyWithTempsFromMethodNode: methodNode)]. 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: 'source code management' stamp: 'MarcusDenker 4/29/2012 13:47'! schematicTempNamesString "Answer the schematicTempNames string" ^ self methodNode schematicTempNamesString! ! !CompiledMethod methodsFor: 'source code management' stamp: 'Igor.Stasenko 12/20/2009 19:02'! 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 an scrPointer, and then #become it" | trailer copy | trailer := CompiledMethodTrailer new sourcePointer: srcPointer. copy := self copyWithTrailerBytes: trailer. self becomeForward: copy. ^ copy! ! !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: '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: 'source code management' stamp: 'CamilloBruni 2/28/2012 14:06'! sourceFileStreamIfAbsent: aBlock ^ self sourceFileStream ifNil: aBlock! ! !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: 'source code management' stamp: 'MarcusDenker 4/29/2012 14:06'! tempNames ^self methodNode tempNames.! ! !CompiledMethod methodsFor: 'source code management' stamp: 'MarcusDenker 4/29/2012 13:37'! zapSourcePointer "If receiver has trailer with source pointer, replace it with empty trailer. But do this only if receiver has a trailer with source pointer, but something else" (self trailer hasSourcePointer) ifTrue: [ self becomeForward: (self copyWithTrailerBytes: CompiledMethodTrailer empty) ]! ! !CompiledMethod methodsFor: 'testing' stamp: 'lr 3/14/2010 21:13'! 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: #hottest #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: 'testing' stamp: 'AlexandreBergel 9/14/2011 08:31'! isAbstract "Answer true if I am abstract" ^ self markerOrNil == self class abstractMarker! ! !CompiledMethod methodsFor: 'testing' stamp: 'mada 5/5/2012 11:29'! isBinarySelector ^self selector allSatisfy: [:each | each isSpecial]! ! !CompiledMethod methodsFor: 'testing' stamp: 'md 11/21/2003 12:15'! isCompiledMethod ^ true! ! !CompiledMethod methodsFor: 'testing' stamp: 'al 1/23/2004 13:12'! isConflict ^ self markerOrNil == self class conflictMarker! ! !CompiledMethod methodsFor: 'testing' stamp: 'MarcusDenker 4/29/2011 00:40'! isDeprecated ^ (self sendsSelector: #deprecated:) or: [self sendsSelector: #deprecated:on:in:]! ! !CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:32'! isDisabled ^ self isDisabled: self markerOrNil! ! !CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:32'! isDisabled: marker ^ marker == self class disabledMarker! ! !CompiledMethod methodsFor: 'testing' stamp: 'MarcusDenker 4/29/2012 14:59'! isDoIt ^self selector isDoIt.! ! !CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:32'! isExplicitlyRequired ^ self isExplicitlyRequired: self markerOrNil! ! !CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:32'! isExplicitlyRequired: marker ^ marker == self class explicitRequirementMarker! ! !CompiledMethod methodsFor: 'testing' stamp: 'GuillermoPolito 4/26/2012 11:11'! isExternalCallPrimitive ^self primitive = 120! ! !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: 'testing' stamp: 'NS 3/22/2005 16:32'! isImplicitlyRequired ^ self isImplicitlyRequired: self markerOrNil! ! !CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:32'! isImplicitlyRequired: marker ^ marker == self class implicitRequirementMarker! ! !CompiledMethod methodsFor: 'testing' stamp: 'eem 12/1/2008 11:14'! isInstalled self methodClass ifNotNil: [:class| self selector ifNotNil: [:selector| ^self == (class methodDict at: selector ifAbsent: [])]]. ^false! ! !CompiledMethod methodsFor: 'testing' stamp: 'GuillermoPolito 4/26/2012 10:54'! isNamedPrimitive ^self primitive = 117! ! !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: 'testing' stamp: 'GuillermoPolito 4/26/2012 10:54'! isPrimitive ^self primitive > 0! ! !CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:40'! isProvided ^ self isProvided: 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: '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: 'testing' stamp: 'NS 3/22/2005 16:38'! isRequired ^ self isRequired: self markerOrNil! ! !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: '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: 'testing'! isReturnSelf "Answer whether the receiver is a quick return of self." ^ self primitive = 256! ! !CompiledMethod methodsFor: 'testing'! isReturnSpecial "Answer whether the receiver is a quick return of self or constant." ^ self primitive between: 256 and: 263! ! !CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:38'! isSubclassResponsibility ^ self isSubclassResponsibility: self markerOrNil! ! !CompiledMethod methodsFor: 'testing' stamp: 'NS 3/22/2005 16:38'! isSubclassResponsibility: marker ^ marker == self class subclassResponsibilityMarker! ! !CompiledMethod methodsFor: 'private' stamp: 'MarcusDenker 6/30/2012 16:44'! getSourceReplacingSelectorWith: newSelector | oldKeywords newKeywords args newSelectorWithArgs source oldSelector s | source := self sourceCode. oldSelector := self parserClass new parseSelector: source. oldSelector = newSelector ifTrue: [ ^ source ]. oldKeywords := oldSelector keywords. newKeywords := (newSelector ifNil: [self defaultSelector]) keywords. [oldKeywords size = newKeywords size] assert. args := (self methodClass parserClass new parseArgsAndTemps: source string notifying: nil) copyFrom: 1 to: self numArgs. 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: '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: '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: '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: 'private' stamp: 'StephaneDucasse 6/24/2011 18:08'! receiver: receiver withArguments: argArray executeMethod: compiledMethod "Execute compiledMethod against the receiver and the arguments in argArray" "Please do not use this method. It is just there to make sure that we can invoke this primitive with right order of arguments" ^receiver withArgs: argArray executeMethod: compiledMethod ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CompiledMethod class instanceVariableNames: ''! !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: '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: 'class initialization' stamp: 'di 1/11/1999 22:13'! fullFrameSize "CompiledMethod fullFrameSize" ^ LargeFrame! ! !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: 'class initialization' stamp: 'ajh 7/18/2001 02:04'! smallFrameSize ^ SmallFrame! ! !CompiledMethod class methodsFor: 'constants' stamp: 'AlexandreBergel 9/14/2011 08:30'! abstractMarker ^ #subclassResponsibility! ! !CompiledMethod class methodsFor: 'constants' stamp: 'al 1/23/2004 13:11'! conflictMarker ^ #traitConflict! ! !CompiledMethod class methodsFor: 'constants' stamp: 'al 1/23/2004 13:11'! disabledMarker ^ #shouldNotImplement! ! !CompiledMethod class methodsFor: 'constants' stamp: 'al 1/23/2004 13:11'! explicitRequirementMarker ^ #explicitRequirement! ! !CompiledMethod class methodsFor: 'constants' stamp: 'al 1/23/2004 13:11'! implicitRequirementMarker ^ #requirement! ! !CompiledMethod class methodsFor: 'constants' stamp: 'al 1/23/2004 13:11'! subclassResponsibilityMarker ^ #subclassResponsibility! ! !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: 'instance creation' stamp: 'tk 9/9/2000 20:36'! basicNew: size self error: 'CompiledMethods may only be created with newMethod:header:' ! ! !CompiledMethod class methodsFor: 'instance creation' stamp: 'MarcusDenker 4/29/2012 13:38'! cleanUp self allInstances do: [:e | e isInstalled ifFalse: [e zapSourcePointer]]. "pay attention since zapSourcePointer 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: '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: '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: '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: '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: '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: '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: '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'! 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: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: '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: '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: 'private' stamp: 'MarcusDenker 2/9/2012 21:09'! receiver: receiver withArguments: argArray executeMethod: compiledMethod "Execute compiledMethod against the receiver and the arguments in argArray" "Please do not use this method. It is just there to make sure that we can invoke this primitive with right order of arguments" ^receiver withArgs: argArray executeMethod: compiledMethod! ! Inspector subclass: #CompiledMethodInspector instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tools-Inspector'! !CompiledMethodInspector methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'! fieldList | keys | keys := OrderedCollection new. keys add: 'self'. keys add: 'all bytecodes'. keys add: 'header'. 1 to: object numLiterals do: [ :i | keys add: 'literal', i printString ]. object initialPC to: object size do: [ :i | keys add: i printString ]. ^ keys asArray ! ! !CompiledMethodInspector methodsFor: 'selecting' stamp: 'ajh 3/20/2003 00:17'! contentsIsString "Hacked so contents empty when deselected" ^ #(0 2 3) includes: selectionIndex! ! !CompiledMethodInspector methodsFor: 'selecting' stamp: 'sd 11/20/2005 21:27'! selection | bytecodeIndex | selectionIndex = 0 ifTrue: [^ '']. selectionIndex = 1 ifTrue: [^ object ]. selectionIndex = 2 ifTrue: [^ object symbolic]. selectionIndex = 3 ifTrue: [^ object headerDescription]. selectionIndex <= (object numLiterals + 3) ifTrue: [ ^ object objectAt: selectionIndex - 2 ]. bytecodeIndex := selectionIndex - object numLiterals - 3. ^ object at: object initialPC + bytecodeIndex - 1! ! !CompiledMethodInspector methodsFor: 'selecting' stamp: 'ajh 3/20/2001 11:56'! selectionUnmodifiable "Answer if the current selected variable is unmodifiable via acceptance in the code pane. For most inspectors, no selection and a selection of self (selectionIndex = 1) are unmodifiable" ^ true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CompiledMethodInspector class instanceVariableNames: ''! !CompiledMethodInspector class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 2/20/2011 15:12'! registerToolsOn: registry "Register ourselves as inspector for CompiledMethod" registry registerInspector: self for: CompiledMethod ! ! ClassTestCase subclass: #CompiledMethodTest instanceVariableNames: 'x y' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Methods'! !CompiledMethodTest commentStamp: '' prior: 0! 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: 'coverage' stamp: 'nice 4/8/2011 08:55'! classToBeTested ^CompiledMethod! ! !CompiledMethodTest methodsFor: 'examples' stamp: 'AlexandreBergel 9/14/2011 08:27'! abstractMethod "I am an abstract method" ^ self subclassResponsibility! ! !CompiledMethodTest methodsFor: 'examples' stamp: 'Alexandre Bergel 5/6/2010 12:17'! deprecatedMethod self deprecated: 'example of a deprecated method'! ! !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: 'examples' stamp: 'sd 4/6/2009 21:27'! readX | tmp | tmp := x. ^ tmp! ! !CompiledMethodTest methodsFor: 'examples' stamp: 'sd 4/6/2009 21:23'! readXandY ^ x + y ! ! !CompiledMethodTest methodsFor: 'examples' stamp: 'md 2/18/2006 20:09'! returnPlusOne: anInteger ^anInteger + 1. ! ! !CompiledMethodTest methodsFor: 'examples' stamp: 'md 2/18/2006 20:09'! returnTrue ^true ! ! !CompiledMethodTest methodsFor: 'examples' stamp: 'AlexandreBergel 9/14/2011 08:28'! shouldNotImplementMethod "I am not an abstract method" ^ self shouldNotImplement! ! !CompiledMethodTest methodsFor: 'examples' stamp: 'sd 4/6/2009 21:23'! writeX x := 33 ! ! !CompiledMethodTest methodsFor: 'examples' stamp: 'sd 4/6/2009 21:23'! writeXandY x := 33. y := 66 ! ! !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 - 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: 'tests - accessing' stamp: 'md 2/18/2006 20:10'! 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: 'KernelTests-Methods'. cls compile: 'foo ^ 10'. method := cls >> #foo. Smalltalk removeClassNamed: #TUTU. self assert: method methodClass = cls! ! !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 - accessing' stamp: 'GabrielOmarCotelli 5/25/2010 21:22'! 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: 'KernelTests-Methods'. cls compile: 'foo ^ 10'. method := cls >> #foo. Smalltalk removeClassNamed: #TUTU. self assert: method searchForClass isNil! ! !CompiledMethodTest methodsFor: 'tests - accessing' stamp: 'GabrielOmarCotelli 5/25/2010 21:22'! 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: 'KernelTests-Methods'. cls compile: 'foo ^ 10'. method := cls >> #foo. Smalltalk removeClassNamed: #TUTU. self assert: method searchForSelector isNil! ! !CompiledMethodTest methodsFor: 'tests - accessing' stamp: 'md 2/16/2006 20:28'! 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: 'KernelTests-Methods'. cls compile: 'foo ^ 10'. method := cls >> #foo. Smalltalk removeClassNamed: #TUTU. self assert: method selector = #foo. ! ! !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: 'MarianoMartinezPeck 7/25/2012 14:24'! testCopyWithTrailerBytes | method copy | method := thisContext method. self assert: method pragmas notEmpty. copy := method copyWithTrailerBytes: CompiledMethodTrailer empty. self assert: (method equivalentTo: copy). self deny: method = copy. "copyWithTrailerBytes: changes the length of a method so these are no longer equal." 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] ! ! !CompiledMethodTest methodsFor: 'tests - comparing' stamp: 'MarianoMartinezPeck 9/17/2011 23:10'! testEqualityClassSideMethod | method1 method2 | method1 := (TestCase class compile: 'aMethod' classified: nil notifying: nil trailer: CompiledMethodTrailer empty ifFail: [^ nil]) method. method2 := (TestCase class compile: 'aMethod' classified: nil notifying: nil trailer: CompiledMethodTrailer empty ifFail: [^ nil]) method. self deny: (method1 literalAt: method1 numLiterals) == (method2 literalAt: method2 numLiterals). self assert: method1 = method2. ! ! !CompiledMethodTest methodsFor: 'tests - comparing' stamp: 'MarianoMartinezPeck 9/17/2011 23:10'! testEqualityInstanceSideMethod | method1 method2 | method1 := (TestCase compile: 'aMethod' classified: nil notifying: nil trailer: CompiledMethodTrailer empty ifFail: [^ nil]) method. method2 := (TestCase compile: 'aMethod' classified: nil notifying: nil trailer: CompiledMethodTrailer empty ifFail: [^ nil]) method. self assert: (method1 literalAt: method1 numLiterals) == (method2 literalAt: method2 numLiterals). self assert: method1 = method2. ! ! !CompiledMethodTest methodsFor: 'tests - conversion' stamp: 'LukasRenggli 5/8/2010 19:40'! testCompiledMethodAsString "self debug: #testCompiledMethodAsString" self shouldnt: [thisContext method asString] raise: Error! ! !CompiledMethodTest methodsFor: 'tests - decompiling' stamp: 'md 2/16/2006 20:29'! testDecompile "self debug: #testDecompileTree" | method cls stream | Smalltalk removeClassNamed: #TUTU. cls := Object subclass: #TUTU instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Methods'. cls compile: 'foo ^ 10'. method := cls >> #foo. Smalltalk removeClassNamed: #TUTU. stream := ReadWriteStream on: String new. method decompile printOn: stream. self assert: stream contents = 'foo ^ 10' ! ! !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 - 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: '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: '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: '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: '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 - 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: '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 - testing' stamp: 'md 2/18/2006 20:10'! 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: 'KernelTests-Methods'. cls compile: 'foo ^ 10'. method := cls >> #foo. Smalltalk removeClassNamed: #TUTU. self deny: method isInstalled. ! ! !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). ! ! Object subclass: #CompiledMethodTrailer instanceVariableNames: 'data encodedData kind size method' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Methods'! !CompiledMethodTrailer commentStamp: '' prior: 0! 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: '*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: '*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: '*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: '*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 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 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: 'accessing' stamp: 'Igor.Stasenko 4/5/2010 13:48'! nativeCode kind = #NativeCodeTrailer ifFalse: [ ^ nil ]. ^ data at: 2 ! ! !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 4/5/2010 13:49'! platformId kind = #NativeCodeTrailer ifFalse: [ ^ nil ]. ^ data at: 1 ! ! !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 16:45'! size "Answer the size of method's trailer , in bytes" ^ size! ! !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: '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: '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: '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: '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: '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: '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: '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: '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 15:57'! decodeEmbeddedSourceQCompress "data is string with method's source code, encoded using qCompress method" self qDecompress.! ! !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: 'decoding' stamp: 'Igor.Stasenko 12/13/2009 11:56'! decodeNoTrailer "Not much to decode here" size := 1. ! ! !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/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: '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: 'decoding' stamp: 'Igor.Stasenko 12/13/2009 16:34'! decodeUndefined self error: 'undefined method encoding'! ! !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: '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: 'encoding' stamp: 'Igor.Stasenko 12/13/2009 14:30'! decodeExtendedKind "reserved for future use" self shouldBeImplemented. ! ! !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:16'! encodeClearedTrailer "A cleared trailer is replaced by #NoTrailer, when used for encoding" self clear. kind := #NoTrailer. ^ self encode! ! !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: 'encoding' stamp: 'Igor.Stasenko 12/13/2009 15:02'! encodeExtendedKind "reserved for future use" self error: 'Not yet implemented'. ! ! !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: 'encoding' stamp: 'Igor.Stasenko 12/13/2009 11:55'! encodeNoTrailer encodedData := ByteArray with: self kindAsByte! ! !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: '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: '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 14:38'! encodeUndefined self error: 'use of an undefined kind of trailer encoding'! ! !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: '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: 'initialize-release' stamp: 'Igor.Stasenko 12/13/2009 11:38'! clear kind := #NoTrailer. size := 1. data := encodedData := method := nil! ! !CompiledMethodTrailer methodsFor: 'initialize-release' stamp: 'Igor.Stasenko 12/13/2009 11:51'! initialize self clear! ! !CompiledMethodTrailer methodsFor: 'initialize-release' stamp: 'jannik.laval 5/1/2010 16:07'! 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" self perform: ('decode' , kind) asSymbol. "after decoding the trailer, size must be set" [size notNil] assert. ! ! !CompiledMethodTrailer methodsFor: 'testing' stamp: 'MarcusDenker 4/29/2012 09:51'! hasSource ^ kind == #EmbeddedSourceQCompress or: [ kind == #EmbeddedSourceZip ]! ! !CompiledMethodTrailer methodsFor: 'testing' stamp: 'Igor.Stasenko 4/11/2010 13:15'! hasSourcePointer ^ kind == #SourcePointer or: [ kind == #VarLengthSourcePointer or: [ kind == #NativeCodeTrailer ] ] ! ! !CompiledMethodTrailer methodsFor: 'testing' stamp: 'Igor.Stasenko 12/13/2009 16:54'! isEmpty ^ kind == #NoTrailer or: [ kind == #ClearedTrailer ]! ! !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: '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: '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: '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: '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 class instanceVariableNames: ''! !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 12/14/2009 10:08'! empty "answer the empty trailer" ^ self new! ! !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 )! ! TestCase subclass: #CompiledMethodTrailerTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Methods'! !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: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: '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). ! ! !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: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). ! ! Object subclass: #CompiledMethodWithNode instanceVariableNames: 'node method' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Support'! !CompiledMethodWithNode methodsFor: 'accessing' stamp: 'NS 1/28/2004 09:03'! method ^ method! ! !CompiledMethodWithNode methodsFor: 'accessing' stamp: 'NS 1/28/2004 09:04'! node ^ node! ! !CompiledMethodWithNode methodsFor: 'accessing' stamp: 'NS 1/28/2004 09:04'! selector ^ self node selector! ! !CompiledMethodWithNode methodsFor: 'private' stamp: 'NS 1/28/2004 09:03'! method: aCompiledMethod method := aCompiledMethod! ! !CompiledMethodWithNode methodsFor: 'private' stamp: 'NS 1/28/2004 09:04'! node: aMethodNode node := aMethodNode! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CompiledMethodWithNode class instanceVariableNames: ''! !CompiledMethodWithNode class methodsFor: 'instance creation' stamp: 'NS 1/28/2004 09:05'! generateMethodFromNode: aMethodNode trailer: bytes ^ self method: (aMethodNode generate: bytes) node: aMethodNode.! ! !CompiledMethodWithNode class methodsFor: 'instance creation' stamp: 'NS 1/28/2004 09:05'! method: aCompiledMethod node: aMethodNode ^ self new method: aCompiledMethod; node: aMethodNode.! ! Object subclass: #Compiler instanceVariableNames: 'sourceStream requestor class category context parser' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Kernel'! !Compiler commentStamp: '' prior: 0! 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: 'error handling' stamp: 'pavel.krivanek 11/21/2008 16:50'! interactive ^ UIManager default interactiveParserFor: requestor! ! !Compiler methodsFor: 'error handling'! notify: aString "Refer to the comment in Object|notify:." ^self notify: aString at: sourceStream position + 1! ! !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 access' 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: '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: '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 access' 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 access' stamp: 'NS 1/19/2004 09:05'! evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock ^ self evaluate: textOrStream in: aContext to: receiver notifying: aRequestor ifFail: failBlock logged: false.! ! !Compiler methodsFor: 'public access' stamp: 'EstebanLorenzano 7/27/2012 16:30'! evaluate: textOrStream in: aContext to: receiver 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: [receiver 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 := receiver 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 access' stamp: 'alain.plantec 5/18/2009 15:54'! 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 decompileString! ! !Compiler methodsFor: 'public access' 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: 'public access' 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 access' stamp: 'eem 5/15/2008 15:13'! parser parser ifNil: [parser := self parserClass new]. ^parser! ! !Compiler methodsFor: 'public access' stamp: 'eem 5/15/2008 15:07'! parser: aParser parser := aParser! ! !Compiler methodsFor: 'public access' stamp: 'IgorStasenko 1/11/2011 01:02'! parserClass "Answer the class of parser. In future, should be replaced with more flexible #newParser " ^ parser ifNil: [(class ifNil: [self class]) parserClass] ifNotNil: [parser class] ! ! !Compiler methodsFor: 'public access' stamp: 'eem 5/15/2008 15:06'! parserClass: aParserClass parser := aParserClass new! ! !Compiler methodsFor: 'public access' stamp: 'md 2/20/2006 21:16'! translate: aStream noPattern: noPattern ifFail: failBlock parser: parser | tree | tree := parser parse: aStream class: class noPattern: noPattern context: context notifying: requestor ifFail: [^ failBlock value]. ^ tree! ! !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: 'private' stamp: 'PeterHugossonMiller 9/2/2009 16:05'! from: textOrStream class: aClass context: aContext notifying: req (textOrStream isKindOf: PositionableStream) ifTrue: [sourceStream := textOrStream] ifFalse: [sourceStream := textOrStream asString readStream]. class := aClass. context := aContext. requestor := req! ! !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 class instanceVariableNames: ''! !Compiler class methodsFor: 'accessing' stamp: 'nk 8/30/2004 07:56'! couldEvaluate: anObject "Answer true if anObject can be passed to my various #evaluate: methods." ^anObject isString or: [ anObject isText or: [ anObject isStream ]]! ! !Compiler class methodsFor: 'accessing' stamp: 'MarcusDenker 11/16/2012 13:46'! debuggerMethodMapForMethod: aMethod ^ DebuggerMethodMap forMethod: aMethod! ! !Compiler class methodsFor: 'accessing' stamp: 'md 3/1/2006 21:12'! decompilerClass ^Decompiler! ! !Compiler class methodsFor: 'accessing' stamp: 'eem 5/13/2008 11:37'! parserClass "Answer a parser class to use for parsing methods compiled by instances of the receiver." ^Parser! ! !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: 'evaluating'! 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: '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: 'evaluating'! 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'! 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: 'alain.plantec 5/18/2009 15:53'! format: textOrStream in: aClass notifying: aRequestor ^self new format: textOrStream in: aClass notifying: aRequestor! ! !Compiler class methodsFor: 'utilities' stamp: 'StephaneDucasse 2/20/2010 22:58'! recompileAll "Recompile all classes and traits in the system." Smalltalk allClassesAndTraits do: [:classOrTrait | classOrTrait compileAll] displayingProgress: 'Recompiling all classes and traits'. ! ! !Compiler class methodsFor: 'utilities' stamp: 'MarcusDenker 12/14/2009 19:34'! recompileAllFrom: firstName "Recompile all classes, starting with given name." Smalltalk allClassesAndTraitsDo: [:class | class name >= firstName ifTrue: [Transcript show: class name; cr. class compileAll]] "Compiler recompileAllFrom: 'AAABodyShop'." ! ! TestCase subclass: #CompilerEvaluationTest instanceVariableNames: 'weightedAverage' classVariableNames: '' poolDictionaries: '' category: 'CompilerTests'! !CompilerEvaluationTest commentStamp: 'StephaneDucasse 6/9/2010 20:54' prior: 0! 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: '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: 'helper methods' stamp: 'carlaGriggio 5/23/2010 20:18'! weightedAverage ^weightedAverage ! ! !CompilerEvaluationTest methodsFor: 'setup' stamp: 'StephaneDucasse 6/9/2010 20:55'! setUp weightedAverage := WeightedAverageCost new ! ! !CompilerEvaluationTest methodsFor: 'testing' stamp: 'nice 2/20/2012 20:58'! 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: [^ #failedDoit] logged: false. notInlinedResult := Compiler new evaluate: '| aBlock | aBlock := [:i | ]. 1+1 to: 0 do: aBlock' in: nil to: nil notifying: nil ifFail: [^ #failedDoit] logged: false. self assert: inlinedResult = notInlinedResult! ! !CompilerEvaluationTest methodsFor: 'testing' stamp: 'PavelKrivanek 11/8/2012 12:32'! 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: [^ #failedDoit] logged: true. self assert: result = (6250 / 3)! ! TestCase subclass: #CompilerExceptionsTest instanceVariableNames: 'status text' classVariableNames: '' poolDictionaries: '' category: 'CompilerTests'! !CompilerExceptionsTest methodsFor: 'compiling' stamp: 'StephaneDucasse 2/10/2011 16:59'! compile: sourceString text := sourceString. self class compileSilently: text classified: 'generated' notifying: self! ! !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: 'JohanBrichau 4/15/2011 15:56'! interactive ^ true! ! !CompilerExceptionsTest methodsFor: 'compiling' stamp: 'StephaneDucasse 2/10/2011 17:01'! removeGeneratedMethods self class removeCategory: 'generated'! ! !CompilerExceptionsTest methodsFor: 'emulating' stamp: 'cwp 8/25/2009 20:23'! select ! ! !CompilerExceptionsTest methodsFor: 'emulating' stamp: 'cwp 8/25/2009 20:23'! selectFrom: start to: end ! ! !CompilerExceptionsTest methodsFor: 'emulating' stamp: 'cwp 8/25/2009 20:22'! selectionInterval ^ 1 to: 0! ! !CompilerExceptionsTest methodsFor: 'emulating' stamp: 'StephaneDucasse 2/10/2011 17:36'! text ^ text! ! !CompilerExceptionsTest methodsFor: 'setUp' stamp: 'StephaneDucasse 2/10/2011 17:35'! setUp self removeGeneratedMethods. status := Parser warningAllowed. Parser warnUser.! ! !CompilerExceptionsTest methodsFor: 'setUp' stamp: 'StephaneDucasse 3/15/2010 21:11'! tearDown Parser warningAllowed: status ! ! !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: 'tests' stamp: 'StephaneDucasse 2/10/2011 17:29'! testUndeclaredVariable self compiling: 'griffle ^ goo' shouldRaise: UndeclaredVariable; compiling: 'griffle ^ [ goo ] value' shouldRaise: UndeclaredVariable! ! !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: '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: 'tests' stamp: 'StephaneDucasse 2/10/2011 17:37'! testUnusedVariable self compiling: 'griffle | goo | ^nil' shouldRaise: UnusedVariable. " does not work for the moment. self compiling: 'griffle ^[ | goo | ]' shouldRaise: UnusedVariable "! ! TestCase subclass: #CompilerNotifyingTest instanceVariableNames: 'text morph expectedErrors expectedErrorPositions failure' classVariableNames: '' poolDictionaries: '' category: 'CompilerTests'! !CompilerNotifyingTest commentStamp: 'nice 2/23/2012 22:09' prior: 0! 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: '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: 'initialize-release' stamp: 'nice 2/22/2012 00:54'! setUp failure := Object new.! ! !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 01:44'! testATempShadowingAnotherTemp self setUpForErrorsIn: '| x | x := 1. ^[ | ` Name is already defined ->`x | x ]'. self enumerateAllSelections! ! !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:06'! testAssignmentOfSelf self setUpForErrorsIn: '` Cannot store into ->`self := 1. ^self'. self enumerateAllSelections.! ! !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 00:55'! testDigitTooLargeForARadix self setUpForErrorsIn: '2r` a digit between 0 and 1 expected ->`3'. self enumerateAllSelections! ! !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 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'! testExtraneousStatementAfterAReturnInABlock self setUpForErrorsIn: '[ ^1 ` End of block expected ->`2]'. self enumerateAllSelections.! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'nice 2/22/2012 00:31'! testInvalidExternalFunctionDeclaration "Not implemented yet. #externalFunctionDeclaration skipped, cannot be evaluated"! ! !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:31'! testInvalidPattern "Not implemented yet. #pattern:inContext: skipped, cannot be evaluated"! ! !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:31'! testInvalidPrimitive "Not implemented yet. ##primitive:error: #primitive:module:error: skipped, cannot be evaluated"! ! !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 00:55'! testLiteralCharacterMissing self setUpForErrorsIn: '$` A Character was expected ->`'. 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'! testMissingArgumentAfterAMessageKey self setUpForErrorsIn: '1 to: ` Argument expected ->`:='. self enumerateAllSelections! ! !CompilerNotifyingTest methodsFor: 'testing' stamp: 'nice 2/22/2012 00:55'! testMissingBlockArgumentName self setUpForErrorsIn: '[ :x : ` Argument name expected ->`1]'. self enumerateAllSelections! ! !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:55'! testMissingExpressionAfterAReturn self setUpForErrorsIn: '^ ` Expression to return expected ->`. 1 + 2'. self enumerateAllSelections.! ! !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'! testMissingSeparatorBetweenBlockArgumentAndStatements self setUpForErrorsIn: '[ :x ` Vertical bar expected ->`x + 1 ]'. 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'! 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 01:57'! testUnmatchedBlockBracket self setUpForErrorsIn: 'nil yourself. [` Period or right bracket expected ->`'. 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: '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 00:55'! testUnmatchedCommentQuote self setUpForErrorsIn: '1+2 ` Unmatched comment quote ->`"unfinished comment'. 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'! 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'! testUnmatchedLocalTempDeclaration self setUpForErrorsIn: '| x y ` Vertical bar 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 00:55'! testUnmatchedStringQuote self setUpForErrorsIn: '^nil printString , ` Unmatched string quote ->`''unfinished string'. 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-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-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-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-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: '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: 'private' stamp: 'nice 2/21/2012 23:52'! evaluateSelection ^(nil class evaluatorClass new) evaluate: morph editor selectionAsStream in: nil to: nil notifying: morph editor ifFail: [^failure] logged: false ! ! !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: 'private' stamp: 'nice 2/21/2012 22:23'! numberOfSelections ^(text occurrencesOf: $%) + 1! ! CompilerNotifyingTest subclass: #CompilerSyntaxErrorNotifyingTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CompilerTests'! !CompilerSyntaxErrorNotifyingTest commentStamp: 'nice 2/23/2012 22:09' prior: 0! 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: 'nice 2/22/2012 23:08'! evaluateSelection ^(nil class evaluatorClass 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 instanceVariableNames: ''! !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! ! Object subclass: #CompilerSystemSettings instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Settings-Compiler'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CompilerSystemSettings class instanceVariableNames: ''! !CompilerSystemSettings class methodsFor: 'settings' stamp: 'AlainPlantec 1/31/2010 17:10'! compilerSettingsOn: aBuilder (aBuilder group: #compiler) label: 'Compiler'; with: [ (aBuilder setting: #warningAllowed) label: 'More warnings' translated; target: Parser; description: 'Ask the user for certain situation such as use of undefined variables' translated. (aBuilder setting: #allowBlockArgumentAssignment) label: 'Allow block argument assignment' translated; target: Parser; description: 'If enabled, the compiler will allow assignment into block arguments. This provides backward compatibility with the pre-closure compiler.' translated. (aBuilder setting: #allowUnderscoreAsAssignment) label: 'Allow underscore as assignment' translated; target: Scanner; description: 'If enabled, the compiler will accept _ (underscore) for assignment. If disabled, the compiler will accept identifiers with underscore characters. This provides backward compatibility with the pre-ANSI compiler.' translated]. ! ! TestCase subclass: #CompilerTest instanceVariableNames: 'errorMessage errorLocation errorSource interactive originalTranscript newTranscript' classVariableNames: '' poolDictionaries: '' category: 'CompilerTests'! !CompilerTest commentStamp: 'nice 12/3/2007 22:15' prior: 0! CompilerTest is a holder for SUnit test of Compiler! !CompilerTest methodsFor: 'literals' stamp: 'nice 12/20/2012 23:37'! testNegativeZero self assert: (Compiler evaluate: '-0.0') hex = Float negativeZero hex.! ! !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: 'mocking' stamp: 'JorgeRessia 3/4/2010 12:48'! initializeErrorMessage errorMessage := nil. errorLocation := nil. errorSource := nil! ! !CompilerTest methodsFor: 'mocking' stamp: 'JorgeRessia 3/4/2010 12:49'! interactive ^interactive! ! !CompilerTest methodsFor: 'mocking' stamp: 'JorgeRessia 3/4/2010 12:49'! notify: aString at: aSmallInteger in: aReadStream errorMessage := aString. errorLocation := aSmallInteger. errorSource := aReadStream. ! ! !CompilerTest methodsFor: 'running' stamp: 'EstebanLorenzano 8/3/2012 15:28'! runCase SystemAnnouncer uniqueInstance suspendAllWhile: [ super runCase ] ! ! !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: 'running' stamp: 'simon.denier 6/11/2010 14:24'! tearDown Smalltalk globals at: #Transcript put: originalTranscript. ! ! !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: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: '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: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: '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: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: '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: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: '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: '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: '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: '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: '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: '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)'). ! ! !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: '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: '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: '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: '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: '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: '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 = '').! ! SimpleBorder subclass: #ComplexBorder instanceVariableNames: 'style colors lineStyles' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Borders'! !ComplexBorder commentStamp: 'MarcusDenker 2/14/2010 22:32' prior: 0! 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:13'! colors ^colors ifNil:[colors := self computeColors].! ! !ComplexBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:22'! style ^style! ! !ComplexBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:22'! style: newStyle style == newStyle ifTrue:[^self]. style := newStyle. self releaseCachedState.! ! !ComplexBorder methodsFor: 'accessing' stamp: 'ar 8/25/2001 16:14'! widthForRounding ^0! ! !ComplexBorder methodsFor: 'color tracking' stamp: 'ar 8/25/2001 18:17'! trackColorFrom: aMorph baseColor ifNil:[self color: aMorph raisedColor].! ! !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: '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: '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: '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: 'initialize' stamp: 'ar 11/26/2001 14:43'! releaseCachedState colors := nil. lineStyles := nil.! ! !ComplexBorder methodsFor: 'testing' stamp: 'ar 8/26/2001 19:30'! isComplex ^true! ! !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: '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: '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: '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: '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: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: '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 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/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 class instanceVariableNames: ''! !ComplexBorder class methodsFor: 'instance creation' stamp: 'ar 8/25/2001 16:22'! style: aSymbol ^self new style: aSymbol! ! Model subclass: #ComposableModel instanceVariableNames: 'focusOrder owner window spec extentHolder needRebuild keyStrokeForNextFocusHolder keyStrokeForPreviousFocusHolder additionalKeyBindings announcer' classVariableNames: '' poolDictionaries: '' category: 'Spec-Core'! !ComposableModel commentStamp: '' prior: 0! ComposableModel is an abstract class which represent a applicative model made to be composed with other ComposableModel! !ComposableModel methodsFor: '*Spec-Tools-Editor' stamp: 'BenjaminVanRyseghem 7/11/2012 17:41'! edit WidgetSetter new model: self; openWithSpec.! ! !ComposableModel methodsFor: 'Morphic-Widgets-should-be-an-extension' stamp: 'StephaneDucasse 5/17/2012 19:26'! 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! ! !ComposableModel methodsFor: 'Morphic-Widgets-should-be-an-extension' stamp: 'BenjaminVanRyseghem 7/10/2012 23:54'! heightToDisplayInList: aList "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 heightToDisplayInList: aList! ! !ComposableModel methodsFor: 'Morphic-Widgets-should-be-an-extension' stamp: 'BenjaminVanRyseghem 7/10/2012 23:56'! 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! ! !ComposableModel methodsFor: 'Morphic-Widgets-should-be-an-extension' stamp: 'BenjaminVanRyseghem 2/22/2013 00:17'! 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: [ 1halt.self buildWithSpec ]. self widget listRenderOn: aCanvas atRow: aRow bounds: drawBounds color: drawColor backgroundColor: backgroundColor from: aMorph! ! !ComposableModel methodsFor: 'Morphic-Widgets-should-be-an-extension' stamp: 'BenjaminVanRyseghem 6/24/2012 23:11'! 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! ! !ComposableModel methodsFor: 'Morphic-Widgets-should-be-an-extension' stamp: 'BenjaminVanRyseghem 7/10/2012 23:56'! widthToDisplayInList: aList "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 widthToDisplayInList: aList! ! !ComposableModel methodsFor: 'Morphic-Widgets-should-be-an-extension' stamp: 'BenjaminVanRyseghem 7/10/2012 23:56'! 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! ! !ComposableModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/21/2013 23:59'! announcer ^ announcer contents! ! !ComposableModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/24/2012 10:50'! bindings: aBindings self bindings bindings: aBindings! ! !ComposableModel methodsFor: 'accessing'! focusOrder ^ focusOrder ifNil: [ focusOrder := OrderedCollection new ].! ! !ComposableModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/9/2012 14:00'! needRebuild ^ needRebuild contents! ! !ComposableModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/9/2012 14:00'! needRebuild: aBoolean needRebuild contents: aBoolean! ! !ComposableModel methodsFor: 'accessing'! owner: anObject owner ifNotNil: [owner removeDependent: self]. anObject ifNotNil: [anObject addDependent: self]. owner := anObject.! ! !ComposableModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/6/2012 18:25'! spec ^ spec! ! !ComposableModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/6/2012 18:26'! spec: aSpec spec := aSpec! ! !ComposableModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/7/2012 12:25'! widget ^ spec ifNil: [ nil ] ifNotNil: [:s | s instance ]! ! !ComposableModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/27/2012 19:36'! window ^ window ifNil: [ owner ifNil: [ nil ] ifNotNil: [:o | o window ]]! ! !ComposableModel methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 2/21/2013 23:59'! initialize "Initialization code for ComposableModel" super initialize. extentHolder := nil asValueHolder. needRebuild := true asValueHolder. keyStrokeForNextFocusHolder := KMNoShortcut new asValueHolder. keyStrokeForPreviousFocusHolder := KMNoShortcut new asValueHolder. additionalKeyBindings := Dictionary new. announcer := Announcer new asValueHolder. self initializeWidgets. self initializePresenter. keyStrokeForNextFocusHolder whenChangedDo: [:shortcut | self on: shortcut do: [ self giveFocusToNextFrom: self widget ]]. keyStrokeForPreviousFocusHolder whenChangedDo: [:shortcut | self on: shortcut do: [ self giveFocusToPreviousFrom: self widget ]].! ! !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: '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: 'initialization' stamp: 'BenjaminVanRyseghem 7/10/2012 23:21'! initializeWidgets self subclassResponsibility! ! !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: '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: 'instance creation' stamp: 'BenjaminVanRyseghem 6/11/2012 10:00'! resolveSymbol: aSymbol ^ Smalltalk at: aSymbol! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 2/22/2013 00:18'! announce: anAnnouncement self announcer announce: anAnnouncement! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/11/2012 16:13'! apiMethods ^ self class apiMethods! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/11/2012 16:14'! apiSelectors ^ self class apiSelectors! ! !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 2/22/2013 00:02'! buildWithSpec: aSpec "Build the widget using the spec name provided as argument" | widget | widget := SpecInterpreter buildWidgetFor: self withSpec: aSpec. self ensureExtentFor: widget. self ensureKeyBindingsFor: widget. self announce: (WidgetBuilt model: self widget: widget). ^ widget! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 2/22/2013 00:10'! buildWithSpecLayout: aSpecLayout "Build the widget using the spec name provided as argument" | widget | widget := SpecInterpreter new interpretASpec: aSpecLayout model: self. self ensureExtentFor: widget. self ensureKeyBindingsFor: widget. self announce: (WidgetBuilt model: self widget: widget). ^ widget! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/11/2012 02:05'! ensureExtentFor: old self extent ifNotNil: [ :ex | (old respondsTo: #extent:) ifTrue: [ old extent: ex ] ]. self initialExtent ifNotNil: [ :ex | (old respondsTo: #extent:) ifTrue: [ old extent: ex ] ]! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/26/2012 00:18'! extent ^ extentHolder contents! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/26/2012 00:18'! extent: aPoint ^ extentHolder contents: aPoint! ! !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 7/10/2012 15:07'! initialExtent ^ nil! ! !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: '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: 'protocol' stamp: 'BenjaminVanRyseghem 7/11/2012 00:37'! openDialogWithSpec: aSpec "Build the widget using the spec name provided as argument and display it into a window" (window notNil and: [ self needRebuild not ]) ifTrue: [ self needRebuild: true. window rebuildWithSpec: aSpec ] ifFalse: [ window := DialogWindowModel new model: self. window openWithSpec: aSpec. self initializeDialogWindow: window. window updateTitle. self takeKeyboardFocus ]. ^ window! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/11/2012 00:38'! openDialogWithSpecLayout: aSpec "Build the widget using the spec name provided as argument and display it into a window" (window notNil and: [ self needRebuild not ]) ifTrue: [ self needRebuild: true. window rebuildWithSpec: aSpec ] ifFalse: [ window := DialogWindowModel new model: self. window openWithSpecLayout: aSpec. self initializeDialogWindow: window. window updateTitle. self takeKeyboardFocus ]. ^ window! ! !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: 'protocol' stamp: 'BenjaminVanRyseghem 7/11/2012 00:29'! openWithSpec: aSpec "Build the widget using the spec name provided as argument and display it into a window" (window notNil and: [ self needRebuild not ]) ifTrue: [ self needRebuild: true. window rebuildWithSpec: aSpec ] ifFalse: [ window := WindowModel new model: self. window openWithSpec: aSpec. self takeKeyboardFocus ]. ^ window! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/11/2012 00:17'! openWithSpecLayout: aSpec "Build the widget using the spec name provided as argument and display it into a window" (window notNil and: [ self needRebuild not ]) ifFalse: [ window := WindowModel new model: self. window openWithSpecLayout: aSpec. self takeKeyboardFocus ] ifTrue: [ self needRebuild: true. window rebuildWithSpecLayout: aSpec ]. ^ window! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/26/2012 00:47'! show self widget ifNotNil: [:widget | (widget respondsTo: #show) ifTrue: [ widget show ]].! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/12/2012 14:58'! specSelectors "Return all the spec names" ^ self class specSelectors! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/12/2012 14:58'! title "Return the window's title" ^ self class title! ! !ComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/10/2012 15:35'! updateTitle "Update the window title" self window ifNotNil: [:w | w updateTitle ]! ! !ComposableModel methodsFor: 'protocol-announcements' stamp: 'BenjaminVanRyseghem 2/22/2013 00:05'! on: anAnnouncement send: aSelector to: aTarget self announcer weak on: anAnnouncement send: aSelector to: aTarget! ! !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: 'protocol-focus' stamp: 'BenjaminVanRyseghem 2/8/2013 13:36'! eventKeyStrokeForNextFocus "String describing the keystroke to perform to jump to the next widget" ^ keyStrokeForNextFocusHolder contents! ! !ComposableModel methodsFor: 'protocol-focus' stamp: 'BenjaminVanRyseghem 2/8/2013 13:37'! eventKeyStrokeForPreviousFocus "String describing the keystroke to perform to jump to the previous widget" ^ keyStrokeForPreviousFocusHolder contents! ! !ComposableModel methodsFor: 'protocol-focus' stamp: 'BenjaminVanRyseghem 2/8/2013 13:36'! keyStrokeForNextFocus: aKMShortcut keyStrokeForNextFocusHolder contents: aKMShortcut ! ! !ComposableModel methodsFor: 'protocol-focus' stamp: 'BenjaminVanRyseghem 2/10/2013 14:43'! keyStrokeForPreviousFocus: aKMShortcut keyStrokeForPreviousFocusHolder contents: aKMShortcut ! ! !ComposableModel methodsFor: 'protocol-shortcuts' stamp: 'BenjaminVanRyseghem 2/8/2013 13:43'! additionalKeyBindings ^ additionalKeyBindings contents! ! !ComposableModel methodsFor: 'protocol-shortcuts' stamp: 'BenjaminVanRyseghem 2/8/2013 13:49'! on: aShortcut do: aBlock additionalKeyBindings at: aShortcut put: aBlock. self widget ifNotNil:[:w | w on: aShortcut do: aBlock ]! ! !ComposableModel methodsFor: 'specs' stamp: 'bvr 6/1/2012 17:12'! defaultSpec ^ self class perform: self defaultSpecSelector! ! !ComposableModel methodsFor: 'private'! addAll: aWindow withSpec: aSpec aWindow addMorph: (self buildWithSpec: aSpec) frame: (0@0 corner: 1@1).! ! !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: 'private' stamp: 'BenjaminVanRyseghem 2/8/2013 13:13'! defaultSpecSelector ((((SpecPragmaCollector behavior: self class class) filter: [:prg | prg keyword = 'spec:' and: [prg arguments includes: #default]]) reset; collected) collect: [:e | e method selector ]) ifNotEmpty: [:col | ^ col first ]. self specSelectors ifNotEmpty: [:col | col size = 1 ifTrue: [ ^ col first ]]. "should use pragmas" ^ #defaultSpec ! ! !ComposableModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 7/3/2012 17:45'! delete self widget ifNotNil: [:widget | window ifNil: [ widget delete ] ifNotNil: [:o | o delete ]]! ! !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: 'private' stamp: 'BenjaminVanRyseghem 12/12/2012 15:41'! private_buildWithSpec "Build the widget using the default spec" ^ self private_buildWithSpec: self defaultSpecSelector! ! !ComposableModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 2/8/2013 13:12'! 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. ^ widget! ! !ComposableModel methodsFor: 'private'! update: aParameter self changed: aParameter! ! !ComposableModel methodsFor: 'private-focus' stamp: 'BenjaminVanRyseghem 2/8/2013 13:50'! ensureKeyBindingsFor: aWidget aWidget on: self eventKeyStrokeForPreviousFocus do: [ self giveFocusToPreviousFrom: aWidget ]. aWidget on: self eventKeyStrokeForNextFocus do: [ self giveFocusToNextFrom: aWidget ]. additionalKeyBindings associationsDo: [:association | aWidget on: association key do: association value ]! ! !ComposableModel methodsFor: 'private-focus' stamp: 'EstebanLorenzano 2/18/2013 15:27'! 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: 'EstebanLorenzano 2/18/2013 15:29'! 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: 'private-focus'! handlesKeyboard: evt ^ true! ! !ComposableModel methodsFor: 'private-focus' stamp: 'StephaneDucasse 5/17/2012 17:57'! takeKeyboardFocus self focusOrder ifNotEmpty:[:focus | ^ focus first takeKeyboardFocus ]. ^ self widget ifNotNil: [:m | m takeKeyboardFocus ]! ! !ComposableModel methodsFor: 'private-focus'! takeLastKeyboardFocus self focusOrder ifEmpty: [ self takeKeyboardFocus ] ifNotEmpty: [:focus | focus last takeKeyboardFocus ].! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ComposableModel class instanceVariableNames: ''! !ComposableModel class methodsFor: '*Spec-Builder' stamp: 'bvr 5/31/2012 13:39'! bindings ^ BindingsHolder new! ! !ComposableModel class methodsFor: '*Spec-Builder' stamp: 'BenjaminVanRyseghem 2/28/2012 14:15'! possibleEvents ^ #()! ! !ComposableModel class methodsFor: 'instance creation'! owner: owner ^ self new owner: owner; yourself! ! !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: 'protocol' stamp: 'BenjaminVanRyseghem 7/11/2012 16:13'! apiSelectors ^ self apiMethods collect: #selector! ! !ComposableModel class methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/26/2012 00:13'! specSelectors ^ (((SpecPragmaCollector behavior: self class) filter: [:prg | prg keyword = #spec]) reset; collected) collect: [:e | e method selector ]! ! !ComposableModel class methodsFor: 'specs' stamp: 'bvr 6/4/2012 14:35'! defaultSpec ^ self subclassResponsibility! ! !ComposableModel class methodsFor: 'specs'! title ^ 'Untitled window'! ! !ComposableModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/15/2013 11:38'! windowSpec ^ { #StandardWindow. #addMorphBack:. { self defaultSpec . #layout:. #(FrameLayout) }. #title:. self title}! ! AbstractDescription subclass: #ComposableModelDescription instanceVariableNames: 'addClassDescription addInstVarDescriptions addMethodDescriptions addIntoMethodDescriptions specDescription superclass' classVariableNames: '' poolDictionaries: '' category: 'Spec-Builder'! !ComposableModelDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/28/2012 14:07'! addClassDescription ^ addClassDescription! ! !ComposableModelDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/5/2012 05:43'! addClassDescription: aDescription addClassDescription := aDescription! ! !ComposableModelDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 06:58'! addInstVarDescriptions ^ addInstVarDescriptions! ! !ComposableModelDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 07:55'! addIntoMethodDescriptions ^ addIntoMethodDescriptions! ! !ComposableModelDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/27/2012 06:58'! addMethodDescriptions ^ addMethodDescriptions! ! !ComposableModelDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/2/2012 05:56'! specDescription ^ specDescription! ! !ComposableModelDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/5/2012 06:22'! specDescription: aDescription specDescription := aDescription! ! !ComposableModelDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/29/2012 10:14'! superclass ^ superclass! ! !ComposableModelDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/29/2012 10:14'! superclass: anObject superclass := anObject! ! !ComposableModelDescription methodsFor: 'initialization' stamp: 'bvr 5/31/2012 13:40'! initialize "Initialization code for ComposableModelDescription" super initialize. addClassDescription := AddClassDescription new. addInstVarDescriptions := OrderedCollection new. addIntoMethodDescriptions := OrderedCollection new. addMethodDescriptions := OrderedCollection new. specDescription := SpecDescription new. superclass := ComposableModel.! ! !ComposableModelDescription methodsFor: 'processing' stamp: 'BenjaminVanRyseghem 3/29/2012 10:14'! finalize ^ SpecInterpreter interpretASpec: self generate model: self superclass! ! !ComposableModelDescription methodsFor: 'processing' stamp: 'BenjaminVanRyseghem 3/2/2012 06:06'! generateSpec | spec | spec := OrderedCollection new addAll: (addClassDescription generateSpec); addAll: (addInstVarDescriptions gather: #generateSpec); addAll: (addMethodDescriptions gather: #generateSpec); addAll: ((addIntoMethodDescriptions sort: [:a :b | a order < b order ]) gather: #generateSpec); add: #theMetaClass; addAll: specDescription generate; add: #theNonMetaClass; yourself. ^ spec addAll: {#theMetaClass. #compileWithoutReturn:classified:. 'generatingSpec ^ ', (spec copy addFirst: #model;yourself) asArray storeString. 'generating'};yourself! ! !ComposableModelDescription methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 2/28/2012 14:01'! addInstVarNamed: aString kindOf: aClass order: order self addInstVarNamed: aString kindOf: aClass. self addCodeToInitialize: aString, ' := ', aClass name, ' new' order: order! ! !ComposableModelDescription methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 2/27/2012 08:09'! addInstVarNamed: aString kindOfComposablaeModel: aComposableModelClass self addInstVarNamed: aString kindOfComposablaeModel: aComposableModelClass order: 0! ! !ComposableModelDescription methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 2/28/2012 14:01'! addInstVarNamed: aString kindOfComposablaeModel: aComposableModelClass order: order self addInstVarNamed: aString kindOf: aComposableModelClass. self addCodeToInitialize: aString, ' := self instantiate: ', aComposableModelClass name order: order! ! !ComposableModelDescription methodsFor: 'protocol-basic' stamp: 'BenjaminVanRyseghem 2/28/2012 20:18'! addClassNamed: name categorized: category addClassDescription := AddClassDescription category: category name: name. self addMethodWithSource: 'initialize super initialize' category: 'initialize'.! ! !ComposableModelDescription methodsFor: 'protocol-basic' stamp: 'BenjaminVanRyseghem 2/27/2012 08:01'! addCodeTo: selector source: source order: order addIntoMethodDescriptions add: (AddIntoMethodDescription code: source order: order selector: selector).! ! !ComposableModelDescription methodsFor: 'protocol-basic' stamp: 'BenjaminVanRyseghem 2/27/2012 07:56'! addCodeToInitialize: source order: order addIntoMethodDescriptions add: (AddIntoMethodDescription code: source order: order selector: #initialize).! ! !ComposableModelDescription methodsFor: 'protocol-basic' stamp: 'BenjaminVanRyseghem 3/1/2012 21:45'! addInstVarNamed: aString addInstVarDescriptions add: (AddInstVarDescription name: aString). self addMethodWithSource: aString, ' ^ ', aString category: 'accessing'! ! !ComposableModelDescription methodsFor: 'protocol-basic' stamp: 'BenjaminVanRyseghem 3/1/2012 21:53'! addInstVarNamed: aString kindOf: aClass addInstVarDescriptions add: (AddInstVarDescription name: aString type: aClass). self addMethodWithSource: aString, ' ^ ', aString category: 'accessing'! ! !ComposableModelDescription methodsFor: 'protocol-basic' stamp: 'BenjaminVanRyseghem 2/27/2012 07:48'! addMethodWithSource: source category: category addMethodDescriptions add: (AddMethodDescription category: category source: source)! ! !ComposableModelDescription methodsFor: 'protocol-basic' stamp: 'BenjaminVanRyseghem 3/30/2012 17:10'! removeInstVar: anInstVar addInstVarDescriptions remove: anInstVar.! ! MorphicModel subclass: #ComposableMorph uses: TEasilyThemed instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !ComposableMorph commentStamp: 'gvc 5/18/2007 13:32' prior: 0! Morph with an inset border by default and theme access.! !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: 'as yet unclassified' stamp: 'gvc 10/30/2006 09:39'! defaultBorderWidth "Answer the default border width for the receiver." ^ 1! ! !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: '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'! newAlphaImage: aForm help: helpText "Answer an alpha image morph." ^self theme newAlphaImageIn: self image: aForm help: helpText! ! !ComposableMorph methodsFor: 'controls'! 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'! 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'! 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'! 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: 'controls'! 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'! 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'! 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: 'controls'! 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'! 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'! 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'! 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'! 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: 'controls'! 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'! 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'! 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: 'controls'! 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'! 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'! 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'! 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'! 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: 'controls'! 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'! 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'! newButtonLabel: aString "Answer a new button text label." ^self newButtonLabelFor: nil label: aString getEnabled: nil! ! !ComposableMorph methodsFor: 'controls'! 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'! newCancelButton "Answer a new cancel button." ^self newCancelButtonFor: self! ! !ComposableMorph methodsFor: 'controls'! newCancelButtonFor: aModel "Answer a new cancel button." ^self theme newCancelButtonIn: self for: aModel! ! !ComposableMorph methodsFor: 'controls'! 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'! 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'! 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'! newCloseButton "Answer a new close button." ^self newCloseButtonFor: self ! ! !ComposableMorph methodsFor: 'controls'! newCloseButtonFor: aModel "Answer a new close button." ^self theme newCloseButtonIn: self for: aModel! ! !ComposableMorph methodsFor: 'controls'! newCloseControlFor: aModel action: aValuable help: helpText "Answer a new cancel button." ^self theme newCloseControlIn: self for: aModel action: aValuable help: helpText! ! !ComposableMorph methodsFor: 'controls'! 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'! 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'! 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'! newColumn: controls "Answer a morph laid out with a column of controls." ^self theme newColumnIn: self for: controls! ! !ComposableMorph methodsFor: 'controls'! newDialogPanel "Answer a new main dialog panel." ^self theme newDialogPanelIn: self! ! !ComposableMorph methodsFor: 'controls'! 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'! 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'! 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: 'controls'! 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: 'controls'! 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'! newEmbeddedMenu "Answer a new menu." ^self theme newEmbeddedMenuIn: self for: self! ! !ComposableMorph methodsFor: 'controls'! newExpander: aString "Answer an expander with the given label." ^self theme newExpanderIn: self label: aString forAll: #()! ! !ComposableMorph methodsFor: 'controls'! newExpander: aString for: aControl "Answer an expander with the given label and control." ^self theme newExpanderIn: self label: aString forAll: {aControl}! ! !ComposableMorph methodsFor: 'controls'! newExpander: aString forAll: controls "Answer an expander with the given label and controls." ^self theme newExpanderIn: self label: aString forAll: controls! ! !ComposableMorph methodsFor: 'controls'! 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'! 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'! 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: 'controls'! newGroupbox "Answer a plain groupbox." ^self theme newGroupboxIn: self! ! !ComposableMorph methodsFor: 'controls'! newGroupbox: aString "Answer a groupbox with the given label." ^self theme newGroupboxIn: self label: aString! ! !ComposableMorph methodsFor: 'controls'! newGroupbox: aString for: control "Answer a groupbox with the given label and control." ^self theme newGroupboxIn: self label: aString for: control! ! !ComposableMorph methodsFor: 'controls'! newGroupbox: aString forAll: controls "Answer a groupbox with the given label and controls." ^self theme newGroupboxIn: self label: aString forAll: controls! ! !ComposableMorph methodsFor: 'controls'! newGroupboxFor: control "Answer a plain groupbox with the given control." ^self theme newGroupboxIn: self for: control! ! !ComposableMorph methodsFor: 'controls'! newGroupboxForAll: controls "Answer a plain groupbox with the given controls." ^self theme newGroupboxIn: self forAll: controls! ! !ComposableMorph methodsFor: 'controls'! newHSVASelector: aColor help: helpText "Answer a hue-saturation-volume selector with the given color." ^self theme newHSVASelectorIn: self color: aColor help: helpText! ! !ComposableMorph methodsFor: 'controls'! 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'! 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'! newImage: aForm "Answer a new image." ^self theme newImageIn: self form: aForm! ! !ComposableMorph methodsFor: 'controls'! newImage: aForm size: aPoint "Answer a new image." ^self theme newImageIn: self form: aForm size: aPoint! ! !ComposableMorph methodsFor: 'controls'! 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: 'controls'! 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'! newLabel: aString "Answer a new text label." ^self newLabelFor: nil label: aString getEnabled: nil! ! !ComposableMorph methodsFor: 'controls'! newLabelFor: aModel getLabel: labelSel getEnabled: enabledSel "Answer a new text label." ^self theme newLabelIn: self for: aModel getLabel: labelSel getEnabled: enabledSel! ! !ComposableMorph methodsFor: 'controls'! newLabelFor: aModel label: aString getEnabled: enabledSel "Answer a new text label." ^self theme newLabelIn: self for: aModel label: aString getEnabled: enabledSel! ! !ComposableMorph methodsFor: 'controls'! 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'! 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'! 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'! 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'! 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'! newMenu "Answer a new menu." ^self theme newMenuIn: self for: self! ! !ComposableMorph methodsFor: 'controls'! newMenuFor: aModel "Answer a new menu." ^self theme newMenuIn: self for: aModel! ! !ComposableMorph methodsFor: 'controls'! 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'! 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'! 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'! 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: 'controls'! 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'! 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'! newNoButton "Answer a new No button." ^self newNoButtonFor: self! ! !ComposableMorph methodsFor: 'controls'! newNoButtonFor: aModel "Answer a new No button." ^self theme newNoButtonIn: self for: aModel! ! !ComposableMorph methodsFor: 'controls'! newOKButton "Answer a new OK button." ^self newOKButtonFor: self! ! !ComposableMorph methodsFor: 'controls'! newOKButtonFor: aModel "Answer a new OK button." ^self newOKButtonFor: aModel getEnabled: nil! ! !ComposableMorph methodsFor: 'controls'! newOKButtonFor: aModel getEnabled: enabledSel "Answer a new OK button." ^self theme newOKButtonIn: self for: aModel getEnabled: enabledSel! ! !ComposableMorph methodsFor: 'controls'! 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'! newPanel "Answer a new panel." ^self theme newPanelIn: self! ! !ComposableMorph methodsFor: 'controls'! newPluggableDialogWindow "Answer a new pluggable dialog." ^self newPluggableDialogWindow: 'Dialog'! ! !ComposableMorph methodsFor: 'controls'! newPluggableDialogWindow: title "Answer a new pluggable dialog with the given content." ^self newPluggableDialogWindow: title for: nil! ! !ComposableMorph methodsFor: 'controls'! newPluggableDialogWindow: title for: contentMorph "Answer a new pluggable dialog with the given content." ^self theme newPluggableDialogWindowIn: self title: title for: contentMorph! ! !ComposableMorph methodsFor: 'controls'! 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'! 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'! newRow "Answer a morph laid out as a row." ^self theme newRowIn: self for: #()! ! !ComposableMorph methodsFor: 'controls'! newRow: controls "Answer a morph laid out with a row of controls." ^self theme newRowIn: self for: controls! ! !ComposableMorph methodsFor: 'controls'! newSVSelector: aColor help: helpText "Answer a saturation-volume selector with the given color." ^self theme newSVSelectorIn: self color: aColor help: helpText! ! !ComposableMorph methodsFor: 'controls'! newScrollPaneFor: aMorph "Answer a new scroll pane morph to scroll the given morph." ^self theme newScrollPaneIn: self for: aMorph! ! !ComposableMorph methodsFor: 'controls'! newSeparator "Answer an horizontal separator." ^self theme newSeparatorIn: self! ! !ComposableMorph methodsFor: 'controls'! 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: 'controls'! 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'! 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: 'controls'! newStack "Answer a morph laid out as a stack." ^self theme newStackIn: self for: #()! ! !ComposableMorph methodsFor: 'controls'! newStack: controls "Answer a morph laid out with a stack of controls." ^self theme newStackIn: self for: controls! ! !ComposableMorph methodsFor: 'controls'! newString: aStringOrText "Answer a new embossed string." ^self theme newStringIn: self label: aStringOrText font: self theme labelFont style: #plain! ! !ComposableMorph methodsFor: 'controls'! newString: aStringOrText font: aFont style: aStyle "Answer a new embossed string." ^self theme newStringIn: self label: aStringOrText font: aFont style: aStyle! ! !ComposableMorph methodsFor: 'controls'! newString: aStringOrText style: aStyle "Answer a new embossed string." ^self theme newStringIn: self label: aStringOrText font: self theme labelFont style: aStyle! ! !ComposableMorph methodsFor: 'controls'! newTabGroup: labelsAndPages "Answer a tab group with the given tab labels associated with pages." ^self theme newTabGroupIn: self for: labelsAndPages! ! !ComposableMorph methodsFor: 'controls'! newText: aStringOrText "Answer a new text." ^self theme newTextIn: self text: aStringOrText! ! !ComposableMorph methodsFor: 'controls'! 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'! 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: 'controls'! 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: 'controls'! 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'! 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'! 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'! 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: 'controls'! 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'! newToolDockingBar "Answer a tool docking bar." ^self theme newToolDockingBarIn: self! ! !ComposableMorph methodsFor: 'controls'! newToolSpacer "Answer a tool spacer." ^self theme newToolSpacerIn: self! ! !ComposableMorph methodsFor: 'controls'! newToolbar "Answer a toolbar." ^self theme newToolbarIn: self! ! !ComposableMorph methodsFor: 'controls'! newToolbar: controls "Answer a toolbar with the given controls." ^self theme newToolbarIn: self for: controls! ! !ComposableMorph methodsFor: 'controls'! newToolbarHandle "Answer a toolbar handle." ^self theme newToolbarHandleIn: self! ! !ComposableMorph methodsFor: 'controls'! 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: 'controls'! newVerticalSeparator "Answer a vertical separator." ^self theme newVerticalSeparatorIn: self! ! !ComposableMorph methodsFor: 'controls'! newWindowFor: aModel title: titleString "Answer a new window morph." ^self theme newWindowIn: self for: aModel title: titleString! ! !ComposableMorph methodsFor: 'controls'! newWorkArea "Answer a new work area morph." ^self theme newWorkAreaIn: self! ! !ComposableMorph methodsFor: 'controls'! newYesButton "Answer a new Yes button." ^self newYesButtonFor: self! ! !ComposableMorph methodsFor: 'controls'! newYesButtonFor: aModel "Answer a new yes button." ^self theme newYesButtonIn: self for: aModel! ! !ComposableMorph methodsFor: 'services'! abort: aStringOrText "Open an error dialog." ^self abort: aStringOrText title: 'Error' translated! ! !ComposableMorph methodsFor: 'services'! abort: aStringOrText title: aString "Open an error dialog." ^self theme abortIn: self text: aStringOrText title: aString! ! !ComposableMorph methodsFor: 'services'! alert: aStringOrText "Open an alert dialog." ^self alert: aStringOrText title: 'Alert' translated! ! !ComposableMorph methodsFor: 'services'! alert: aStringOrText title: aString "Open an alert dialog." ^self alert: aStringOrText title: aString configure: [:d | ]! ! !ComposableMorph methodsFor: 'services'! 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: 'services'! 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: 'services'! chooseColor "Answer the result of a color selector dialog ." ^self chooseColor: Color black! ! !ComposableMorph methodsFor: 'services'! 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'! 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: 'services'! chooseDirectory: title "Answer the result of a file dialog with the given title, answer a directory." ^self chooseDirectory: title path: nil! ! !ComposableMorph methodsFor: 'services'! 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: 'services'! chooseDropList: aStringOrText list: aList "Open a drop list chooser dialog." ^self chooseDropList: aStringOrText title: 'Choose' translated list: aList! ! !ComposableMorph methodsFor: 'services'! chooseDropList: aStringOrText title: aString list: aList "Open a drop list chooser dialog." ^self theme chooseDropListIn: self text: aStringOrText title: aString list: aList! ! !ComposableMorph methodsFor: 'services'! 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: 'services'! chooseFont "Answer the result of a font selector dialog." ^self chooseFont: nil! ! !ComposableMorph methodsFor: 'services'! 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: 'services'! deny: aStringOrText "Open a denial dialog." ^self deny: aStringOrText title: 'Access Denied' translated! ! !ComposableMorph methodsFor: 'services'! deny: aStringOrText title: aString "Open a denial dialog." ^self theme denyIn: self text: aStringOrText title: aString! ! !ComposableMorph methodsFor: 'services'! fileOpen: title "Answer the result of a file open dialog with the given title." ^self fileOpen: title extensions: nil! ! !ComposableMorph methodsFor: 'services'! 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: 'services'! 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: 'services'! 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: 'services'! fileSave: title "Answer the result of a file save dialog with the given title." ^self fileSave: title extensions: nil path: nil! ! !ComposableMorph methodsFor: 'services'! 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: 'services'! 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: 'services'! 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: 'services'! longMessage: aStringOrText title: aString "Open a (long) message dialog." ^self theme longMessageIn: self text: aStringOrText title: aString! ! !ComposableMorph methodsFor: 'services'! message: aStringOrText "Open a message dialog." ^self message: aStringOrText title: 'Information' translated! ! !ComposableMorph methodsFor: 'services'! message: aStringOrText title: aString "Open a message dialog." ^self theme messageIn: self text: aStringOrText title: aString! ! !ComposableMorph methodsFor: 'services'! proceed: aStringOrText "Open a proceed dialog." ^self proceed: aStringOrText title: 'Proceed' translated! ! !ComposableMorph methodsFor: 'services'! 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: 'services'! question: aStringOrText "Open a question dialog." ^self question: aStringOrText title: 'Question' translated! ! !ComposableMorph methodsFor: 'services'! 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'! questionWithoutCancel: aStringOrText "Open a question dialog." ^self questionWithoutCancel: aStringOrText title: 'Question' translated! ! !ComposableMorph methodsFor: 'services'! 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: 'services'! textEntry: aStringOrText "Open a text entry dialog." ^self textEntry: aStringOrText title: 'Entry' translated! ! !ComposableMorph methodsFor: 'services'! textEntry: aStringOrText title: aString "Open a text entry dialog." ^self textEntry: aStringOrText title: aString entryText: ''! ! !ComposableMorph methodsFor: 'services'! textEntry: aStringOrText title: aString entryText: defaultEntryText "Open a text entry dialog." ^self theme textEntryIn: self text: aStringOrText title: aString entryText: defaultEntryText! ! !ComposableMorph methodsFor: 'theme'! theme "Answer the ui theme that provides controls." ^UITheme current! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ComposableMorph class uses: TEasilyThemed classTrait instanceVariableNames: ''! AbstractSpec subclass: #ComposableSpec instanceVariableNames: 'subSpecs' classVariableNames: '' poolDictionaries: '' category: 'Spec-Core-Specs'! !ComposableSpec commentStamp: '' prior: 0! A ComposableSpec is a spec used to combine other specs! !ComposableSpec methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/6/2012 19:17'! subSpecs ^ subSpecs! ! !ComposableSpec methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 10/17/2012 10:39'! initialize "Initialization code for ComposableSpec" super initialize. subSpecs := Set new.! ! !ComposableSpec methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/6/2012 19:43'! addSubSpec: aSpec subSpecs add: aSpec! ! !ComposableSpec methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/24/2012 01:42'! classSymbol ^ #Panel! ! !ComposableSpec methodsFor: 'private' stamp: 'BenjaminVanRyseghem 12/12/2012 15:43'! initializeInstance ^ SpecInterpreter private_interpretASpec: { self classSymbol. #useProportionalLayout. #addSplitters. #vSpaceFill. #hSpaceFill.} model: DummyComposableModel new! ! SimpleBorder subclass: #CompositeBorder instanceVariableNames: 'borders' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Borders'! !CompositeBorder commentStamp: 'gvc 5/18/2007 13:28' prior: 0! Border supporting multiple "sub-borders".! !CompositeBorder methodsFor: 'accessing' stamp: 'gvc 3/12/2007 11:15'! borders "Answer the value of borders" ^ borders! ! !CompositeBorder methodsFor: 'accessing' stamp: 'gvc 3/12/2007 11:15'! borders: anObject "Set the value of borders" borders := anObject! ! !CompositeBorder methodsFor: 'as yet unclassified' stamp: 'gvc 3/29/2007 17:32'! = aBorderStyle "Check the sub-borders too" ^super = aBorderStyle and: [ self borders = aBorderStyle borders]! ! !CompositeBorder methodsFor: 'as yet unclassified' stamp: 'gvc 3/12/2007 12:13'! colorsAtCorners "Return the colors of the first border." ^self borders first colorsAtCorners! ! !CompositeBorder methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'gvc 5/18/2007 13:29'! hash "Since #= is overridden." ^super hash bitXor: self borders hash! ! !CompositeBorder methodsFor: 'as yet unclassified' stamp: 'gvc 3/14/2007 10:32'! isComposite "Answer true." ^true! ! FillStyle subclass: #CompositeFillStyle instanceVariableNames: 'fillStyles' classVariableNames: '' poolDictionaries: '' category: 'Balloon-Fills'! !CompositeFillStyle commentStamp: 'gvc 9/23/2008 12:05' prior: 0! Fillstyle supporting compositing of multiple sub-fillstyles.! !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: '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 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: '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: '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 "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: '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: '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: '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: '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: '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: '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: 'initialize-release' 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:37'! isGradientFill "Answer whether any of the composited fill styles are gradients." self fillStyles reverseDo: [:fs | fs isGradientFill ifTrue: [^true]]. ^false! ! !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: '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: '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 class instanceVariableNames: ''! !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! ! DisplayTransform subclass: #CompositeTransform instanceVariableNames: 'globalTransform localTransform' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Transformations'! !CompositeTransform commentStamp: '' prior: 0! A composite transform provides the effect of several levels of coordinate transformations.! !CompositeTransform methodsFor: 'accessing' stamp: 'di 10/26/1999 17:06'! angle ^ localTransform angle + globalTransform angle! ! !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: 'accessing' stamp: 'di 10/26/1999 15:40'! offset ^ (self localPointToGlobal: 0@0) negated! ! !CompositeTransform methodsFor: 'accessing' stamp: 'di 10/26/1999 15:39'! scale ^ localTransform scale * globalTransform scale! ! !CompositeTransform methodsFor: 'converting' stamp: 'ar 11/2/1998 20:00'! asCompositeTransform ^self! ! !CompositeTransform methodsFor: 'converting' stamp: 'ar 11/2/1998 19:56'! asMatrixTransform2x3 ^globalTransform asMatrixTransform2x3 composedWithLocal: localTransform asMatrixTransform2x3! ! !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: '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: 'ar 11/2/1998 20:00'! isCompositeTransform ^true! ! !CompositeTransform methodsFor: 'testing' stamp: 'di 3/4/98 19:18'! isIdentity ^ globalTransform isIdentity and: [localTransform isIdentity]! ! !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: 'transformations' stamp: 'di 3/4/98 19:20'! transform: aPoint ^ localTransform transform: (globalTransform transform: aPoint)! ! !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: '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 class instanceVariableNames: ''! !CompositeTransform class methodsFor: 'instance creation' stamp: 'ls 3/19/2000 16:44'! globalTransform: gt localTransform: lt ^self new globalTransform: gt localTransform: lt! ! CharacterScanner subclass: #CompositionScanner instanceVariableNames: 'spaceX spaceIndex lineHeight baseline lineHeightAtSpace baselineAtSpace' classVariableNames: '' poolDictionaries: 'TextConstants' category: 'Text-Scanning'! !CompositionScanner commentStamp: '' prior: 0! CompositionScanners are used to measure text and determine where line breaks and space padding should occur.! !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: 'scanning' stamp: 'nice 3/16/2010 20:42'! composeFrom: startIndex inRectangle: lineRectangle firstLine: firstLine leftSide: leftSide rightSide: rightSide "Answer an instance of TextLineInterval that represents the next line in the paragraph." "Set up margins" | runLength stopCondition | 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" self setStopConditions. "also sets font" runLength := text runLengthFor: startIndex. runStopIndex := (lastIndex := startIndex) + (runLength - 1). line := (TextLine start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0) rectangle: lineRectangle. spaceCount := 0. self handleIndentation. leftMargin := destX. line leftMargin: leftMargin. [ stopCondition := self scanCharactersFrom: lastIndex to: runStopIndex in: text string rightX: rightMargin stopConditions: stopConditions kern: kern. "See setStopConditions for stopping conditions for composing." self perform: stopCondition ] whileFalse. ^ line lineHeight: lineHeight + textStyle leading baseline: baseline + textStyle leading! ! !CompositionScanner methodsFor: 'scanning' stamp: 'lr 7/4/2009 10:42'! 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: 'tween 4/6/2007 11:13'! columnBreak "Answer true. Set up values for the text line interval currently being composed." pendingKernX := 0. line stop: lastIndex. spaceX := destX. line paddingWidth: rightMargin - spaceX. ^true! ! !CompositionScanner methodsFor: 'stop conditions' stamp: 'nice 11/16/2009 09:23'! 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. spaceX := destX. line paddingWidth: rightMargin - spaceX. ^true! ! !CompositionScanner methodsFor: 'stop conditions' stamp: 'tween 4/6/2007 11:14'! crossedX "There is a word that has fallen across the right edge of the composition rectangle. This signals the need for wrapping which is done to the last space that was encountered, as recorded by the space stop condition." pendingKernX := 0. spaceCount >= 1 ifTrue: ["The common case. First back off to the space at which we wrap." line stop: spaceIndex. lineHeight := lineHeightAtSpace. baseline := baselineAtSpace. spaceCount := spaceCount - 1. spaceIndex := spaceIndex - 1. "Check to see if any spaces preceding the one at which we wrap. Double space after punctuation, most likely." [(spaceCount > 1 and: [(text at: spaceIndex) = Space])] whileTrue: [spaceCount := spaceCount - 1. "Account for backing over a run which might change width of space." font := text fontAt: spaceIndex withStyle: textStyle. spaceIndex := spaceIndex - 1. spaceX := spaceX - (font widthOf: Space)]. line paddingWidth: rightMargin - spaceX. line internalSpaces: spaceCount] ifFalse: ["Neither internal nor trailing spaces -- almost never happens." lastIndex := lastIndex - 1. [destX <= rightMargin] whileFalse: [destX := destX - (font widthOf: (text at: lastIndex)). lastIndex := lastIndex - 1]. spaceX := destX. line paddingWidth: rightMargin - destX. line stop: (lastIndex max: line first)]. ^true! ! !CompositionScanner methodsFor: 'stop conditions' stamp: 'lr 7/4/2009 10:42'! 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: 'stop conditions' stamp: 'lr 7/4/2009 10:42'! placeEmbeddedObject: anchoredMorph "Workaround: The following should really use #textAnchorType" | descent | anchoredMorph relativeTextAnchorPosition ifNotNil: [ ^ true ]. (super placeEmbeddedObject: anchoredMorph) ifFalse: [ "It doesn't fit" "But if it's the first character then leave it here" lastIndex < line first ifFalse: [ line stop: lastIndex - 1. ^ false ] ]. descent := lineHeight - baseline. lineHeight := lineHeight max: anchoredMorph height. baseline := lineHeight - descent. line stop: lastIndex. ^ true! ! !CompositionScanner methodsFor: 'stop conditions' stamp: 'MarcusDenker 11/20/2012 10:01'! setFont super setFont. stopConditions == DefaultStopConditions ifTrue: [ stopConditions := stopConditions copy ]. stopConditions at: Space asciiValue + 1 put: #space. wantsColumnBreaks ifTrue: [ stopConditions at: TextComposer characterForColumnBreak asciiValue + 1 put: #columnBreak ]! ! !CompositionScanner methodsFor: 'stop conditions' stamp: 'ar 1/8/2000 14:37'! setStopConditions "Set the font and the stop conditions for the current run." self setFont! ! !CompositionScanner methodsFor: 'stop conditions' stamp: 'tween 4/6/2007 11:14'! space "Record left x and character index of the space character just encounted. Used for wrap-around. Answer whether the character has crossed the right edge of the composition rectangle of the paragraph." pendingKernX := 0. spaceX := destX. destX := spaceX + spaceWidth. spaceIndex := lastIndex. lineHeightAtSpace := lineHeight. baselineAtSpace := baseline. lastIndex := lastIndex + 1. spaceCount := spaceCount + 1. destX > rightMargin ifTrue: [^self crossedX]. ^false ! ! !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 ! ! TextConverter subclass: #CompoundTextConverter instanceVariableNames: 'state' classVariableNames: '' poolDictionaries: '' category: 'Multilingual-TextConversion'! !CompoundTextConverter commentStamp: '' prior: 0! Text converter for X Compound Text.! !CompoundTextConverter methodsFor: 'conversion' stamp: 'ar 4/9/2005 22:25'! nextFromStream: aStream | character character2 size leadingChar offset result | aStream isBinary ifTrue: [^ aStream basicNext]. character := aStream basicNext. character ifNil: [^ nil]. character == Character escape ifTrue: [ self parseShiftSeqFromStream: aStream. character := aStream basicNext. character ifNil: [^ nil]]. character asciiValue < 128 ifTrue: [ size := state g0Size. leadingChar := state g0Leading. offset := 16r21. ] ifFalse: [ size :=state g1Size. leadingChar := state g1Leading. offset := 16rA1. ]. size = 1 ifTrue: [ leadingChar = 0 ifTrue: [^ character] ifFalse: [^ Character leadingChar: leadingChar code: character asciiValue] ]. size = 2 ifTrue: [ character2 := aStream basicNext. character2 ifNil: [^ nil. "self errorMalformedInput"]. character := character asciiValue - offset. character2 := character2 asciiValue - offset. result := Character leadingChar: leadingChar code: character * 94 + character2. ^ result asUnicodeChar. "^ self toUnicode: result" ]. self error: 'unsupported encoding'. ! ! !CompoundTextConverter methodsFor: 'conversion' stamp: 'MarcusDenker 3/28/2011 22:15'! nextPut: aCharacter toStream: aStream | ascii leadingChar class | aStream isBinary ifTrue: [^aCharacter storeBinaryOn: aStream]. class := (EncodedCharSet charsetAt: aCharacter leadingChar) traditionalCharsetClass. ascii := (class charFromUnicode: aCharacter asUnicode) charCode. leadingChar := class leadingChar. self nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForLeadingChar: leadingChar. ! ! !CompoundTextConverter methodsFor: 'friend' stamp: 'yo 8/18/2003 17:50'! emitSequenceToResetStateIfNeededOn: aStream Latin1 emitSequenceToResetStateIfNeededOn: aStream forState: state. ! ! !CompoundTextConverter methodsFor: 'friend' stamp: 'yo 11/4/2002 12:33'! restoreStateOf: aStream with: aConverterState state := aConverterState copy. aStream position: state streamPosition. ! ! !CompoundTextConverter methodsFor: 'friend' stamp: 'pmm 3/13/2010 11:22'! saveStateOf: aStream | inst | inst := state shallowCopy. inst streamPosition: aStream position. ^ inst. ! ! !CompoundTextConverter methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:49'! initialize super initialize. state := CompoundTextConverterState g0Size: 1 g1Size: 1 g0Leading: 0 g1Leading: 0 charSize: 1 streamPosition: 0. " unused acceptingEncodings := #(ascii iso88591 jisx0208 gb2312 ksc5601 ksx1001 ) copy." ! ! !CompoundTextConverter methodsFor: 'private' stamp: 'yo 11/4/2002 14:36'! nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForLeadingChar: leadingChar | charset | charset := EncodedCharSet charsetAt: leadingChar. charset ifNotNil: [ charset nextPutValue: ascii toStream: aStream withShiftSequenceIfNeededForTextConverterState: state. ] ifNil: [ "..." ]. ! ! !CompoundTextConverter methodsFor: 'private' stamp: 'marcus.denker 9/14/2008 21:14'! parseShiftSeqFromStream: aStream | c set target id | c := aStream basicNext. c = $$ ifTrue: [ set := #multibyte. c := aStream basicNext. c = $( ifTrue: [target := 1]. c = $) ifTrue: [target := 2]. target ifNil: [target := 1. id := c] ifNotNil: [id := aStream basicNext]. ] ifFalse: [ c = $( ifTrue: [target := 1. set := #nintyfour]. c = $) ifTrue: [target := 2. set := #nintyfour]. c = $- ifTrue: [target := 2. set := #nintysix]. id := aStream basicNext. ]. (set = #multibyte and: [id = $B]) ifTrue: [ state charSize: 2. target = 1 ifTrue: [ state g0Size: 2. state g0Leading: 1. ] ifFalse: [ state g1Size: 2. state g1Leading: 1. ]. ^ self ]. (set = #multibyte and: [id = $A]) ifTrue: [ state charSize: 2. target = 1 ifTrue: [ state g0Size: 2. state g0Leading: 2. ] ifFalse: [ state g1Size: 2. state g1Leading: 2. ]. ^ self ]. (set = #nintyfour and: [id = $B or: [id = $J]]) ifTrue: [ state charSize: 1. state g0Size: 1. state g0Leading: 0. ^ self ]. (set = #nintysix and: [id = $A]) ifTrue: [ state charSize: 1. state g1Size: 1. state g1Leading: 0. ^ self ].! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CompoundTextConverter class instanceVariableNames: ''! !CompoundTextConverter class methodsFor: 'utilities' stamp: 'yo 10/24/2002 14:16'! encodingNames ^ #('iso-2022-jp' 'x-ctext') copy ! ! Object subclass: #CompoundTextConverterState instanceVariableNames: 'g0Size g1Size g0Leading g1Leading charSize streamPosition' classVariableNames: '' poolDictionaries: '' category: 'Multilingual-TextConversion'! !CompoundTextConverterState commentStamp: '' prior: 0! This represents the state of CompoundTextConverter.! !CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 8/23/2002 21:30'! charSize ^ charSize ! ! !CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 9/16/2002 20:41'! charSize: s charSize := s. ! ! !CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 8/23/2002 21:29'! g0Leading ^ g0Leading ! ! !CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 9/16/2002 20:41'! g0Leading: l g0Leading := l. ! ! !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 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'! g1Leading ^ g1Leading ! ! !CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 9/16/2002 20:41'! g1Leading: l g1Leading := l. ! ! !CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 8/23/2002 21:29'! g1Size ^ g1Size ! ! !CompoundTextConverterState methodsFor: 'accessing' stamp: 'yo 9/16/2002 20:41'! g1Size: s g1Size := s. ! ! !CompoundTextConverterState methodsFor: 'accessing' 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:40'! streamPosition: pos streamPosition := pos. ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CompoundTextConverterState class instanceVariableNames: ''! !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. ! ! Object subclass: #CompressedBoundaryShape instanceVariableNames: 'points leftFills rightFills lineWidths lineFills fillStyles' classVariableNames: '' poolDictionaries: '' category: 'Balloon-Geometry'! !CompressedBoundaryShape commentStamp: '' prior: 0! 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: '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: 'accessing' stamp: 'ar 11/3/1998 21:55'! fillStyles ^fillStyles! ! !CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ar 11/3/1998 21:55'! leftFills ^leftFills! ! !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: 'accessing' stamp: 'ar 11/4/1998 13:50'! numSegments ^points size // 3! ! !CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ar 11/3/1998 20:42'! points ^points! ! !CompressedBoundaryShape methodsFor: 'accessing' stamp: 'ar 11/3/1998 21:55'! rightFills ^rightFills! ! !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: '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: '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: '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: '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 class instanceVariableNames: ''! !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! ! CommandLineHandler subclass: #ConfigurationCommandLineHandler instanceVariableNames: 'version repositoryURL configurationName' classVariableNames: '' poolDictionaries: '' category: 'ConfigurationCommandLineHandler-Core'! !ConfigurationCommandLineHandler commentStamp: '' prior: 0! 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 $PharoVM My.image config # list all configurations of a repository $PharoVM My.image config $MC_REPOS_URL # list all the available versions of a confgurtation $PharoVM My.image config $MC_REPOS_URL ConfigurationOfFoo # install the stable version $PharoVM My.image config $MC_REPOS_URL ConfigurationOfFoo --install #install a specific version '1.5' $PharoVM My.image config $MC_REPOS_URL ConfigurationOfFoo --install=1.5 #install a specific version '1.5' and only a specific group 'Tests' $PharoVM My.image config $MC_REPOS_URL ConfigurationOfFoo --install=1.5 --group=Tests ! !ConfigurationCommandLineHandler methodsFor: 'accessing' stamp: 'CamilloBruni 10/13/2012 13:55'! configuration self gofer package: self configurationName; load. ^ Smalltalk globals at: self configurationName asSymbol! ! !ConfigurationCommandLineHandler methodsFor: 'accessing' stamp: 'CamilloBruni 10/13/2012 13:54'! configurationName ^ configurationName ifNil: [ configurationName := self argumentAt: 2 ]! ! !ConfigurationCommandLineHandler methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 1/22/2013 23:40'! 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: 'accessing' stamp: 'CamilloBruni 10/13/2012 13:25'! loadRepositoryURL ^ self argumentAt: 1.! ! !ConfigurationCommandLineHandler methodsFor: 'accessing' stamp: 'CamilloBruni 10/13/2012 14:02'! project ^ self configuration project! ! !ConfigurationCommandLineHandler methodsFor: 'accessing' stamp: 'CamilloBruni 10/13/2012 13:24'! repositoryURL ^ repositoryURL ifNil: [ repositoryURL := self loadRepositoryURL ]! ! !ConfigurationCommandLineHandler methodsFor: 'actions' stamp: 'CamilloBruni 10/13/2012 15:46'! errorNoConfigurationsFound self exitFailure: 'No Configurations found in ', repositoryURL asString! ! !ConfigurationCommandLineHandler methodsFor: 'actions' stamp: 'CamilloBruni 10/13/2012 14:12'! installConfiguration self installVersion: ((self optionAt: 'install') ifNil: [ #stable ])! ! !ConfigurationCommandLineHandler methodsFor: 'actions' stamp: 'CamilloBruni 10/23/2012 22:16'! installVersion: aVersionName | metacelloVersion | self inform: 'Installing ', self configurationName, ' ', aVersionName. metacelloVersion := (self metacelloVersion: aVersionName). (self hasOption: 'group') ifTrue: [ metacelloVersion load: (self optionAt: 'group') ] ifFalse: [ metacelloVersion load ]. Smalltalk snapshot: true andQuit: true.! ! !ConfigurationCommandLineHandler methodsFor: 'actions' stamp: 'CamilloBruni 10/13/2012 13:07'! list self hasConfiguration ifTrue: [ self listConfigurationDetails ] ifFalse: [ self listConfigurations ]! ! !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: 'actions' stamp: 'CamilloBruni 10/13/2012 13:42'! listConfigurations "List possible configurations of the given repository" | configurations | configurations := self loadConfigurationNames. configurations ifEmpty: [ ^ self errorNoConfigurationsFound ]. self printConfigurations: configurations. ^ self exitSuccess! ! !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: '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: 'activation' stamp: 'CamilloBruni 1/12/2013 20:08'! activate self activateHelp ifTrue: [ ^ self ]. (self hasOption: 'install') ifFalse: [ ^ self list ]. self installConfiguration. ! ! !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: 'printing' stamp: 'CamilloBruni 10/13/2012 13:59'! printMetacelloProjectDetails: metacelloProject self inform: 'Available versions for ', self configurationName. metacelloProject symbolicVersionMap keysDo: [ :key| self stdout print: key; lf ]. metacelloProject map keysDo: [ :key| self stdout nextPutAll: key; lf ]! ! !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 class instanceVariableNames: ''! !ConfigurationCommandLineHandler class methodsFor: 'accessing' stamp: 'CamilloBruni 10/13/2012 12:51'! commandName ^ 'config'! ! !ConfigurationCommandLineHandler class methodsFor: 'accessing' stamp: 'CamilloBruni 10/13/2012 12:51'! description ^ 'Install and inspect Metacello Configurations from the command line'! ! TestCase subclass: #ConfigurationCommandLineHandlerTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ConfigurationCommandLineHandler-Tests'! !ConfigurationCommandLineHandlerTest methodsFor: 'convenience' stamp: 'PavelKrivanek 11/13/2012 10:15'! activate: arguments ^ DefaultCommandLineHandler activateWith: (self argumentsWith: arguments)! ! !ConfigurationCommandLineHandlerTest methodsFor: 'convenience' stamp: 'CamilloBruni 10/13/2012 13:03'! argumentsWith: aCollection ^ CommandLineArguments withArguments: aCollection! ! !ConfigurationCommandLineHandlerTest methodsFor: 'convenience' stamp: 'CamilloBruni 10/13/2012 13:17'! command: arguments ^ ConfigurationCommandLineHandler commandLine: (self argumentsWith: arguments)! ! !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: '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: 'tests' stamp: 'CamilloBruni 10/13/2012 13:04'! testResponsibility | args | args := self argumentsWith: #('config'). self assert: (ConfigurationCommandLineHandler isResponsibleFor: args).! ! Object subclass: #ConfigurationGenerator instanceVariableNames: 'repository workingCopy' classVariableNames: '' poolDictionaries: '' category: 'Spec-Tools-Monticello'! !ConfigurationGenerator commentStamp: '' prior: 0! Probably to be removed to use metacello toolbox! !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'! 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'! browseConfiguration self configurationClass browse! ! !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'! 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'! 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'! 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'! 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:01'! hasAnyBaseline ^ self baseLines notEmpty! ! !ConfigurationGenerator methodsFor: 'metacello' stamp: 'StephaneDucasse 4/19/2012 18:01'! lastBaseLine ^ self baseLines last! ! Object subclass: #ConfigurationOfPharo20 instanceVariableNames: 'project' classVariableNames: 'LastVersionLoad' poolDictionaries: '' category: 'ScriptLoader20'! !ConfigurationOfPharo20 commentStamp: '' prior: 0! I'm the metacello configuration for Pharo 2.0 project. ! !ConfigurationOfPharo20 methodsFor: 'accessing' stamp: 'EstebanLorenzano 5/3/2012 15:54'! project ^ project ifNil: [ | constructor | "Bootstrap Metacello if it is not already loaded" (self class baseConfigurationClassIfAbsent: []) ensureMetacello. "Construct Metacello project" constructor := (Smalltalk at: #MetacelloVersionConstructor) on: self. project := constructor project. project loadType: #linear. "change to #atomic if desired" project ]! ! !ConfigurationOfPharo20 methodsFor: 'baselines' stamp: 'EstebanLorenzano 5/16/2012 12:46'! baseline20: spec "Auto-generated method" spec for: #common do: [ spec blessing: #baseline. spec repository: 'http://ss3.gemstone.com/ss/Pharo20' ]. spec for: #pharo do: [ spec package: 'AST-Core'; package: 'AST-Semantic'; package: 'Keymapping-Core'; package: 'Keymapping-Pragmas'; package: 'Keymapping-Settings'; package: 'Keymapping-Shortcuts'; package: 'Keymapping-Tools-Spec'; package: 'NECompletion'; package: 'NOCompletion'; package: 'Polymorph-EventEnhancements'; package: 'Polymorph-Geometry'; package: 'Polymorph-TaskbarIcons'; package: 'Polymorph-Tools-Diff'; package: 'Polymorph-Widgets'; package: 'RPackage-Core'; package: 'RPackage-SystemIntegration'; package: 'Refactoring-Changes'; package: 'Refactoring-Core'; package: 'Refactoring-Critics'; package: 'Refactoring-Environment'; package: 'Refactoring-Pharo-Platform'; package: 'Refactoring-Spelling'; package: 'Regex-Core'; package: 'Regex-Help'; package: 'SUnit-Core'; package: 'SUnit-Help'; package: 'SUnit-UI'; package: 'Graphics-Display Objects'; package: 'Graphics-External'; package: 'Graphics-Files'; package: 'Graphics-Fonts'; package: 'Graphics-Primitives'; package: 'Graphics-Resources'; package: 'Graphics-Support'; package: 'Graphics-Text'; package: 'Graphics-Transformations'; package: 'HelpSystem-Core'; package: 'Nautilus'; package: 'Nautilus'; package: 'NautilusCommon'; package: 'NautilusRefactoring'; package: 'Announcements-Tests-Core'; package: 'BalloonTests'; package: 'CodeImport-Tests'; package: 'CollectionsTests'; package: 'CompilerTests'; package: 'CompressionTests'; package: 'FileSystem-Tests-AnsiStreams'; package: 'FileSystem-Tests-Core'; package: 'FileSystem-Tests-Disk'; package: 'FileSystem-Tests-Memory'; package: 'FreeTypeTests'; package: 'Gofer-Tests'; package: 'Graphics-Tests'; package: 'HelpSystem-Tests'; package: 'KernelTests'; package: 'Keymapping-Tests'; package: 'MorphicTests'; package: 'Multilingual-Tests'; package: 'NetworkTests'; package: 'RPackage-Tests'; package: 'Regex-Tests-Core'; package: 'Ring-Tests-Containers'; package: 'Ring-Tests-Kernel'; package: 'SUnit-Tests'; package: 'ShoutTests'; package: 'Spec-Tests'; package: 'Tests'; package: 'ToolsTest'; package: 'Zinc-Tests'; package: 'Balloon'; package: 'Compatibility'; package: 'Deprecated20'; package: 'EmergencyEvaluator'; package: 'EventModel'; package: 'FamFam-Icons'; package: 'FixUnderscores'; package: 'FreeType'; package: 'Gofer-Core'; package: 'GroupManager'; package: 'GroupManagerUI'; package: 'Growl'; package: 'HistoryCollection'; package: 'MenuRegistration'; package: 'Monticello'; package: 'MonticelloConfigurations'; package: 'MonticelloGUI'; package: 'Monticellomocks'; package: 'Morphic'; package: 'NonInteractiveTranscript'; package: 'PackageInfo'; package: 'PluggableTextMorphWithLimits'; package: 'RecentSubmissions'; package: 'Ring-Core-Containers'; package: 'Ring-Core-Kernel'; package: 'Shout'; package: 'StartupPreferences'; package: 'TrueType'; package: 'UI-Basic'. spec group: 'default' with: #('PharoKernel' 'System' 'Network' 'FileSystem' 'Zinc' 'Announcements' 'Settings' 'PharoTools' 'AST' 'Keymapping' 'CodeCompletion' 'Polymorph' 'RPackage' 'Refactoring' 'Regex' 'SUnit' 'Graphics' 'HelpSystem' 'NautilusBrowser' 'Unsorted' 'PharoTests'). spec group: 'AST' with: #('AST-Core' 'AST-Semantic'). spec group: 'Keymapping' with: #('Keymapping-Core' 'Keymapping-Pragmas' 'Keymapping-Settings' 'Keymapping-Shortcuts' 'Keymapping-Tools-Spec'). spec group: 'CodeCompletion' with: #('NECompletion' 'NOCompletion'). spec group: 'Polymorph' with: #('Polymorph-EventEnhancements' 'Polymorph-Geometry' 'Polymorph-TaskbarIcons' 'Polymorph-Tools-Diff' 'Polymorph-Widgets'). spec group: 'RPackage' with: #('RPackage-Core' 'RPackage-SystemIntegration'). spec group: 'Refactoring' with: #('Refactoring-Changes' 'Refactoring-Core' 'Refactoring-Critics' 'Refactoring-Environment' 'Refactoring-Pharo-Platform' 'Refactoring-Spelling'). spec group: 'Regex' with: #('Regex-Core' 'Regex-Help'). spec group: 'SUnit' with: #('SUnit-Core' 'SUnit-Help' 'SUnit-UI'). spec group: 'Graphics' with: #('Graphics-Display Objects' 'Graphics-External' 'Graphics-Files' 'Graphics-Fonts' 'Graphics-Primitives' 'Graphics-Resources' 'Graphics-Support' 'Graphics-Text' 'Graphics-Transformations'). spec group: 'HelpSystem' with: #('HelpSystem-Core'). spec group: 'NautilusBrowser' with: #('Nautilus' 'Nautilus' 'NautilusCommon' 'NautilusRefactoring'). spec group: 'PharoTests' with: #('Announcements-Tests-Core' 'BalloonTests' 'CodeImport-Tests' 'CollectionsTests' 'CompilerTests' 'CompressionTests' 'FileSystem-Tests-AnsiStreams' 'FileSystem-Tests-Core' 'FileSystem-Tests-Disk' 'FileSystem-Tests-Memory' 'FreeTypeTests' 'Gofer-Tests' 'Graphics-Tests' 'HelpSystem-Tests' 'KernelTests' 'Keymapping-Tests' 'MorphicTests' 'Multilingual-Tests' 'NetworkTests' 'RPackage-Tests' 'Regex-Tests-Core' 'Ring-Tests-Containers' 'Ring-Tests-Kernel' 'SUnit-Tests' 'ShoutTests' 'Spec-Tests' 'Tests' 'ToolsTest' 'Zinc-Tests'). spec group: 'Unsorted' with: #('Balloon' 'Compatibility' 'Deprecated20' 'EmergencyEvaluator' 'EventModel' 'FamFam-Icons' 'FixUnderscores' 'FreeType' 'Gofer-Core' 'GroupManager' 'GroupManagerUI' 'Growl' 'HistoryCollection' 'MenuRegistration' 'Monticello' 'MonticelloConfigurations' 'MonticelloGUI' 'Monticellomocks' 'Morphic' 'NonInteractiveTranscript' 'PackageInfo' 'PluggableTextMorphWithLimits' 'RecentSubmissions' 'Ring-Core-Containers' 'Ring-Core-Kernel' 'Shout' 'StartupPreferences' 'TrueType' 'UI-Basic') ].! ! !ConfigurationOfPharo20 methodsFor: 'baselines' stamp: 'EstebanLorenzano 5/16/2012 12:46'! baseline20Core: spec "Auto-generated method" spec for: #common do: [ spec blessing: #baseline. spec repository: 'http://ss3.gemstone.com/ss/Pharo20' ]. spec for: #pharo do: [ spec package: 'System-Announcements'; package: 'System-Applications'; package: 'System-Change Notification'; package: 'System-Changes'; package: 'System-Clipboard'; package: 'System-CommandLine'; package: 'System-FilePackage'; package: 'System-FileRegistry'; package: 'System-Finalization'; package: 'System-Hashing'; package: 'System-History'; package: 'System-Installers'; package: 'System-Localization'; package: 'System-Object Events'; package: 'System-Object Storage'; package: 'System-Platforms'; package: 'System-Serial Port'; package: 'System-Settings'; package: 'System-Sound'; package: 'System-Support'; package: 'System-Text'; package: 'System-Tools'; package: 'Network-Kernel'; package: 'Network-MIME'; package: 'Network-Mail'; package: 'Network-Protocols'; package: 'Network-RFC822'; package: 'Network-URI'; package: 'Network-UUID'; package: 'Network-Url'; package: 'FileSystem-AnsiStreams'; package: 'FileSystem-Core'; package: 'FileSystem-Disk'; package: 'FileSystem-Memory'; package: 'FileSystem-Zip'; package: 'Zinc-HTTP'; package: 'Zinc-Patch-HTTPSocket'; package: 'Announcements-Core'; package: 'Announcements-Help'; package: 'Announcements-View'; package: 'Settings-Compiler'; package: 'Settings-Display'; package: 'Settings-FreeType'; package: 'Settings-Graphics'; package: 'Settings-Kernel'; package: 'Settings-Monticello'; package: 'Settings-Network'; package: 'Settings-Polymorph'; package: 'Settings-System'; package: 'Settings-Tools'; package: 'Tools'. spec group: 'System' with: #('System-Announcements' 'System-Applications' 'System-Change Notification' 'System-Changes' 'System-Clipboard' 'System-CommandLine' 'System-FilePackage' 'System-FileRegistry' 'System-Finalization' 'System-Hashing' 'System-History' 'System-Installers' 'System-Localization' 'System-Object Events' 'System-Object Storage' 'System-Platforms' 'System-Serial Port' 'System-Settings' 'System-Sound' 'System-Support' 'System-Text' 'System-Tools'). spec group: 'Network' with: #('Network-Kernel' 'Network-MIME' 'Network-Mail' 'Network-Protocols' 'Network-RFC822' 'Network-URI' 'Network-UUID' 'Network-Url'). spec group: 'FileSystem' with: #('FileSystem-AnsiStreams' 'FileSystem-Core' 'FileSystem-Disk' 'FileSystem-Memory' 'FileSystem-Zip'). spec group: 'Zinc' with: #('Zinc-HTTP' 'Zinc-Patch-HTTPSocket'). spec group: 'Announcements' with: #('Announcements-Core' 'Announcements-Help' 'Announcements-View'). spec group: 'Settings' with: #('Settings-Compiler' 'Settings-Display' 'Settings-FreeType' 'Settings-Graphics' 'Settings-Kernel' 'Settings-Monticello' 'Settings-Network' 'Settings-Polymorph' 'Settings-System' 'Settings-Tools'). spec group: 'PharoTools' with: #('Tools') ].! ! !ConfigurationOfPharo20 methodsFor: 'baselines' stamp: 'EstebanLorenzano 5/16/2012 12:46'! baseline20Kernel: spec "Auto-generated method" spec for: #common do: [ spec blessing: #baseline. spec repository: 'http://ss3.gemstone.com/ss/Pharo20' ]. spec for: #pharo do: [ spec package: 'Announcements-Core'; package: 'Announcements-Core'; package: 'Collections-Abstract'; package: 'Collections-Arithmetic'; package: 'Collections-Arrayed'; package: 'Collections-Atomic'; package: 'Collections-Native'; package: 'Collections-Sequenceable'; package: 'Collections-Stack'; package: 'Collections-Streams'; package: 'Collections-Strings'; package: 'Collections-Support'; package: 'Collections-Text'; package: 'Collections-Traits'; package: 'Collections-Unordered'; package: 'Collections-Weak'; package: 'Compiler'; package: 'Compression'; package: 'Files'; package: 'Graphics-Display Objects'; package: 'Graphics-Primitives'; package: 'Graphics-Transformations'; package: 'Kernel'; package: 'Multilingual-Encodings'; package: 'Multilingual-ImmPlugin'; package: 'Multilingual-Languages'; package: 'Multilingual-TextConversion'; package: 'System-Change Notification'; package: 'System-Changes'; package: 'System-CommandLine'; package: 'System-Clipboard'; package: 'System-FileRegistry'; package: 'System-Finalization'; package: 'System-Localization'; package: 'System-Object Events'; package: 'System-Object Storage'; package: 'System-Platforms'; package: 'System-Support'; package: 'Traits'; package: 'UIManager'; package: 'Transcript'; package: 'FileSystem-AnsiStreams'; package: 'FileSystem-Core'; package: 'FileSystem-Disk'; package: 'FileSystem-Memory'; package: 'CodeImport'. spec group: 'PharoKernel' with: #('Announcements-Core' 'Announcements-Core' 'Collections-Abstract' 'Collections-Arithmetic' 'Collections-Arrayed' 'Collections-Atomic' 'Collections-Native' 'Collections-Sequenceable' 'Collections-Stack' 'Collections-Streams' 'Collections-Strings' 'Collections-Support' 'Collections-Text' 'Collections-Traits' 'Collections-Unordered' 'Collections-Weak' 'Compiler' 'Compression' 'Files' 'Graphics-Display Objects' 'Graphics-Primitives' 'Graphics-Transformations' 'Kernel' 'Multilingual-Encodings' 'Multilingual-ImmPlugin' 'Multilingual-Languages' 'Multilingual-TextConversion' 'System-Change Notification' 'System-Changes' 'System-CommandLine' 'System-Clipboard' 'System-FileRegistry' 'System-Finalization' 'System-Localization' 'System-Object Events' 'System-Object Storage' 'System-Platforms' 'System-Support' 'Traits' 'UIManager' 'Transcript' 'FileSystem-AnsiStreams' 'FileSystem-Core' 'FileSystem-Disk' 'FileSystem-Memory' 'CodeImport') ].! ! !ConfigurationOfPharo20 methodsFor: 'generating' stamp: 'EstebanLorenzano 5/15/2012 10:29'! newBaseline: versionString self generateBaseline: 'Kernel' version: versionString imports: #() groups: self groupsKernel. self generateBaseline: 'Core' version: versionString imports: #('Kernel') groups: self groupsCore. self generateBaseline: '' version: versionString imports: #('Kernel' 'Core') groups: self groupsEnvironment, self groupsTest defineGroups: (Dictionary with: 'default'->(self groupsKernel, self groupsCore, self groupsEnvironment, self groupsTest))! ! !ConfigurationOfPharo20 methodsFor: 'generating' stamp: 'EstebanLorenzano 5/15/2012 10:29'! newVersion: aString ^self newVersion: aString description: nil preLoad: nil postLoad: nil fromBaseline: (self calculateBaselineForVersion: aString)! ! !ConfigurationOfPharo20 methodsFor: 'generating' stamp: 'EstebanLorenzano 5/15/2012 10:29'! newVersion: versionString description: descriptionString preLoad: preLoadString postLoad: postLoadString ^self newVersion: versionString description: descriptionString preLoad: preLoadString postLoad: postLoadString fromBaseline: (self calculateBaselineForVersion: versionString) ! ! !ConfigurationOfPharo20 methodsFor: 'generating' stamp: 'EstebanLorenzano 5/15/2012 13:20'! newVersion: versionString description: descriptionString preLoad: preLoadString postLoad: postLoadString fromBaseline: baselineString | template | self generateVersion: 'Kernel' fromBaseline: baselineString version: versionString groups: self groupsKernel. self generateVersion: 'Core' fromBaseline: baselineString version: versionString groups: self groupsCore. self generateVersion: 'Environment' fromBaseline: baselineString version: versionString groups: self groupsEnvironment. template := self templateVersion format: { self versionForMethodName: versionString. versionString. '''', baselineString, ''''. TimeStamp now. descriptionString ifNil: [ '' ]. String streamContents: [ :stream | #('Kernel' 'Core' 'Environment') do: [ :each | stream << (self createIncluded: versionString with: each) ] separatedBy: [ stream << $. << String cr ] ]. preLoadString isEmptyOrNil not ifTrue: [ self generateDoIt: 'PreLoad' version: versionString with: preLoadString. String streamContents: [ :stream | stream << String tab << ('spec preLoadDoIt: #version{1}PreLoad' format: {self versionForMethodName: versionString}) << $. ] ] ifFalse: [ '' ]. postLoadString isEmptyOrNil not ifTrue: [ self generateDoIt: 'PostLoad' version: versionString with: postLoadString. String streamContents: [ :stream | stream << String tab << ('spec postLoadDoIt: #version{1}PostLoad' format: {self versionForMethodName: versionString}) << $. ] ] ifFalse: [ '' ]. }. self class compile: template classified: 'versions' ! ! !ConfigurationOfPharo20 methodsFor: 'versions' stamp: 'EstebanLorenzano 5/16/2012 14:17'! version20075: spec "Auto-generated method" spec for: #common do: [ spec blessing: #release. spec timestamp: '16 May 2012 2:17:21 pm'. spec description: 'Issue 5906: Better comment for Class>>#copy http://code.google.com/p/pharo/issues/detail?id=5906 Issue 5898: Fixing version browsing and ring historical behavior http://code.google.com/p/pharo/issues/detail?id=5898 Issue 5895: Change History separator in nautilus history http://code.google.com/p/pharo/issues/detail?id=5895 Issue 5894: Mini improvement in MethodWidget API http://code.google.com/p/pharo/issues/detail?id=5894 ' ]. spec for: #pharo do: [ self version20075Kernel: spec. self version20075Core: spec. self version20075Environment: spec. spec preLoadDoIt: #version20075PreLoad. ].! ! !ConfigurationOfPharo20 methodsFor: 'versions' stamp: 'EstebanLorenzano 5/16/2012 14:17'! version20075Core: spec "Auto-generated method" spec package: 'Announcements-Core' with: 'Announcements-Core-StephaneDucasse.31'; package: 'System-Change Notification' with: 'System-Change Notification-MarcusDenker.23'; package: 'System-Changes' with: 'System-Changes-MarcusDenker.138'; package: 'System-CommandLine' with: 'System-CommandLine-MarcusDenker.15'; package: 'System-Clipboard' with: 'System-Clipboard-StephaneDucasse.23'; package: 'System-FileRegistry' with: 'System-FileRegistry-MarcusDenker.15'; package: 'System-Finalization' with: 'System-Finalization-StephaneDucasse.17'; package: 'System-Localization' with: 'System-Localization-StephaneDucasse.61'; package: 'System-Object Events' with: 'System-Object Events-StephaneDucasse.11'; package: 'System-Object Storage' with: 'System-Object Storage-MarcusDenker.154'; package: 'System-Platforms' with: 'System-Platforms-StephaneDucasse.19'; package: 'System-Support' with: 'System-Support-MarcusDenker.626'; package: 'FileSystem-AnsiStreams' with: 'FileSystem-AnsiStreams-MarcusDenker.4'; package: 'FileSystem-Core' with: 'FileSystem-Core-MarcusDenker.10'; package: 'FileSystem-Disk' with: 'FileSystem-Disk-MarcusDenker.8'; package: 'FileSystem-Memory' with: 'FileSystem-Memory-EstebanLorenzano.6'; package: 'System-Announcements' with: 'System-Announcements-MarcusDenker.3'; package: 'System-Applications' with: 'System-Applications-EstebanLorenzano.42'; package: 'System-FilePackage' with: 'System-FilePackage-MarcusDenker.66'; package: 'System-Hashing' with: 'System-Hashing-StephaneDucasse.18'; package: 'System-History' with: 'System-History-MarcusDenker.5'; package: 'System-Installers' with: 'System-Installers-MarcusDenker.15'; package: 'System-Serial Port' with: 'System-Serial Port-MarcusDenker.20'; package: 'System-Settings' with: 'System-Settings-MarcusDenker.262'; package: 'System-Sound' with: 'System-Sound-StephaneDucasse.10'; package: 'System-Text' with: 'System-Text-MarcusDenker.207'; package: 'System-Tools' with: 'System-Tools-MarcusDenker.83'; package: 'Network-Kernel' with: 'Network-Kernel-MarcusDenker.67'; package: 'Network-MIME' with: 'Network-MIME-StephaneDucasse.43'; package: 'Network-Mail' with: 'Network-Mail-StephaneDucasse.10'; package: 'Network-Protocols' with: 'Network-Protocols-MarcusDenker.75'; package: 'Network-RFC822' with: 'Network-RFC822-StephaneDucasse.4'; package: 'Network-URI' with: 'Network-URI-StephaneDucasse.34'; package: 'Network-UUID' with: 'Network-UUID-MarcusDenker.22'; package: 'Network-Url' with: 'Network-Url-MarcusDenker.68'; package: 'FileSystem-Zip' with: 'FileSystem-Zip-EstebanLorenzano.6'; package: 'Zinc-HTTP' with: 'Zinc-HTTP-EstebanLorenzano.253'; package: 'Zinc-Patch-HTTPSocket' with: 'Zinc-Patch-HTTPSocket-StephaneDucasse.2'; package: 'Announcements-Help' with: 'Announcements-Help-MarcusDenker.5'; package: 'Announcements-View' with: 'Announcements-View-StephaneDucasse.9'; package: 'Settings-Compiler' with: 'Settings-Compiler-StephaneDucasse.3'; package: 'Settings-Display' with: 'Settings-Display-MarcusDenker.7'; package: 'Settings-FreeType' with: 'Settings-FreeType-MarcusDenker.4'; package: 'Settings-Graphics' with: 'Settings-Graphics-MarcusDenker.14'; package: 'Settings-Kernel' with: 'Settings-Kernel-StephaneDucasse.2'; package: 'Settings-Monticello' with: 'Settings-Monticello-StephaneDucasse.4'; package: 'Settings-Network' with: 'Settings-Network-MarcusDenker.8'; package: 'Settings-Polymorph' with: 'Settings-Polymorph-MarcusDenker.43'; package: 'Settings-System' with: 'Settings-System-MarcusDenker.19'; package: 'Settings-Tools' with: 'Settings-Tools-StephaneDucasse.39'; package: 'Tools' with: 'Tools-EstebanLorenzano.842'! ! !ConfigurationOfPharo20 methodsFor: 'versions' stamp: 'EstebanLorenzano 5/16/2012 14:17'! version20075Environment: spec "Auto-generated method" spec package: 'Graphics-Display Objects' with: 'Graphics-Display Objects-MarcusDenker.72'; package: 'Graphics-Primitives' with: 'Graphics-Primitives-MarcusDenker.76'; package: 'Graphics-Transformations' with: 'Graphics-Transformations-StephaneDucasse.4'; package: 'AST-Core' with: 'AST-Core-MarcusDenker.94'; package: 'AST-Semantic' with: 'AST-Semantic-EstebanLorenzano.16'; package: 'Keymapping-Core' with: 'Keymapping-Core-MarcusDenker.124'; package: 'Keymapping-Pragmas' with: 'Keymapping-Pragmas-MarcusDenker.16'; package: 'Keymapping-Settings' with: 'Keymapping-Settings-EstebanLorenzano.61'; package: 'Keymapping-Shortcuts' with: 'Keymapping-Shortcuts-MarcusDenker.57'; package: 'Keymapping-Tools-Spec' with: 'Keymapping-Tools-Spec-MarcusDenker.4'; package: 'NECompletion' with: 'NECompletion-MarcusDenker.23'; package: 'NOCompletion' with: 'NOCompletion-EstebanLorenzano.9'; package: 'Polymorph-EventEnhancements' with: 'Polymorph-EventEnhancements-MarcusDenker.13'; package: 'Polymorph-Geometry' with: 'Polymorph-Geometry-LaurentLaffont.8'; package: 'Polymorph-TaskbarIcons' with: 'Polymorph-TaskbarIcons-MarcusDenker.12'; package: 'Polymorph-Tools-Diff' with: 'Polymorph-Tools-Diff-MarcusDenker.75'; package: 'Polymorph-Widgets' with: 'Polymorph-Widgets-MarcusDenker.634'; package: 'RPackage-Core' with: 'RPackage-Core-MarcusDenker.113'; package: 'RPackage-SystemIntegration' with: 'RPackage-SystemIntegration-MarcusDenker.91'; package: 'Refactoring-Changes' with: 'Refactoring-Changes-EstebanLorenzano.21'; package: 'Refactoring-Core' with: 'Refactoring-Core-EstebanLorenzano.157'; package: 'Refactoring-Critics' with: 'Refactoring-Critics-EstebanLorenzano.14'; package: 'Refactoring-Environment' with: 'Refactoring-Environment-EstebanLorenzano.10'; package: 'Refactoring-Pharo-Platform' with: 'Refactoring-Pharo-Platform-EstebanLorenzano.2'; package: 'Refactoring-Spelling' with: 'Refactoring-Spelling-EstebanLorenzano.29'; package: 'Regex-Core' with: 'Regex-Core-StephaneDucasse.8'; package: 'Regex-Help' with: 'Regex-Help-StephaneDucasse.2'; package: 'SUnit-Core' with: 'SUnit-Core-MarcusDenker.21'; package: 'SUnit-Help' with: 'SUnit-Help-MarcusDenker.1'; package: 'SUnit-UI' with: 'SUnit-UI-MarcusDenker.23'; package: 'Graphics-External' with: 'Graphics-External-MarcusDenker.11'; package: 'Graphics-Files' with: 'Graphics-Files-MarcusDenker.25'; package: 'Graphics-Fonts' with: 'Graphics-Fonts-MarcusDenker.53'; package: 'Graphics-Resources' with: 'Graphics-Resources-MarcusDenker.13'; package: 'Graphics-Support' with: 'Graphics-Support-MarcusDenker.13'; package: 'Graphics-Text' with: 'Graphics-Text-MarcusDenker.29'; package: 'HelpSystem-Core' with: 'HelpSystem-Core-StephaneDucasse.87'; package: 'Nautilus' with: 'Nautilus-EstebanLorenzano.279'; package: 'NautilusCommon' with: 'NautilusCommon-MarcusDenker.68'; package: 'NautilusRefactoring' with: 'NautilusRefactoring-MarcusDenker.30'; package: 'Balloon' with: 'Balloon-MarcusDenker.83'; package: 'Compatibility' with: 'Compatibility-MarcusDenker.8'; package: 'Deprecated20' with: 'Deprecated20-MarcusDenker.4'; package: 'EmergencyEvaluator' with: 'EmergencyEvaluator-MarcusDenker.25'; package: 'EventModel' with: 'EventModel-StephaneDucasse.1'; package: 'FamFam-Icons' with: 'FamFam-Icons-MarcusDenker.8'; package: 'FixUnderscores' with: 'FixUnderscores-MarcusDenker.23'; package: 'FreeType' with: 'FreeType-MarcusDenker.574'; package: 'Gofer-Core' with: 'Gofer-Core-StephaneDucasse.148'; package: 'GroupManager' with: 'GroupManager-EstebanLorenzano.27'; package: 'GroupManagerUI' with: 'GroupManagerUI-EstebanLorenzano.14'; package: 'Growl' with: 'Growl-EstebanLorenzano.8'; package: 'HistoryCollection' with: 'HistoryCollection-EstebanLorenzano.10'; package: 'MenuRegistration' with: 'MenuRegistration-MarcusDenker.38'; package: 'Monticello' with: 'Monticello-MarcusDenker.582'; package: 'MonticelloConfigurations' with: 'MonticelloConfigurations-StephaneDucasse.61'; package: 'MonticelloGUI' with: 'MonticelloGUI-MarcusDenker.147'; package: 'Monticellomocks' with: 'Monticellomocks-MarcusDenker.1'; package: 'Morphic' with: 'Morphic-MarcusDenker.1150'; package: 'NonInteractiveTranscript' with: 'NonInteractiveTranscript-StephaneDucasse.3'; package: 'PackageInfo' with: 'PackageInfo-MarcusDenker.77'; package: 'PluggableTextMorphWithLimits' with: 'PluggableTextMorphWithLimits-EstebanLorenzano.9'; package: 'RecentSubmissions' with: 'RecentSubmissions-MarcusDenker.157'; package: 'Ring-Core-Containers' with: 'Ring-Core-Containers-MarcusDenker.11'; package: 'Ring-Core-Kernel' with: 'Ring-Core-Kernel-EstebanLorenzano.54'; package: 'Shout' with: 'Shout-MarcusDenker.138'; package: 'StartupPreferences' with: 'StartupPreferences-EstebanLorenzano.42'; package: 'TrueType' with: 'TrueType-StephaneDucasse.33'; package: 'UI-Basic' with: 'UI-Basic-MarcusDenker.8'! ! !ConfigurationOfPharo20 methodsFor: 'versions' stamp: 'EstebanLorenzano 5/16/2012 14:17'! version20075Kernel: spec "Auto-generated method" spec package: 'Announcements-Core' with: 'Announcements-Core-StephaneDucasse.31'; package: 'Collections-Abstract' with: 'Collections-Abstract-MarcusDenker.160'; package: 'Collections-Arithmetic' with: 'Collections-Arithmetic-StephaneDucasse.6'; package: 'Collections-Arrayed' with: 'Collections-Arrayed-MarcusDenker.66'; package: 'Collections-Atomic' with: 'Collections-Atomic-MarcusDenker.5'; package: 'Collections-Native' with: 'Collections-Native-MarcusDenker.5'; package: 'Collections-Sequenceable' with: 'Collections-Sequenceable-MarcusDenker.117'; package: 'Collections-Stack' with: 'Collections-Stack-MarcusDenker.7'; package: 'Collections-Streams' with: 'Collections-Streams-StephaneDucasse.105'; package: 'Collections-Strings' with: 'Collections-Strings-MarcusDenker.210'; package: 'Collections-Support' with: 'Collections-Support-MarcusDenker.49'; package: 'Collections-Text' with: 'Collections-Text-MarcusDenker.79'; package: 'Collections-Traits' with: 'Collections-Traits-StephaneDucasse.6'; package: 'Collections-Unordered' with: 'Collections-Unordered-MarcusDenker.131'; package: 'Collections-Weak' with: 'Collections-Weak-MarcusDenker.60'; package: 'Compiler' with: 'Compiler-MarcusDenker.330'; package: 'Compression' with: 'Compression-MarcusDenker.95'; package: 'Files' with: 'Files-MarcusDenker.ducasse.240'; package: 'Graphics-Display Objects' with: 'Graphics-Display Objects-MarcusDenker.72'; package: 'Graphics-Primitives' with: 'Graphics-Primitives-MarcusDenker.76'; package: 'Graphics-Transformations' with: 'Graphics-Transformations-StephaneDucasse.4'; package: 'Kernel' with: 'Kernel-EstebanLorenzano.1086'; package: 'Multilingual-Encodings' with: 'Multilingual-Encodings-MarcusDenker.23'; package: 'Multilingual-ImmPlugin' with: 'Multilingual-ImmPlugin-LaurentLaffont.10'; package: 'Multilingual-Languages' with: 'Multilingual-Languages-MarcusDenker.17'; package: 'Multilingual-TextConversion' with: 'Multilingual-TextConversion-MarcusDenker.30'; package: 'System-Change Notification' with: 'System-Change Notification-MarcusDenker.23'; package: 'System-Changes' with: 'System-Changes-MarcusDenker.138'; package: 'System-CommandLine' with: 'System-CommandLine-MarcusDenker.15'; package: 'System-Clipboard' with: 'System-Clipboard-StephaneDucasse.23'; package: 'System-FileRegistry' with: 'System-FileRegistry-MarcusDenker.15'; package: 'System-Finalization' with: 'System-Finalization-StephaneDucasse.17'; package: 'System-Localization' with: 'System-Localization-StephaneDucasse.61'; package: 'System-Object Events' with: 'System-Object Events-StephaneDucasse.11'; package: 'System-Object Storage' with: 'System-Object Storage-MarcusDenker.154'; package: 'System-Platforms' with: 'System-Platforms-StephaneDucasse.19'; package: 'System-Support' with: 'System-Support-MarcusDenker.626'; package: 'Traits' with: 'Traits-MarcusDenker.412'; package: 'UIManager' with: 'UIManager-MarcusDenker.61'; package: 'Transcript' with: 'Transcript-MarcusDenker.4'; package: 'FileSystem-AnsiStreams' with: 'FileSystem-AnsiStreams-MarcusDenker.4'; package: 'FileSystem-Core' with: 'FileSystem-Core-MarcusDenker.10'; package: 'FileSystem-Disk' with: 'FileSystem-Disk-MarcusDenker.8'; package: 'FileSystem-Memory' with: 'FileSystem-Memory-EstebanLorenzano.6'; package: 'CodeImport' with: 'CodeImport-EstebanLorenzano.7'! ! !ConfigurationOfPharo20 methodsFor: 'versions' stamp: 'EstebanLorenzano 5/16/2012 14:17'! version20075PreLoad MetacelloScriptLoader showIntegrationMenu. World resetWorldMenu.! ! !ConfigurationOfPharo20 methodsFor: 'private accessing' stamp: 'EstebanLorenzano 5/16/2012 12:44'! allPackages | excluded allPackages | excluded := #('ConfigurationOf*' 'Metacello-*' 'ScriptLoader*' 'Fuel*'). ^((MCPackage allInstances collect: #name) reject: [ :eachName | excluded anySatisfy: [ :eachPattern | eachPattern match: eachName ] ]) sort: [ :a :b | a < b ]. ! ! !ConfigurationOfPharo20 methodsFor: 'private accessing' stamp: 'EstebanLorenzano 5/15/2012 10:29'! calculateBaselineForVersion: aString "For now, just check lastest baseline available" ^(((self project versions select: [ :each | '*-baseline' match: each name ]) sort: [ :a :b | b < a ]) first) name! ! !ConfigurationOfPharo20 methodsFor: 'private accessing' stamp: 'EstebanLorenzano 5/15/2012 13:14'! collectionToString: aCollection ^String streamContents: [ :stream | stream << '#('. aCollection do: [ :each | stream << $' << each asString << $' ] separatedBy: [ stream << String space ]. stream << ')' ]! ! !ConfigurationOfPharo20 methodsFor: 'private accessing' stamp: 'EstebanLorenzano 5/15/2012 10:29'! groupsAndPackages | groups packages | packages := self allPackages. groups := OrderedCollection new "Kernel" add: 'PharoKernel'->(Smalltalk kernelPackageNames select: [ :each | packages includes: each ]); "Core" add: 'System'->(self packages: packages selectMatch: #('System-*')); add: 'Network'->(self packages: packages selectMatch: #('Network-*')); add: 'FileSystem'->(self packages: packages selectMatch: #('FileSystem-*')); add: 'Zinc'->(self packages: packages selectMatch: #('Zinc-*')); add: 'Announcements'->(self packages: packages selectMatch: #('Announcements-*')); add: 'Settings'->(self packages: packages selectMatch: #('Settings-*')); add: 'PharoTools'->(self packages: packages selectMatch: #('Tools*')); "Environment" add: 'AST'->(self packages: packages selectMatch: #('AST-*')); add: 'Keymapping'->(self packages: packages selectMatch: #('Keymapping-*')); add: 'CodeCompletion'->(self packages: packages selectMatch: #('NEC*' 'NOC*')); add: 'Polymorph'->(self packages: packages selectMatch: #('Polymorph-*')); add: 'RPackage'->(self packages: packages selectMatch: #('RPackage-*')); add: 'Refactoring'->(self packages: packages selectMatch: #('Refactoring-*')); add: 'Regex'->(self packages: packages selectMatch: #('Regex-*')); "Actually, all current Ring packages are part of Kernel" "add: 'Ring'->(self packages: nonKernelPackages selectMatch: #('Ring-*'));" add: 'SUnit'->(self packages: packages selectMatch: #('SUnit-*')); add: 'Spec'->(self packages: packages selectMatch: #('Spec-*')); add: 'Graphics'->(self packages: packages selectMatch: #('Graphics-*')); add: 'HelpSystem'->(self packages: packages selectMatch: #('HelpSystem-*')); add: 'NautilusBrowser'->(self packages: packages selectMatch: #('Nautilus*')); "Tests" add: 'PharoTests'->(self packages: packages selectMatch: self testPatterns rejectMatch: #()); yourself. self flag: #todo. "Add this packages to correct groups" groups add: 'Unsorted'->(packages copyWithoutAll: (groups inject: #() into: [ :all :each | all, (each value)])). ^groups ! ! !ConfigurationOfPharo20 methodsFor: 'private accessing' stamp: 'EstebanLorenzano 5/15/2012 10:29'! groupsCore ^ #('System' 'Network' 'FileSystem' 'Zinc' 'Announcements' 'Settings' 'PharoTools')! ! !ConfigurationOfPharo20 methodsFor: 'private accessing' stamp: 'EstebanLorenzano 5/15/2012 10:29'! groupsEnvironment ^ #('AST' 'Keymapping' 'CodeCompletion' 'Polymorph' 'RPackage' 'Refactoring' 'Regex' 'SUnit' 'Graphics' 'HelpSystem' 'NautilusBrowser' 'Unsorted') ! ! !ConfigurationOfPharo20 methodsFor: 'private accessing' stamp: 'EstebanLorenzano 5/15/2012 10:29'! groupsKernel ^ #('PharoKernel')! ! !ConfigurationOfPharo20 methodsFor: 'private accessing' stamp: 'EstebanLorenzano 5/15/2012 10:29'! groupsTest ^ #('PharoTests') ! ! !ConfigurationOfPharo20 methodsFor: 'private accessing' stamp: 'EstebanLorenzano 5/15/2012 10:29'! packages: packages selectMatch: patterns ^self packages: packages selectMatch: patterns rejectMatch: self testPatterns! ! !ConfigurationOfPharo20 methodsFor: 'private accessing' stamp: 'EstebanLorenzano 5/15/2012 10:29'! packages: packages selectMatch: patterns rejectMatch: rejectPatterns ^(packages select: [ :each | patterns anySatisfy: [ :eachPattern | eachPattern match: each ] ]) reject: [ :each | rejectPatterns anySatisfy: [ :eachPattern | eachPattern match: each ] ] ! ! !ConfigurationOfPharo20 methodsFor: 'private accessing' stamp: 'EstebanLorenzano 5/15/2012 13:10'! requirementsFor: aString ^(HazelKernelAnalyzer forPackageNamed: aString) analyze dependentPackages collect: #packageName as: Set. ! ! !ConfigurationOfPharo20 methodsFor: 'private accessing' stamp: 'EstebanLorenzano 5/15/2012 13:18'! templateBaseline ^ 'baseline{1}{2}: spec "Auto-generated method" spec for: #common do: [ spec blessing: #baseline. spec repository: ''http://ss3.gemstone.com/ss/Pharo20'' ]. spec for: #pharo do: [ spec {6}. {7} ].'! ! !ConfigurationOfPharo20 methodsFor: 'private accessing' stamp: 'EstebanLorenzano 5/15/2012 13:19'! templateVersion ^ 'version{1}: spec "Auto-generated method" spec for: #common do: [ spec blessing: #release. spec timestamp: ''{4}''. spec description: ''{5}'' ]. spec for: #pharo do: [ {6}. {7} {8} ].'! ! !ConfigurationOfPharo20 methodsFor: 'private accessing' stamp: 'EstebanLorenzano 5/15/2012 13:18'! templateVersionSplit ^'version{1}{2}: spec "Auto-generated method" spec {3}'! ! !ConfigurationOfPharo20 methodsFor: 'private accessing' stamp: 'EstebanLorenzano 5/15/2012 10:29'! testPatterns ^ #('*Test*')! ! !ConfigurationOfPharo20 methodsFor: 'private accessing' stamp: 'EstebanLorenzano 5/15/2012 10:29'! versionForMethodName: aString ^aString reject: [ :each | #($. $-) includes: each ]! ! !ConfigurationOfPharo20 methodsFor: 'private creating' stamp: 'EstebanLorenzano 5/15/2012 10:45'! createGroup: nameString with: aCollection ^String streamContents: [ :stream | stream << String tab << String tab << 'spec group: ' << $' << nameString << $' << ' with: ' << (self collectionToString: aCollection) ] ! ! !ConfigurationOfPharo20 methodsFor: 'private creating' stamp: 'EstebanLorenzano 5/15/2012 10:29'! createImports: versionString with: imports ^imports ifNotEmpty: [ ' imports: #({1})' format: { String streamContents: [ :stream | imports do: [ :each | stream << $' << ('{1}-baseline-{2}' format: {versionString. each asLowercase }) << $' ] separatedBy: [ stream << String space ] ]} ] ifEmpty: [ '' ]! ! !ConfigurationOfPharo20 methodsFor: 'private creating' stamp: 'EstebanLorenzano 5/15/2012 10:29'! createIncluded: versionString with: nameString ^String streamContents: [ :stream | stream << String tab << String tab << ('self version{1}{2}: spec' format: { self versionForMethodName: versionString. nameString})]! ! !ConfigurationOfPharo20 methodsFor: 'private creating' stamp: 'EstebanLorenzano 5/16/2012 10:40'! createPackage: nameString ^self createPackage: nameString withRequirements: nil "(self requirementsFor: nameString)"! ! !ConfigurationOfPharo20 methodsFor: 'private creating' stamp: 'EstebanLorenzano 5/15/2012 10:29'! createPackage: nameString with: versionString ^String streamContents: [ :stream | stream << String tab << String tab << 'package: ' << $' << nameString << $' << ' with: ' << $' << versionString << $' ]! ! !ConfigurationOfPharo20 methodsFor: 'private creating' stamp: 'EstebanLorenzano 5/15/2012 13:16'! createPackage: nameString withRequirements: aCollection ^String streamContents: [ :stream | stream << String tab << String tab << String tab << 'package: ' << $' << nameString << $'. aCollection isEmptyOrNil ifFalse: [ stream << ' with: [ spec requires: ' << (self collectionToString: aCollection) << ' ]' ] ]! ! !ConfigurationOfPharo20 methodsFor: 'private generating' stamp: 'EstebanLorenzano 5/15/2012 10:29'! generateBaseline: nameString version: versionString imports: imports groups: groups self generateBaseline: nameString version: versionString imports: imports groups: groups defineGroups: Dictionary new! ! !ConfigurationOfPharo20 methodsFor: 'private generating' stamp: 'EstebanLorenzano 5/15/2012 10:37'! generateBaseline: nameString version: versionString imports: imports groups: groups defineGroups: baseGroups | template groupsAndPackages packages | groupsAndPackages := self groupsAndPackages select: [ :each | groups includes: each key ]. packages := (groupsAndPackages collect: #value) inject: #() into: [ :all :each | all, each ]. template := self templateBaseline format: { self versionForMethodName: versionString. nameString asLowercase capitalized. versionString. nameString ifNotEmpty: ['-{1}' format: { nameString asLowercase } ]. self createImports: versionString with: imports. String streamContents: [ :stream | packages do: [ :each | stream << (self createPackage: each) ] separatedBy: [ stream << $; << String cr ] ]. String streamContents: [ :stream | baseGroups associations, groupsAndPackages do: [ :each | stream << (self createGroup: each key with: each value) ] separatedBy: [ stream << $. << String cr ] ] }. self class compile: template classified: 'baselines'.! ! !ConfigurationOfPharo20 methodsFor: 'private generating' stamp: 'EstebanLorenzano 5/15/2012 10:37'! generateDoIt: nameString version: versionString with: aString | template | template := 'version{2}{1} {3}' format: { nameString. self versionForMethodName: versionString. String streamContents: [ :stream | aString lines do: [ :each | stream << String tab << each trimBoth ] separatedBy: [ stream cr ] ]}. self class compile: template classified: 'versions'! ! !ConfigurationOfPharo20 methodsFor: 'private generating' stamp: 'EstebanLorenzano 5/15/2012 10:37'! generateVersion: nameString fromBaseline: baselineString version: versionString groups: groups | template groupsAndPackages packages | groupsAndPackages := self groupsAndPackages select: [ :each | groups includes: each key ]. packages := (groupsAndPackages collect: #value) inject: #() into: [ :all :each | all, each ]. template := self templateVersionSplit format: { self versionForMethodName: versionString. nameString asLowercase capitalized. String streamContents: [ :stream | ((self project version: baselineString) packages select: [ :each | packages includes: each name ]) do: [ :each | stream << (self createPackage: each name with: each currentVersionInfo name) ] separatedBy: [ stream << $; << String cr ] ] }. self class compile: template classified: 'versions'.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ConfigurationOfPharo20 class instanceVariableNames: ''! !ConfigurationOfPharo20 class methodsFor: 'accessing' stamp: 'EstebanLorenzano 5/3/2012 15:54'! project ^self new project! ! !ConfigurationOfPharo20 class methodsFor: 'development support' stamp: 'EstebanLorenzano 5/3/2012 15:54'! 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." ! ! !ConfigurationOfPharo20 class methodsFor: 'development support' stamp: 'EstebanLorenzano 5/3/2012 15:54'! 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! ! !ConfigurationOfPharo20 class methodsFor: 'loading' stamp: 'EstebanLorenzano 5/3/2012 15:54'! 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! ! !ConfigurationOfPharo20 class methodsFor: 'loading' stamp: 'EstebanLorenzano 5/3/2012 15:54'! 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! ! !ConfigurationOfPharo20 class methodsFor: 'loading' stamp: 'EstebanLorenzano 5/3/2012 15:54'! 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! ! !ConfigurationOfPharo20 class methodsFor: 'metacello tool support' stamp: 'EstebanLorenzano 5/3/2012 15:54'! isMetacelloConfig "Answer true and the Metacello tools will operate on you" ^true! ! !ConfigurationOfPharo20 class methodsFor: 'private' stamp: 'EstebanLorenzano 5/3/2012 15:54'! baseConfigurationClassIfAbsent: aBlock ^Smalltalk at: #MetacelloBaseConfiguration ifAbsent: [ self ensureMetacelloBaseConfiguration. Smalltalk at: #MetacelloBaseConfiguration ifAbsent: aBlock ]. ! ! !ConfigurationOfPharo20 class methodsFor: 'private' stamp: 'EstebanLorenzano 5/3/2012 15:54'! ensureMetacello (self baseConfigurationClassIfAbsent: []) ensureMetacello! ! !ConfigurationOfPharo20 class methodsFor: 'private' stamp: 'SeanDeNigris 8/26/2012 11:34'! ensureMetacelloBaseConfiguration Smalltalk at: #MetacelloBaseConfiguration ifAbsent: [ | repository version | repository := MCHttpRepository location: 'http://seaside.gemstone.com/ss/metacello'. repository versionReaderForFileNamed: 'Metacello-Base-DaleHenrichs.2.mcz' do: [ :reader | version := reader version. version load. version workingCopy repositoryGroup addRepository: repository ] ]! ! NetworkError subclass: #ConnectionClosed instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Network-Kernel'! !ConnectionClosed commentStamp: 'mir 5/12/2003 18:12' prior: 0! Signals a prematurely closed connection. ! Object subclass: #ConnectionQueue instanceVariableNames: 'portNumber maxQueueLength connections accessSema socket process' classVariableNames: '' poolDictionaries: '' category: 'Network-Kernel'! !ConnectionQueue commentStamp: '' prior: 0! 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: '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: '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: 'public' stamp: 'ls 9/26/1999 15:34'! isValid ^process notNil! ! !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: '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: '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 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 class instanceVariableNames: ''! !ConnectionQueue class methodsFor: 'instance creation' stamp: 'jm 3/9/98 14:09'! portNumber: anInteger queueLength: queueLength ^ self new initPortNumber: anInteger queueLength: queueLength ! ! NetworkError subclass: #ConnectionRefused instanceVariableNames: 'host port' classVariableNames: '' poolDictionaries: '' category: 'Network-Kernel'! !ConnectionRefused commentStamp: 'mir 5/12/2003 18:14' prior: 0! 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'! host ^ host! ! !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'! port ^ port! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ConnectionRefused class instanceVariableNames: ''! !ConnectionRefused class methodsFor: 'instance creation' stamp: 'len 12/14/2002 11:39'! host: addressOrHostName port: portNumber ^ self new host: addressOrHostName port: portNumber! ! NetworkError subclass: #ConnectionTimedOut instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Network-Kernel'! !ConnectionTimedOut commentStamp: 'mir 5/12/2003 18:14' prior: 0! Signals that a connection attempt timed out. ! TestCase subclass: #ContextCompilationTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CompilerTests'! !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]]]]! ! Inspector subclass: #ContextInspector instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tools-Inspector'! !ContextInspector methodsFor: 'accessing' stamp: 'StephaneDucasse 8/21/2010 20:48'! fieldList "Answer the base field list plus an abbreviated list of indices." ^ self baseFieldList , (object tempNames collect: [:t| '[',t,']'])! ! !ContextInspector methodsFor: 'accessing' stamp: 'ClementBera 11/15/2012 09:12'! selection "The receiver has a list of variables of its inspected object. One of these is selected. Answer the value of the selected variable." | basicIndex | selectionIndex = 0 ifTrue: [^ '']. selectionIndex = 1 ifTrue: [^ object]. selectionIndex = 2 ifTrue: [^ object longPrintStringLimitedTo: 20000]. selectionIndex <= self numberOfFixedFields ifTrue: [^ object instVarAt: selectionIndex - 2]. basicIndex := selectionIndex - self numberOfFixedFields. ^object debuggerMap namedTempAt: basicIndex in: object ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ContextInspector class instanceVariableNames: ''! !ContextInspector class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 2/20/2011 15:13'! registerToolsOn: registry "Register ourselves as inspector for MethodContext" registry registerInspector: self for: MethodContext ! ! InstructionStream subclass: #ContextPart instanceVariableNames: 'stackp' classVariableNames: 'PrimitiveFailToken QuickStep SpecialPrimitiveSimulators TryNamedPrimitiveTemplateMethod' poolDictionaries: '' category: 'Kernel-Methods'! !ContextPart commentStamp: '' prior: 0! 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: 'accessing' stamp: 'stephane.ducasse 3/1/2009 08:41'! 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: '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: '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: '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 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: '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: 'accessing'! client "Answer the client, that is, the object that sent the message that created this context." ^sender receiver! ! !ContextPart methodsFor: 'accessing'! home "Answer the context in which the receiver was defined." self subclassResponsibility! ! !ContextPart methodsFor: 'accessing'! method "Answer the method of this context." self subclassResponsibility! ! !ContextPart methodsFor: 'accessing' stamp: 'ar 4/11/2006 01:49'! methodNode ^ self method methodNode.! ! !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: 'lr 3/22/2009 19:15'! methodSelector ^ self method selector! ! !ContextPart methodsFor: 'accessing'! receiver "Answer the receiver of the message that created this context." self subclassResponsibility! ! !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: 'accessing'! tempAt: index "Answer the value of the temporary variable whose index is the argument, index." self subclassResponsibility! ! !ContextPart methodsFor: 'accessing'! tempAt: index put: value "Store the argument, value, as the temporary variable whose index is the argument, index." self subclassResponsibility! ! !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: '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: 'controlling'! 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: 'controlling' stamp: 'eem 8/29/2008 06:27'! 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'! hasSender: context "Answer whether the receiver is strictly above context on the stack." | s | self == context ifTrue: [^false]. s := sender. [s == nil] whileFalse: [s == context ifTrue: [^true]. s := s sender]. ^false! ! !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: 'controlling' stamp: 'di 1/11/1999 22:40'! pop "Answer the top of the receiver's stack and remove the top of the stack." | val | val := self at: stackp. self stackp: stackp - 1. ^ val! ! !ContextPart methodsFor: 'controlling' stamp: 'di 1/11/1999 22:39'! push: val "Push val on the receiver's stack." self stackp: stackp + 1. self at: stackp put: val! ! !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: 'controlling' stamp: 'ar 3/4/2009 14:57'! restart "Unwind thisContext to self and resume from beginning. Execute unwind blocks when unwinding. ASSUMES self is a sender of thisContext" | ctxt unwindBlock | self isDead ifTrue: [self cannotReturn: nil to: self]. self privRefresh. 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. self jump. ! ! !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: 'controlling' stamp: 'ar 3/4/2009 14:58'! 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 ! ! !ContextPart methodsFor: 'controlling' stamp: 'eem 4/25/2012 10:48'! resume: value through: firstUnwindCtxt "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." | ctxt unwindBlock | self isDead ifTrue: [self cannotReturn: value to: self]. ctxt := firstUnwindCtxt. [ctxt isNil] whileFalse: [(ctxt tempAt: 2) ifNil: [ctxt tempAt: 2 put: true. unwindBlock := ctxt tempAt: 1. thisContext terminateTo: ctxt. unwindBlock value]. ctxt := ctxt findNextUnwindContextUpTo: self]. thisContext terminateTo: self. ^value ! ! !ContextPart methodsFor: 'controlling' stamp: 'ajh 1/21/2003 19:27'! return "Unwind until my sender is on top" self return: self receiver! ! !ContextPart methodsFor: 'controlling' stamp: 'ajh 5/20/2004 17:27'! 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: '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 15:30'! return: value to: sendr "Simulate the return of value to sendr." self releaseTo: sendr. sendr ifNil: [^ nil]. ^ sendr push: value! ! !ContextPart methodsFor: 'controlling' stamp: 'CamilloBruni 2/24/2013 20:42'! 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 ctxt here topContext | here := thisContext. "Insert ensure and exception handler contexts under aSender" error := nil. ctxt := aSender insertSender: (ContextPart contextOn: UnhandledError, Halt do: [:ex | error ifNil: [ "now 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] ]). ctxt := ctxt 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" [ctxt isDead] whileFalse: [topContext := topContext stepToCallee]. {topContext. nil} ] ifNotNil: [ "Error was raised, remove inserted above contexts then return signaler context" aSender terminateTo: ctxt sender. "remove above ensure and handler contexts" {topContext. error} ]. ! ! !ContextPart methodsFor: 'controlling' stamp: 'IgorStasenko 3/16/2012 20:05'! send: selector to: rcvr with: args 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 meth val ctx | class := superFlag ifTrue: [(self method literalAt: self method numLiterals) value superclass] ifFalse: [rcvr class]. meth := class lookupSelector: selector. meth == nil ifTrue: [ ^ self send: #doesNotUnderstand: to: rcvr with: (Array with: (Message selector: selector arguments: args)) super: superFlag]. val := self tryPrimitiveFor: meth receiver: rcvr args: args. "primitive runs without failure?" (self isFailToken: val) ifFalse: [^ val]. (selector == #doesNotUnderstand: and: [ (class canUnderstand: #doesNotUnderstand: ) not ]) ifTrue: [^self error: 'Simulated message ' , (args at: 1) selector, ' not understood']. "failure.. lets activate the method" ctx := self activateMethod: meth withArgs: args receiver: rcvr class: class. "check if activated method handles the error code (a first bytecode will be store into temp)" (ctx method at: ctx pc ) = 129 "long store temp" ifTrue: [ ctx at: ctx stackPtr put: val last ]. ^ ctx! ! !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: 'controlling' stamp: 'ajh 1/24/2003 00:56'! terminate "Make myself unresumable." sender := nil. pc := nil. ! ! !ContextPart methodsFor: 'controlling' stamp: 'ar 3/6/2001 14:26'! 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: 'controlling'! top "Answer the top of the receiver's stack." ^self at: stackp! ! !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'! depthBelow: aContext "Answer how many calls there are between this and aContext." | this depth | this := self. depth := 0. [this == aContext or: [this == nil]] whileFalse: [this := this sender. depth := depth + 1]. ^depth! ! !ContextPart methodsFor: 'debugger access' stamp: 'MarcusDenker 7/13/2012 14:29'! errorReportOn: strm "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." | cnt aContext startPos | strm print: Date today; space; print: Time now; cr. strm cr. strm nextPutAll: 'VM: '; nextPutAll: Smalltalk platform platformName asString; nextPutAll: ' - '; nextPutAll: Smalltalk platform platformSubtype asString; nextPutAll: ' - '; nextPutAll: Smalltalk os version asString; nextPutAll: ' - '; nextPutAll: Smalltalk vm version asString; cr. strm nextPutAll: 'Image: '; nextPutAll: SystemVersion current version asString; nextPutAll: ' ['; nextPutAll: Smalltalk lastUpdateString asString; nextPutAll: ']'; cr. strm 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." cnt := 0. startPos := strm position. aContext := self. [aContext notNil and: [(cnt := cnt + 1) < 40]] whileTrue: [aContext printDetails: strm. "variable values" strm cr. aContext := aContext sender]. strm cr; nextPutAll: '--- The full stack ---'; cr. aContext := self. cnt := 0. [aContext == nil] whileFalse: [cnt := cnt + 1. cnt = 40 ifTrue: [strm nextPutAll: ' - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -'; cr]. strm print: aContext; cr. "just class>>selector" strm position > (startPos+150000) ifTrue: [strm nextPutAll: '...etc...'. ^ self]. "exit early" cnt > 200 ifTrue: [strm nextPutAll: '-- and more not shown --'. ^ self]. aContext := aContext sender].! ! !ContextPart methodsFor: 'debugger access' stamp: 'RAA 5/16/2000 12:14'! longStack "Answer a String showing the top 100 contexts on my sender chain." ^ String streamContents: [:strm | (self stackOfSize: 100) do: [:item | strm print: item; cr]]! ! !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: '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: '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: 'debugger access' stamp: 'ar 7/13/2007 16:52'! 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: 'debugger access'! 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: 'debugger access'! releaseTo: caller "Remove information from the receiver and the contexts on its sender chain up to caller in order to break circularities." | c s | c := self. [c == nil or: [c == caller]] whileFalse: [s := c sender. c singleRelease. c := s]! ! !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: 'debugger access'! sender "Answer the context that sent the message that created the receiver." ^sender! ! !ContextPart methodsFor: 'debugger access' stamp: 'di 8/31/1999 09:42'! shortStack "Answer a String showing the top ten contexts on my sender chain." ^ String streamContents: [:strm | (self stackOfSize: 10) do: [:item | strm print: item; cr]]! ! !ContextPart methodsFor: 'debugger access' stamp: 'ajh 1/24/2003 00:03'! singleRelease "Remove information from the receiver in order to break circularities." stackp == nil ifFalse: [1 to: stackp do: [:i | self at: i put: nil]]. sender := nil. pc := nil. ! ! !ContextPart methodsFor: 'debugger access' stamp: 'MarcusDenker 12/22/2012 17:45'! sourceCode ^self method sourceCode.! ! !ContextPart methodsFor: 'debugger access'! stack "Answer an Array of the contexts on the receiver's sender chain." ^self stackOfSize: 9999! ! !ContextPart methodsFor: 'debugger access' stamp: 'eem 6/1/2008 09:43'! stackOfSize: limit "Answer an OrderedCollection of the top 'limit' contexts on the receiver's sender chain." | stack ctxt | stack := OrderedCollection new. stack addLast: (ctxt := self). [(ctxt := ctxt sender) ~~ nil and: [stack size < limit]] whileTrue: [stack addLast: ctxt]. ^stack! ! !ContextPart methodsFor: 'debugger access'! 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: '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: 'debugger access' stamp: 'MarcusDenker 11/14/2012 17:16'! tempsAndValues "Return a string of the temporary variabls and their current values" | aStream | aStream := (String new: 100) writeStream. self tempNames doWithIndex: [ :title :index | aStream nextPutAll: title; nextPut: $:; space; tab. self print: (self namedTempAt: index) on: aStream. aStream cr]. ^aStream contents! ! !ContextPart methodsFor: 'debugger access' stamp: 'MarcusDenker 11/14/2012 18:18'! tempsAndValuesLimitedTo: sizeLimit indent: indent "Return a string of the temporary variabls and their current values" | aStream | aStream := (String new: 100) writeStream. 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]. ^aStream contents! ! !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'! doDup "Simulate the action of a 'duplicate top of stack' bytecode." self push: self top! ! !ContextPart methodsFor: 'instruction decoding'! doPop "Simulate the action of a 'remove top of stack' bytecode." self pop! ! !ContextPart methodsFor: 'instruction decoding'! jump: distance "Simulate the action of a 'unconditional jump' bytecode whose offset is the argument, distance." pc := pc + distance! ! !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: '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: '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: '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: 'instruction decoding'! 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'! 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: '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: 'instruction decoding'! pushActiveContext "Simulate the action of bytecode that pushes the the active context on the top of its own stack." self push: self! ! !ContextPart methodsFor: 'instruction decoding' stamp: 'eem 8/29/2008 06:28'! 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: 'instruction decoding'! pushConstant: value "Simulate the action of bytecode that pushes the constant, value, on the top of the stack." self push: value! ! !ContextPart methodsFor: 'instruction decoding'! 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: 'instruction decoding' stamp: 'eem 5/27/2008 11:32'! pushNewArrayOfSize: arraySize self push: (Array new: arraySize)! ! !ContextPart methodsFor: 'instruction decoding'! 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'! 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: '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: '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: 'instruction decoding' stamp: 'ajh 3/5/2004 03:44'! 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 ctxt | aSender isDead ifTrue: [ ^ self send: #cannotReturn: to: self with: {value} super: false]. newTop := aSender sender. ctxt := self findNextUnwindContextUpTo: newTop. ctxt ifNotNil: [ ^ self send: #aboutToReturn:through: to: self with: {value. ctxt} super: false]. self releaseTo: newTop. newTop ifNotNil: [newTop push: value]. ^ newTop ! ! !ContextPart methodsFor: 'instruction decoding' stamp: 'IgorStasenko 3/16/2012 20:05'! 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 answer | 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'! 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: 'instruction decoding'! 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: '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: '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: 'mirror primitives' stamp: 'MarcusDenker 1/25/2011 13:11'! 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: '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: '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: '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: 'printing' stamp: 'HenrikSperreJohansen 6/28/2010 12:20'! printDetails: strm "Put my class>>selector and arguments and temporaries on the stream. Protect against errors during printing." | str | self printOn: strm. strm cr; tab; nextPutAll: 'Arguments and temporary variables: '; cr. str := [self tempsAndValuesLimitedTo: 80 indent: 2] ifError: [ '<>']. strm nextPutAll: str. strm peekLast == Character cr ifFalse: [strm cr].! ! !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: 'MarianoMartinezPeck 8/23/2012 09:56'! shortDebugStackOn: aStream "print the top 30 contexts on my sender chain." ^ self debugStack: 30 on: aStream! ! !ContextPart methodsFor: 'query' stamp: 'ajh 7/21/2003 09:59'! bottomContext "Return the last context (the first context invoked) in my sender chain" ^ self findContextSuchThat: [:c | c sender isNil]! ! !ContextPart methodsFor: 'query' stamp: 'ajh 1/27/2003 18:35'! copyStack ^ self copyTo: nil! ! !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:12'! 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 sender. ]. ^ nil! ! !ContextPart methodsFor: 'query' stamp: 'md 1/20/2006 16:15'! 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." | sec ctxt bot | sec := self. ctxt := self. [ bot := ctxt findSimilarSender. bot isNil ] whileFalse: [ sec := ctxt. ctxt := bot. ]. ^ sec ! ! !ContextPart methodsFor: 'query' stamp: 'md 1/20/2006 16:14'! findSimilarSender "Return the closest sender with the same method, return nil if none found" | meth | meth := self method. ^ self sender findContextSuchThat: [:c | c method == meth]! ! !ContextPart methodsFor: 'query' stamp: 'ajh 1/24/2003 19:42'! hasContext: aContext "Answer whether aContext is me or one of my senders" ^ (self findContextSuchThat: [:c | c == aContext]) notNil! ! !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: 'query' stamp: 'eem 11/26/2008 20:21'! isContext ^true! ! !ContextPart methodsFor: 'query' stamp: 'ajh 1/24/2003 00:04'! isDead "Has self finished" ^ pc isNil! ! !ContextPart methodsFor: 'query' stamp: 'ajh 1/24/2003 22:28'! secondFromBottom "Return the second from bottom of my sender chain" self sender ifNil: [^ nil]. ^ self findContextSuchThat: [:c | c sender sender isNil]! ! !ContextPart methodsFor: 'special context access' stamp: 'ClementBera 10/22/2012 13:18'! exceptionClass "handlercontext only. access temporaries from BlockClosure>>on: do:" ^self tempAt: 1 ! ! !ContextPart methodsFor: 'special context access' stamp: 'ClementBera 10/22/2012 13:18'! exceptionHandlerBlock "handlercontext only. access temporaries from BlockClosure>>on: do:" ^self tempAt: 2 ! ! !ContextPart methodsFor: 'special context access' stamp: 'ClementBera 10/22/2012 13:18'! exceptionHandlerIsActive "handlercontext only. access temporaries from BlockClosure>>on: do:" ^self tempAt: 3 ! ! !ContextPart methodsFor: 'special context access' stamp: 'ClementBera 10/22/2012 13:18'! exceptionHandlerIsActive: aBool "handlercontext only. access temporaries from BlockClosure>>on: do:" self tempAt: 3 put: aBool ! ! !ContextPart methodsFor: 'special context access' stamp: 'ClementBera 10/22/2012 13:19'! unwindBlock "unwindContext only. access temporaries from BlockClosure>>ensure:/ifCurtailed:" ^self tempAt: 1 ! ! !ContextPart methodsFor: 'special context access' stamp: 'ClementBera 10/22/2012 13:19'! unwindComplete "unwindContext only. access temporaries from BlockClosure>>ensure:/ifCurtailed:" ^self tempAt: 2 ! ! !ContextPart methodsFor: 'special context access' stamp: 'ClementBera 10/22/2012 13:19'! unwindComplete: aBool "unwindContext only. access temporaries from BlockClosure>>ensure:/ifCurtailed:" self tempAt: 2 put: aBool ! ! !ContextPart methodsFor: 'system simulation' stamp: 'hmm 7/30/2001 20:43'! completeCallee: aContext "Simulate the execution of bytecodes until a return to the receiver." | ctxt current ctxt1 | ctxt := aContext. [ctxt == current or: [ctxt hasSender: self]] whileTrue: [current := ctxt. ctxt1 := ctxt quickStep. ctxt1 ifNil: [self halt]. ctxt := ctxt1]. ^self stepToSendOrReturn! ! !ContextPart methodsFor: 'system simulation' stamp: 'MarcusDenker 2/27/2012 09:19'! 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: 'system simulation' stamp: 'sig 1/26/2011 12:11'! 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: 'system simulation'! 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: 'system simulation' stamp: 'ajh 1/24/2003 22:54'! stepToCallee "Step to callee or sender" | ctxt | ctxt := self. [(ctxt := ctxt step) == self] whileTrue. ^ ctxt! ! !ContextPart methodsFor: 'system simulation' stamp: 'MarcusDenker 2/27/2012 09:19'! stepToSendOrReturn "Simulate the execution of bytecodes until either sending a message or returning a value to the receiver (that is, until switching contexts)." | ctxt | [self willSend | self willReturn | self willStore] whileFalse: [ ctxt := self step. ctxt == self ifFalse: [self halt. "Caused by mustBeBoolean handling" ^ctxt]]! ! !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: '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' stamp: 'ajh 1/27/2003 21:18'! 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: [:b | b privHome: copy]]. self sender ifNotNil: [ copy privSender: (self sender copyTo: aContext blocks: dict)]. ^ copy! ! !ContextPart methodsFor: 'private' stamp: 'ajh 1/24/2003 00:50'! cut: aContext "Cut aContext and its senders from my sender chain" | ctxt callee | ctxt := self. [ctxt == aContext] whileFalse: [ callee := ctxt. ctxt := ctxt sender. ctxt ifNil: [aContext ifNotNil: [self error: 'aContext not a sender']]. ]. callee privSender: nil. ! ! !ContextPart methodsFor: 'private' stamp: 'CamilloBruni 8/1/2012 16:04'! doPrimitive: primitiveIndex method: meth 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 := meth literals first tryInvokeWithArguments: arguments. ] ifFalse:[ value := self simulatePrimitive: primitiveIndex in: meth receiver: receiver arguments: arguments ]. ^ (self isFailToken: value) ifTrue: [value] ifFalse: [self push: value] ! ! !ContextPart methodsFor: 'private' stamp: 'ajh 7/21/2003 09:59'! insertSender: aContext "Insert aContext and its sender chain between me and my sender. Return new callee of my original sender." | ctxt | ctxt := aContext bottomContext. ctxt privSender: self sender. self privSender: aContext. ^ ctxt! ! !ContextPart methodsFor: 'private'! isFailToken: anObject ^ anObject class == Array and: [ anObject size = 2 and: [(anObject at: 1) == PrimitiveFailToken]]! ! !ContextPart methodsFor: 'private' stamp: 'ajh 1/23/2003 22:35'! privSender: aContext sender := aContext! ! !ContextPart methodsFor: 'private' stamp: 'di 1/11/1999 10:12'! 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: '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: 'private' stamp: 'md 3/19/2012 15:56'! 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. (theMethod at: xpc ) = 129 "long store temp" ifTrue: [ theMethod at: xpc + 1 put: (16r40 + numArgs). theMethod at: xpc + 3 put: (16r10 + numArgs). ]! ! !ContextPart methodsFor: 'private'! simulatePrimitive: primitiveIndex in: method receiver: receiver arguments: arguments | key simulator | key := primitiveIndex = 117 ifTrue: [ | lit | lit := method literalAt: 1. { lit second. lit first } "prim name, module name " ] ifFalse: [ primitiveIndex ]. simulator := self class specialPrimitiveSimulators at: key ifAbsent: [ ^ primitiveIndex = 117 "named primitives" ifTrue:[ self withoutPrimitiveTryNamedPrimitiveIn: method for: receiver withArgs: arguments. "this using 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: 'private' stamp: 'eem 1/19/2009 10:23'! stackPtr "For use only by the SystemTracer and the Debugger, Inspectors etc" ^ stackp! ! !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: 'private' stamp: 'IgorStasenko 3/16/2012 20:05'! tryNamedPrimitiveIn: aCompiledMethod for: aReceiver withArgs: arguments ec ifNotNil: ["If ec 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 ec should be nil) but ec = nil means primitive 218 is not implemented. So interpret -1 to mean the external primitive failed with a nil error code." ec isInteger ifTrue: [ec = -1 ifTrue: [ec := nil] ifFalse: [self primitiveFailed]]. ^ self class primitiveFailTokenFor: ec ]. "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: 'private' stamp: 'IgorStasenko 3/16/2012 20:05'! 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: 'private' stamp: 'md 3/19/2012 15:43'! 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 spec | 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 "^ aReceiver withArgs: arguments executeMethod: theMethod "! ! !ContextPart methodsFor: 'private-exceptions' stamp: 'ClementBera 10/22/2012 13:05'! 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: 'private-exceptions' stamp: 'TPR 8/28/2000 19:27'! findNextHandlerContextStarting "Return the next handler marked context, returning nil if there is none. Search starts with self and proceeds up to nil." | ctx | ctx := self. [ctx isHandlerContext ifTrue:[^ctx]. (ctx := ctx sender) == nil ] whileFalse. ^nil! ! !ContextPart methodsFor: 'private-exceptions' stamp: 'TPR 8/23/2000 16:37'! findNextUnwindContextUpTo: aContext "Return the next unwind marked above the receiver, returning nil if there is none. Search proceeds up to but not including aContext." | ctx | ctx := self. [(ctx := ctx sender) == nil or: [ctx == aContext]] whileFalse: [ ctx isUnwindContext ifTrue: [^ctx]]. ^nil! ! !ContextPart methodsFor: 'private-exceptions' stamp: 'ClementBera 10/22/2012 13:07'! 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:)." | val | ((self exceptionClass handles: exception) and: [self exceptionHandlerIsActive]) ifFalse: [ ^ self nextHandlerContext handleSignal: exception]. exception privHandlerContext: self contextTag. self exceptionHandlerIsActive: false. "disable self while executing handle block" val := [self exceptionHandlerBlock cull: exception] ensure: [self exceptionHandlerIsActive: true]. self return: val. "return from self if not otherwise directed in handle block" ! ! !ContextPart methodsFor: 'private-exceptions' stamp: 'tpr 2/24/2001 21:29'! isHandlerContext ^false! ! !ContextPart methodsFor: 'private-exceptions' stamp: 'TPR 8/28/2000 15:45'! isUnwindContext ^false! ! !ContextPart methodsFor: 'private-exceptions' stamp: 'ajh 2/1/2003 00:20'! nextHandlerContext ^ self sender findNextHandlerContextStarting! ! !ContextPart methodsFor: 'private-exceptions' stamp: 'ClementBera 10/22/2012 13:10'! unwindTo: aContext | ctx unwindBlock | ctx := self. [(ctx := ctx findNextUnwindContextUpTo: aContext) isNil] whileFalse: [ (ctx unwindComplete) ifNil:[ ctx unwindComplete: true. unwindBlock := ctx unwindBlock. unwindBlock value] ]. ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ContextPart class instanceVariableNames: ''! !ContextPart class methodsFor: '*Fuel' stamp: 'MarianoMartinezPeck 5/22/2011 23:44'! newFromFrameSize: aFrameSize ^ super basicNew: aFrameSize! ! !ContextPart class methodsFor: 'accessing'! specialPrimitiveSimulators SpecialPrimitiveSimulators ifNil: [ self initializePrimitiveSimulators ]. ^ SpecialPrimitiveSimulators! ! !ContextPart class methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 1/25/2012 10:54'! tryNamedPrimitiveTemplateMethod ^ TryNamedPrimitiveTemplateMethod! ! !ContextPart class methodsFor: 'examples'! 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: 'examples'! 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 == nil ifFalse: "call only" [tallies add: current printString]. prev := current]]. ^tallies sortedCounts "ContextPart tallyMethods: [3.14159 printString]"! ! !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! ! !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: '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'! basicNew: size self error: 'Contexts must only be created with newForMethod:'! ! !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: '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: 'registering simulated primitives'! simulatePrimitive: primName module: moduleName with: simulator ^ self specialPrimitiveSimulators at: {primName. moduleName} put: simulator! ! !ContextPart class methodsFor: 'registering simulated primitives'! simulatePrimitiveNumber: num with: simulator ^ self specialPrimitiveSimulators at: num put: simulator! ! !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: 'simulation'! initializePrimitiveSimulators "extra primitive simulators can be registered by implementing #registerPrimitiveSimulators method in class side of your class. " SpecialPrimitiveSimulators := Dictionary new. Class allSubclassesDo: [:metaclass | (metaclass methodDict includesKey: #registerPrimitiveSimulators) ifTrue: [ metaclass theNonMetaClass registerPrimitiveSimulators. ] ].! ! !ContextPart class methodsFor: 'simulation' stamp: 'IgorStasenko 3/16/2012 20:05'! initializeTryNamedPrimitiveTemplateMethod | methodNode | methodNode := Compiler new compile: 'tryNamedPrimitive "This method is a template that the Smalltalk simulator uses to execute primitives. See Object documentation whatIsAPrimitive." ^ ContextPart primitiveFailTokenFor: errorCode' in: UndefinedObject classified: nil notifying: #() ifFail: [ self error: 'method source is incorrect'. ]. TryNamedPrimitiveTemplateMethod := (CompiledMethodWithNode generateMethodFromNode: methodNode trailer: CompiledMethodTrailer empty) method. ! ! !ContextPart class methodsFor: 'simulation' stamp: 'IgorStasenko 3/16/2012 20:06'! primitiveFailToken ^ self primitiveFailTokenFor: nil! ! !ContextPart class methodsFor: 'simulation'! primitiveFailTokenFor: errorCode ^ { PrimitiveFailToken. errorCode } ! ! !ContextPart class methodsFor: 'simulation'! 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: '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: '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: '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: 'private' stamp: 'eem 6/19/2008 10:00'! isContextClass ^true! ! Inspector subclass: #ContextVariablesInspector instanceVariableNames: 'fieldList' classVariableNames: '' poolDictionaries: '' category: 'Tools-Debugger'! !ContextVariablesInspector commentStamp: '' prior: 0! I represent a query path into the internal representation of a ContextPart. Typically this is a context at a point in the query path of a Debugger. As a StringHolder, the string I represent is the value of the currently selected variable of the observed temporary variable of the context.! !ContextVariablesInspector methodsFor: 'accessing' stamp: 'eem 5/21/2008 12:31'! fieldList "Refer to the comment in Inspector|fieldList." object == nil ifTrue: [^Array with: 'thisContext']. ^fieldList ifNil:[fieldList := (Array with: 'thisContext' with: 'stack top' with: 'all temp vars') , object tempNames]! ! !ContextVariablesInspector methodsFor: 'accessing' stamp: 'ar 4/11/2006 02:33'! inspect: anObject "Initialize the receiver so that it is inspecting anObject. There is no current selection. Because no object's inspectorClass method answers this class, it is OK for this method to override Inspector >> inspect: " fieldList := nil. object := anObject. self initialize. ! ! !ContextVariablesInspector methodsFor: 'code'! doItContext ^object! ! !ContextVariablesInspector methodsFor: 'code'! doItReceiver ^object receiver! ! !ContextVariablesInspector methodsFor: 'nil' stamp: 'HenrikSperreJohansen 10/17/2009 10:39'! contentsIsString "Hacked so contents empty when deselected" ^ #(0 3) includes: selectionIndex! ! !ContextVariablesInspector methodsFor: 'selecting' stamp: 'eem 7/18/2008 11:18'! replaceSelectionValue: anObject "Refer to the comment in Inspector|replaceSelectionValue:." ^selectionIndex = 1 ifTrue: [object] ifFalse: [object namedTempAt: selectionIndex - 3 put: anObject]! ! !ContextVariablesInspector methodsFor: 'selecting' stamp: 'eem 6/10/2008 09:37'! selection "Refer to the comment in Inspector|selection." selectionIndex = 0 ifTrue:[^'']. selectionIndex = 1 ifTrue: [^object]. selectionIndex = 2 ifTrue: [^object stackPtr > 0 ifTrue: [object top]]. selectionIndex = 3 ifTrue: [^object tempsAndValues]. ^object debuggerMap namedTempAt: selectionIndex - 3 in: object! ! PluggableButtonMorph subclass: #ControlButtonMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !ControlButtonMorph commentStamp: 'gvc 9/23/2008 12:04' prior: 0! Specially themed "control" button. Used for drop-lists, expanders etc.! !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:24'! disabledFillStyle "Return the disabled fillStyle of the receiver." ^self theme controlButtonDisabledFillStyleFor: self! ! !ControlButtonMorph methodsFor: 'as yet unclassified' 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 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: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:23'! mouseOverFillStyle "Return the mouse over fillStyle of the receiver." ^self theme controlButtonMouseOverFillStyleFor: 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 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:58'! pressedBorderStyle "Return the pressed borderStyle of the receiver." ^self theme controlButtonPressedBorderStyleFor: 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: '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 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 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: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: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: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:25'! selectedPressedFillStyle "Return the selected pressed fillStyle of the receiver." ^self theme controlButtonSelectedPressedFillStyleFor: self! ! Object subclass: #Cookie instanceVariableNames: 'contents timeToLive hourGlass defaultValue' classVariableNames: '' poolDictionaries: '' category: 'KeyChain'! !Cookie commentStamp: '' prior: 0! A Cookie is a simple object which kept a value during a defined amount of time.! !Cookie methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/6/2012 23:32'! defaultValue: anObject contents = defaultValue ifTrue: [ contents := anObject ]. defaultValue := anObject! ! !Cookie methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/9/2012 12:59'! timeToLive ^ timeToLive! ! !Cookie methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/6/2012 23:31'! timeToLive: aDuration timeToLive := aDuration! ! !Cookie methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 5/6/2012 23:18'! contents ^ contents! ! !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:22'! defaultTimeToLive ^ Duration minutes: 2! ! !Cookie methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 5/6/2012 23:30'! initialize "Initialization code for Cookie" super initialize. timeToLive := self defaultTimeToLive. defaultValue := nil. contents := defaultValue.! ! FileSystemVisitor subclass: #CopyVisitor instanceVariableNames: 'source dest' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Core-Implementation'! !CopyVisitor commentStamp: 'cwp 11/18/2009 12:30' prior: 0! 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: '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/17/2009 21:06'! copyDirectory: aReference | directory | directory := dest resolve: (aReference relativeTo: source). directory createDirectory! ! !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: 'EstebanLorenzano 4/2/2012 11:38'! visit (PreorderGuide for: self) show: source! ! !CopyVisitor methodsFor: 'visiting' stamp: 'cwp 11/16/2009 10:51'! visitDirectory: anEntry | reference | reference := anEntry reference. reference = source ifTrue: [dest ensureDirectory] ifFalse: [self copyDirectory: reference]! ! !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 class instanceVariableNames: ''! !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! ! FileSystemTreeTest subclass: #CopyVisitorTest instanceVariableNames: 'source dest' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Tests-Core'! !CopyVisitorTest methodsFor: 'running' stamp: 'cwp 2/18/2011 16:40'! createDirectory: aString source createDirectory: (source store pathFromString: aString)! ! !CopyVisitorTest methodsFor: 'running' stamp: 'cwp 2/18/2011 16:40'! createFile: aString source store createFile: (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').! ! AbstractResizerMorph subclass: #CornerGripMorph instanceVariableNames: 'target' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Windows'! !CornerGripMorph commentStamp: 'jmv 1/29/2006 17:15' prior: 0! 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: 'accessing' stamp: 'jmv 2/2/2006 14:24'! defaultWidth ^ 22! ! !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)]! ! !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: '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 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: '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: 'initialize' stamp: 'gvc 4/26/2007 12:08'! initialize super initialize. self extent: self defaultWidth @ self defaultHeight. self layoutFrame: self gripLayoutFrame! ! Object subclass: #CornerRounder instanceVariableNames: 'cornerMasks cornerOverlays underBits' classVariableNames: 'CR0 CR1 CR2' poolDictionaries: '' category: 'Morphic-Support'! !CornerRounder commentStamp: '' prior: 0! 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: '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: '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: '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 instanceVariableNames: ''! !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: '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! ! !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! ! ComposableModel subclass: #CriticBrowser instanceVariableNames: 'criticModel rulesModel checker thread title rbEnvironment removeTestCase cache resetButton logButton' classVariableNames: '' poolDictionaries: '' category: 'Manifest-CriticBrowser'! !CriticBrowser commentStamp: '' prior: 0! I am a browser for the SmallLint Critics Example: | rule environment | rule := RBExcessiveArgumentsRule new. environment := (RBPackageEnvironment new packages: {RPackageSet named: 'Manifest-Core'}). (CriticBrowser openOnRule: rule onEnvironment: environment) ! !CriticBrowser methodsFor: 'accessing'! criticModel ^ criticModel! ! !CriticBrowser methodsFor: 'accessing' stamp: 'SimonAllier 1/24/2013 12:55'! environment ^ rbEnvironment ! ! !CriticBrowser methodsFor: 'accessing' stamp: 'StephaneDucasse 12/22/2012 19:41'! environment: aEnv rbEnvironment := aEnv ! ! !CriticBrowser methodsFor: 'accessing' stamp: 'SimonAllier 1/29/2013 15:27'! logButton ^ logButton ! ! !CriticBrowser methodsFor: 'accessing' stamp: 'SimonAllier 1/21/2013 17:03'! removeTestCase: aBoolean removeTestCase := aBoolean! ! !CriticBrowser methodsFor: 'accessing' stamp: 'SimonAllier 1/29/2013 15:27'! resetButton ^ resetButton ! ! !CriticBrowser methodsFor: 'accessing' stamp: 'SimonAllier 5/22/2012 16:00'! rules: aCompositeRule self rulesModel roots: {aCompositeRule} ! ! !CriticBrowser methodsFor: 'accessing'! rulesModel ^ rulesModel! ! !CriticBrowser methodsFor: 'display'! open window := self openWithSpec. ^ window.! ! !CriticBrowser methodsFor: 'initialization' stamp: 'SimonAllier 2/5/2013 11:39'! initialize "Initialization code for CriticRulesBrowser" super initialize. cache := CriticsCache new. checker := SmalllintManifestChecker new. cache checker: checker. cache browser: self. criticModel cache: cache. ! ! !CriticBrowser methodsFor: 'initialization' stamp: 'SimonAllier 2/8/2013 16:30'! initializeDisplayBlockForRules rulesModel displayBlock: [:rule || falsePositives toDos total text unknown | falsePositives := (cache falsePositiveOf: rule) size. toDos :=(cache toDosOf: rule) size. total := (cache criticsOf: rule) size. unknown := total - falsePositives - toDos. text := String streamContents: [:s | s << rule name << ' (FP: ' << falsePositives asString << ', ToDo: ' << toDos asString << ', Unclassfied: ' << unknown asString << ')' ]. total isZero ifTrue: [ text ] ifFalse: [ falsePositives >= total ifTrue: [ text asText makeAllColor: criticModel falsePositiveColor ] ifFalse: [ text asText makeAllColor: criticModel defaultColor ]]]! ! !CriticBrowser methodsFor: 'initialization' stamp: 'SimonAllier 2/5/2013 11:40'! initializePresenter rulesModel whenSelectedItemChanged: [:rule | (rule isNil or: [ rule isComposite ]) ifFalse: [ criticModel resetSelection. criticModel rule: rule. criticModel setTextModelForNil]]. ! ! !CriticBrowser methodsFor: 'initialization' stamp: 'SimonAllier 1/29/2013 15:38'! initializeWidgets title := 'Critic Browser'. rulesModel := self instantiate: TreeModel. self instantiateModels: #( rulesModel TreeModel resetButton ButtonModel logButton ButtonModel ). self setLogButton. self setResetButton. criticModel := SingleRuleCriticBrowser new. rulesModel childrenBlock: [:rule | rule isComposite ifTrue: [ rule rules ] ifFalse: [ #() ]]. rulesModel menu: [:a :b | self menu: a shifted: b ]. self initializeDisplayBlockForRules. self focusOrder add: rulesModel; add: criticModel! ! !CriticBrowser methodsFor: 'initialization' stamp: 'SimonAllier 2/8/2013 15:34'! setActionLogButtom |text| text := '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)' . ^ [(MorphicUIManager new confirm: text) ifTrue: [ cache logInManifest] ]! ! !CriticBrowser methodsFor: 'initialization' stamp: 'SimonAllier 2/8/2013 15:31'! setActionResetButtom |text| text := 'Do you want to delete the current configuration and create a new configuration ?' . ^ [(MorphicUIManager new confirm: text) ifTrue: [ self delete. SelectPackageBrowser open.] ]! ! !CriticBrowser methodsFor: 'initialization' stamp: 'SimonAllier 2/8/2013 15:32'! setLogButton logButton state: false; label: 'Save Critics'; action: self setActionLogButtom ! ! !CriticBrowser methodsFor: 'initialization' stamp: 'SimonAllier 2/8/2013 15:31'! setResetButton resetButton state: false; label: 'Run new configuration'; action: self setActionResetButtom.! ! !CriticBrowser methodsFor: 'menu' stamp: 'SimonAllier 2/1/2013 16:35'! menu: aMenu shifted: aBoolean aMenu add: 'Browse rule' translated target: self selector: #browseRule; add: 'Inspect result of this rule' translated target: self selector: #InspectResult; "add: 'Do not understand this rule' translated target: self selector: #doNotUnderstandThisRule; add: 'This rule contains a bug' translated target: self selector: #bugRule;" add: 'Reapply this rule' target: self selector: #reapplyThisRule; addLine; add: 'Ban this rule for all packages' translated target: self selector: #addRuleToFalsePositive; add: 'Unban this rule for all packages' translated target: self selector: #removeRuleToFalsePositive; addLine. "add: 'Reset working package sets' translated target: self selector: #resetWorkingConfiguration." ^ aMenu! ! !CriticBrowser methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/24/2012 17:18'! initialExtent ^ 760@370! ! !CriticBrowser methodsFor: 'protocol' stamp: 'SimonAllier 2/8/2013 13:24'! onWindowClosed | text | cache cacheChange ifTrue: [ text := 'Do you want log all false positive in the Manifests before closing the Critics Browser ?' . (MorphicUIManager new confirm: text) ifTrue: [ cache logInManifest ]]. ! ! !CriticBrowser methodsFor: 'protocol'! openWithSpec window := super openWithSpec. ^ window.! ! !CriticBrowser methodsFor: 'protocol' stamp: 'Sd 11/30/2012 17:32'! setTitle: aTitle title := aTitle. self window updateTitle ! ! !CriticBrowser methodsFor: 'protocol' stamp: 'SimonAllier 7/27/2012 11:08'! title ^ title! ! !CriticBrowser methodsFor: 'system annoucements' stamp: 'SimonAllier 1/23/2013 14:42'! 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: 'system annoucements' stamp: 'SimonAllier 1/31/2013 14:09'! classRemoved: anAnnouncement ((rbEnvironment packages gather: [:package | package packageSet packages]) classes anySatisfy: [ :cl | anAnnouncement classRemoved = cl ]) ifFalse: [ ^ self ]. cache itemRemoved: anAnnouncement classRemoved! ! !CriticBrowser methodsFor: 'system annoucements' stamp: 'SimonAllier 8/13/2012 10:26'! methodAdded: anAnnouncement anAnnouncement methodClass isManifest ifFalse: [ ^ self ]. self updateCountOf: rulesModel selectedItem. self updateTree! ! !CriticBrowser methodsFor: 'system annoucements' stamp: 'SimonAllier 1/23/2013 18:13'! 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: 'system annoucements' stamp: 'SimonAllier 2/1/2013 15:02'! methodRemoved: anAnnouncement | classes | classes := (rbEnvironment packages gather: [:package | package packageSet packages]) gather: [:p | p classes]. (classes anySatisfy: [ :cl | anAnnouncement methodClass = cl ]) ifFalse: [ ^ self ]. cache itemRemoved: anAnnouncement methodRemoved! ! !CriticBrowser methodsFor: 'system annoucements' stamp: 'SimonAllier 2/5/2013 11:49'! registerToAnnouncements SystemAnnouncer uniqueInstance weak " on: ClassRemoved send: #classRemoved: to: self;" on: ClassModifiedClassDefinition send: #classModified: to: self; " on: MethodAdded send: #methodAdded: to: self;" on: MethodModified send: #methodModified: to: self; on: MethodRemoved send: #methodRemoved: to: self. self window window announcer on: WindowClosed do: [self onWindowClosed] ! ! !CriticBrowser methodsFor: 'thread' stamp: 'SimonAllier 1/23/2013 16:33'! updateTree thread ifNotNil: [ thread terminate ]. thread := [ WorldState addDeferredUIMessage: [ criticModel updateList. rulesModel updateTree.]] fork.! ! !CriticBrowser methodsFor: 'user interface' stamp: 'SimonAllier 2/1/2013 15:11'! addModelItemsToWindowMenu: aMenu "Add model-related items to the window menu" "super addModelItemsToWindowMenu: aMenu." aMenu addLine; add: 'Clean all manifest' translated target: checker action: #cleanAllManifest; add: 'Reapply all rules' translated target: self action: #reapplyAllRules! ! !CriticBrowser methodsFor: 'private' stamp: 'SimonAllier 1/25/2013 16:23'! InspectResult rulesModel selectedItem ifNotNil: [:rule | Inspector openOn: rule result]! ! !CriticBrowser methodsFor: 'private' stamp: 'SimonAllier 1/31/2013 11:50'! addRuleToFalsePositive rulesModel selectedItem ifNotNil: [ :rule | rule leaves do: [: r | rbEnvironment packages do: [:package | cache addFalsePositiveRule: r forPackage: package]]]. ! ! !CriticBrowser methodsFor: 'private' stamp: 'SimonAllier 2/8/2013 13:33'! applyRules | packageCount nbPackage process rules| rules := rulesModel getRoots 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. package packageSet packages do: [:RPa | checker runRules: rules onPackage: RPa 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: 'BenjaminVanRyseghem 11/24/2012 16:43'! browseRule rulesModel selectedItem ifNotNil: [:rule | rule browse ]! ! !CriticBrowser methodsFor: 'private' stamp: 'SimonAllier 1/25/2013 16:23'! logInManifest cache logInManifest! ! !CriticBrowser methodsFor: 'private' stamp: 'SimonAllier 1/23/2013 16:00'! reapplyAllRules | ruleCount total rule | ruleCount := 0. rule := rulesModel getRoots 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'. "criticModel updateList." rulesModel updateTree! ! !CriticBrowser methodsFor: 'private' stamp: 'SimonAllier 2/1/2013 14:43'! reapplyRule: aRule | oldCritics | oldCritics := aRule critics. aRule resetResult. rbEnvironment packages do: [:package | package packageSet packages do: [:RPa | checker runRules: aRule onPackage: RPa 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: 'private' stamp: 'SimonAllier 1/31/2013 14:13'! reapplyThisRule | rule | rulesModel selectedItem isNil ifTrue: [^ self]. rule := rulesModel selectedItem. rule leaves do: [:each | self reapplyRule: each]. ! ! !CriticBrowser methodsFor: 'private' stamp: 'SimonAllier 1/31/2013 11:50'! removeRuleToFalsePositive rulesModel selectedItem ifNotNil: [ :rule | rule leaves do: [ :r | rbEnvironment packages do: [:package | cache removeFalsePositiveRule: r forPackage: package]]]. ! ! !CriticBrowser methodsFor: 'private' stamp: 'StephaneDucasse 12/22/2012 19:57'! resetWorkingConfiguration "For now we do not remember what was previously selected." CriticWorkingConfiguration reset.! ! !CriticBrowser methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/24/2012 17:29'! taskbarIcon ^ self class icon! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CriticBrowser class instanceVariableNames: ''! !CriticBrowser class methodsFor: 'instance creation' stamp: 'SimonAllier 8/1/2012 11:03'! open | env rules | rules := RBCompositeLintRule allGoodRules rules. env := (RBPackageEnvironment new packages: ((MCWorkingCopy allManagers asOrderedCollection) copyFrom: 1 to: 20)). 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: 'instance creation' stamp: 'SimonAllier 1/21/2013 17:03'! openOnWorkspace: aWorkspace | cbr | cbr := self new rules: aWorkspace rule; environment: aWorkspace environment; removeTestCase: aWorkspace removeTestCase; yourself. cbr openWithSpec. cbr applyRules. cbr rulesModel changed: #listElementAt:.! ! !CriticBrowser class methodsFor: 'instance creation' stamp: 'SimonAllier 2/8/2013 13:15'! packagesGroup: aBuilder | packages target env rules group| target := aBuilder model. (group := target selectedGroups). packages := OrderedCollection new. group do: [:each | each classes do: [:cl | MCWorkingCopy managersForClass: cl do: [:package | packages add: package]]]. rules := RBCompositeLintRule allGoodRules. env := (RBPackageEnvironment new packages: packages ). (aBuilder item: #'Critics Browser') action: [self openOnRule: rules onEnvironment: env]; help: 'Running critics rules on this group'.! ! !CriticBrowser class methodsFor: 'instance creation' stamp: 'SimonAllier 2/8/2013 16:31'! packagesMenu: aBuilder | packages target env rules | target := aBuilder model. packages := OrderedCollection new. target selectedPackages do: [:p | MCWorkingCopy managersForCategory: p packageName do: [:package | packages add: package]]. rules := RBCompositeLintRule allGoodRules. env := (RBPackageEnvironment new packages: packages ). (aBuilder item: #'Critics Browser') action: [self openOnRule: rules onEnvironment: env]; help: 'Running critics rules on this package'.! ! !CriticBrowser class methodsFor: 'menu' stamp: 'SimonAllier 2/1/2013 15:19'! criticsBrowserMenuOn: aBuilder "I build a menu" (aBuilder item: 'Critic Browser') action: [ self openOnCurrentWorkingConfiguration]; order: 10; parent: #Tools; help: 'To manage rule checks'; icon: self icon! ! !CriticBrowser class methodsFor: 'menu' stamp: 'BenjaminVanRyseghem 11/24/2012 17:30'! icon "Answer an icon for the receiver." ^ self theme smallWarningIcon! ! !CriticBrowser class methodsFor: 'menu' stamp: 'SimonAllier 2/1/2013 15:31'! openOnCurrentWorkingConfiguration CriticWorkingConfiguration exists ifTrue: [ ResetWindow new openWithSpec ] ifFalse: [ SelectPackageBrowser open]! ! !CriticBrowser class methodsFor: 'menu'! theme ^ UITheme current! ! !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) ]! ! ComposableModel subclass: #CriticToolbar instanceVariableNames: 'ruleHolder criticHolder browseModel falsepositiveModel transformModel' classVariableNames: '' poolDictionaries: '' category: 'Manifest-CriticBrowser'! !CriticToolbar commentStamp: '' prior: 0! I'am a toolbar for the SmallLint Critics Instance Variables browseModel: criticHolder: falsepositiveModel: ruleHolder: transformModel: browseModel - xxxxx criticHolder - xxxxx falsepositiveModel - xxxxx ruleHolder - xxxxx transformModel - xxxxx ! !CriticToolbar methodsFor: 'accessing'! browseModel ^ browseModel! ! !CriticToolbar methodsFor: 'accessing'! falsepositiveModel ^ falsepositiveModel! ! !CriticToolbar methodsFor: 'accessing'! transformModel ^ transformModel! ! !CriticToolbar methodsFor: 'initialization'! 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: 'initialization' stamp: 'SimonAllier 7/24/2012 14:07'! initializeWidgets! ! !CriticToolbar methodsFor: 'initialization' stamp: 'SimonAllier 9/28/2012 13:55'! 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'! setBrowseModel browseModel state: false; label: 'Browse'; action: [ self browseCritic ]. ! ! !CriticToolbar methodsFor: 'initialization'! setFalsepositiveModel falsepositiveModel state: false; label: 'False Positive'; action: [ ]. ! ! !CriticToolbar methodsFor: 'initialization'! setFocusOrder self focusOrder add: browseModel; add: transformModel; add: falsepositiveModel. ! ! !CriticToolbar methodsFor: 'initialization'! setTransformModel transformModel state: false; label: 'Transform'; action: [ self transformCritic ]. ! ! !CriticToolbar methodsFor: 'initialization'! whenFalsePositiveClickedDo: aBlock self falsepositiveModel whenActionPerformedDo: aBlock! ! !CriticToolbar methodsFor: 'protocol'! critic: aCritic criticHolder contents: aCritic! ! !CriticToolbar methodsFor: 'protocol'! rule: aRule ruleHolder contents: aRule. aRule isTransformationRule ifTrue: [transformModel enabled: true] ifFalse: [transformModel enabled: false] ! ! !CriticToolbar methodsFor: 'private'! browseCritic criticHolder contents ifNotNil: [:elem | elem isBehavior ifTrue: [ elem theNonMetaClass browse] ifFalse: [elem browse] ] ! ! !CriticToolbar methodsFor: 'private'! transformCritic | changeCode rule selection | rule := ruleHolder contents ifNotNil: [:r | r ]. rule isTransformationRule ifFalse: [^ self]. selection := criticHolder contents ifNotNil: [:critic | critic]. selection ifNotNil: [ changeCode := (rule changes detect: [:ch | ((ch changeClassName) = (selection methodClass name)) & (ch selector = selection selector)]) source. selection methodClass compile: changeCode]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CriticToolbar class instanceVariableNames: ''! !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! ! Object subclass: #CriticWorkingConfiguration instanceVariableNames: 'rule environment removeTestCase logInManifest' classVariableNames: 'Current' poolDictionaries: '' category: 'Manifest-CriticBrowser'! !CriticWorkingConfiguration commentStamp: '' prior: 0! 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: 'BenjaminVanRyseghem 11/24/2012 18:04'! environment ^ environment! ! !CriticWorkingConfiguration methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/24/2012 18:04'! environment: anObject environment := anObject! ! !CriticWorkingConfiguration methodsFor: 'accessing' stamp: 'SimonAllier 1/25/2013 17:03'! logInManifest ^ logInManifest! ! !CriticWorkingConfiguration methodsFor: 'accessing' stamp: 'SimonAllier 1/25/2013 17:03'! logInManifest: anObject logInManifest := anObject! ! !CriticWorkingConfiguration methodsFor: 'accessing' stamp: 'SimonAllier 1/21/2013 17:02'! removeTestCase ^ removeTestCase! ! !CriticWorkingConfiguration methodsFor: 'accessing' stamp: 'SimonAllier 1/21/2013 17:02'! removeTestCase: aBoolean removeTestCase := aBoolean! ! !CriticWorkingConfiguration methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/24/2012 18:04'! rule ^ rule! ! !CriticWorkingConfiguration methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/24/2012 18:04'! rule: anObject rule := anObject! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CriticWorkingConfiguration class instanceVariableNames: ''! !CriticWorkingConfiguration class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 11/24/2012 18:05'! current ^ Current ifNil: [ Current := self basicNew initialize ].! ! !CriticWorkingConfiguration class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 11/24/2012 18:05'! new ^ self shouldNotImplement! ! !CriticWorkingConfiguration class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 11/24/2012 18:05'! reset Current := nil! ! !CriticWorkingConfiguration class methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/24/2012 18:11'! exists ^ Current notNil! ! Object subclass: #CriticsCache instanceVariableNames: 'critics toDos falsePositives checker browser falsePositiveRules falsePositiveClasses packages change' classVariableNames: '' poolDictionaries: '' category: 'Manifest-CriticBrowser'! !CriticsCache commentStamp: '' prior: 0! 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: 'accessing' stamp: 'SimonAllier 1/23/2013 13:48'! browser: aCodeCritiicBrowser browser := aCodeCritiicBrowser ! ! !CriticsCache methodsFor: 'accessing' stamp: 'SimonAllier 2/5/2013 11:11'! cacheChange ^ change! ! !CriticsCache methodsFor: 'accessing' stamp: 'SimonAllier 1/23/2013 10:28'! checker: aSmallLintChercker checker := aSmallLintChercker! ! !CriticsCache methodsFor: 'accessing' stamp: 'SimonAllier 1/31/2013 13:50'! packages: aPackageEnv packages := aPackageEnv packages! ! !CriticsCache methodsFor: 'add/remove' stamp: 'SimonAllier 2/5/2013 11:15'! addCritic: aCritic forRule: aRule (critics includesKey: aRule) ifFalse: [critics at:aRule put: IdentitySet new]. (critics at:aRule) add: aCritic. self updateBrowser! ! !CriticsCache methodsFor: 'add/remove' stamp: 'SimonAllier 2/5/2013 11:15'! 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: 'SimonAllier 2/5/2013 11:15'! addFalsePositiveClass: aClass |fp| falsePositiveClasses add: aClass theNonMetaClass. critics keysAndValuesDo: [:rule :criticss | fp := criticss select: [:critic | aClass = (critic isCompiledMethod ifTrue: [critic methodClass theNonMetaClass] ifFalse: [critic])]. fp do: [:each | self addFalsePositive: each forRule: rule ] ]. self updateBrowser ! ! !CriticsCache methodsFor: 'add/remove' stamp: 'SimonAllier 2/4/2013 14:13'! 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]. browser updateTree ! ! !CriticsCache methodsFor: 'add/remove' stamp: 'SimonAllier 2/5/2013 11:15'! addToDo: aCritic forRule: aRule (toDos includesKey: aRule) ifFalse: [toDos at:aRule put: IdentitySet new]. (toDos at:aRule) add: aCritic. self updateBrowser! ! !CriticsCache methodsFor: 'add/remove' stamp: 'SimonAllier 2/5/2013 11:15'! itemRemoved: aItem critics values do: [:each | each remove: aItem ifAbsent: []]. toDos values do: [:each | each remove: aItem ifAbsent: []]. falsePositives values do: [:each | each remove: aItem ifAbsent: []]. self updateBrowser ! ! !CriticsCache methodsFor: 'add/remove' stamp: 'SimonAllier 2/5/2013 11:15'! removeCritic: aCritic forRule: aRule (critics includesKey: aRule) ifFalse: [^ self]. (critics at:aRule) remove: aCritic ifAbsent: [^ self]. self updateBrowser ! ! !CriticsCache methodsFor: 'add/remove' stamp: 'SimonAllier 2/5/2013 11:16'! removeFalsePositive: aCritic forRule: aRule (falsePositives includesKey: aRule) ifFalse: [^ self]. (falsePositiveClasses includes: (aCritic isCompiledMethod ifTrue: [aCritic methodClass theNonMetaClass] ifFalse: [aCritic])) ifTrue: [^ self]. (falsePositives at:aRule) remove: aCritic ifAbsent: [^ self]. self updateBrowser ! ! !CriticsCache methodsFor: 'add/remove' stamp: 'SimonAllier 1/25/2013 14:32'! removeFalsePositiveClass: aClass |fp| falsePositiveClasses remove: aClass ifAbsent: [^ self]. critics keysAndValuesDo: [:rule :criticss | fp := criticss select: [:critic | aClass = (critic isCompiledMethod ifTrue: [critic methodClass theNonMetaClass] ifFalse: [critic])]. fp do: [:each | self removeFalsePositive: each forRule: rule ] ]. browser updateTree. ! ! !CriticsCache methodsFor: 'add/remove' stamp: 'SimonAllier 2/5/2013 11:16'! 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 isCompiledMethod ifTrue: [c methodClass theNonMetaClass] ifFalse: [c])) not]]. fp do: [:c | self removeFalsePositive: c forRule: aRule]. 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: 'initialize-release' stamp: 'SimonAllier 1/31/2013 11:18'! 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: 'initialize-release' stamp: 'SimonAllier 2/5/2013 11:08'! initialize falsePositives := Dictionary new. toDos := Dictionary new. critics := Dictionary new. falsePositiveRules := Dictionary new. falsePositiveClasses := IdentitySet new. change := false ! ! !CriticsCache methodsFor: 'protocol' stamp: 'CamilloBruni 2/22/2013 22:41'! criticsOf: aRule (aRule isNil "or: [aRule isEmpty]" ) ifTrue: [ ^ {} ]. ^ aRule isComposite ifTrue: [ aRule leaves gather: [:rule | self criticsOf: rule]] ifFalse: [ critics at: aRule ifAbsent: [{}]]! ! !CriticsCache methodsFor: 'protocol' stamp: 'SimonAllier 1/28/2013 13:34'! falsePositiveOf: aRule aRule ifNil: [ ^ {}]. ^ aRule isComposite ifTrue: [ aRule leaves gather: [:rule | self falsePositiveOf: rule]] ifFalse: [falsePositives at: aRule ifAbsent: [{}]] ! ! !CriticsCache methodsFor: 'protocol' stamp: 'SimonAllier 2/5/2013 11:20'! logInManifest self cacheChange ifFalse: [^ self]. self logFalsePositiveRulesInManifest. self logFalsePositiveClassInManifest. self logFalsePositiveInManifest. self logToDosInManifest. self cacheNotChanged. self initCache ! ! !CriticsCache methodsFor: 'protocol' stamp: 'SimonAllier 1/31/2013 11:20'! replaceAll: oldMethod by: newMethod critics values do: [:each | (each includes: oldMethod) ifTrue: [ each remove: oldMethod. each add: newMethod ]]. falsePositives values do: [:each | (each includes: oldMethod) ifTrue: [ each remove: oldMethod. each add: newMethod ]]. toDos values do: [:each | (each includes: oldMethod) ifTrue: [ each remove: oldMethod. each add: newMethod ]]. browser updateTree ! ! !CriticsCache methodsFor: 'protocol' stamp: 'SimonAllier 1/28/2013 13:34'! toDosOf: aRule aRule ifNil: [ ^ {}]. ^ aRule isComposite ifTrue: [ aRule leaves gather: [:rule | self toDosOf: rule]] ifFalse: [toDos at: aRule ifAbsent: [{}]]! ! !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: 'private' stamp: 'SimonAllier 1/25/2013 14:51'! addAllCriticToFalsePositive: aCollectionOfCritic forRule: aRule on: aManifestBuilder | ruleId versionId criticss | criticss := aCollectionOfCritic reject: [:c | falsePositiveClasses includes: (c isCompiledMethod ifTrue: [c methodClass theNonMetaClass] ifFalse:[c])]. 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: 'SimonAllier 1/25/2013 13:41'! 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: 'private' stamp: 'SimonAllier 2/5/2013 11:11'! cacheChanged change := true! ! !CriticsCache methodsFor: 'private' stamp: 'SimonAllier 2/5/2013 11:11'! cacheNotChanged change := false! ! !CriticsCache methodsFor: 'private' stamp: 'SimonAllier 2/1/2013 12:55'! logFalsePositiveClassInManifest | manifestBuilder | packages do: [:package | manifestBuilder := BuilderManifest ofPackageNamed: package packageName. (manifestBuilder rejectClasses \ falsePositiveClasses) do: [:cl | manifestBuilder removeRejectClass: cl]. (falsePositiveClasses \ manifestBuilder rejectClasses) do: [:cl | manifestBuilder addRejectClass: cl]]. ! ! !CriticsCache methodsFor: 'private' stamp: 'SimonAllier 2/1/2013 12:56'! logFalsePositiveInManifest |rId rV removeFp addFp| falsePositives keysAndValuesDo: [:rule :criticss | rId := rule class uniqueIdentifierName. rV := rule class identifierMinorVersionNumber. removeFp := (checker falsePositiveOf: rule) \ criticss. addFp := criticss \ (checker falsePositiveOf: rule). (removeFp groupedBy: [:each | BuilderManifest of: each]) keysAndValuesDo: [:manifestBuilder :value | self removeAllCriticToFalsePositive: value forRule: rule on: manifestBuilder]. (addFp groupedBy: [:each | BuilderManifest of: each]) keysAndValuesDo: [:manifestBuilder :value | (manifestBuilder rejectRules includes: (rule class uniqueIdentifierName)) ifFalse: [ self addAllCriticToFalsePositive: value forRule: rule on: manifestBuilder]] ]. ! ! !CriticsCache methodsFor: 'private' stamp: 'SimonAllier 2/1/2013 14:52'! logFalsePositiveRulesInManifest | manifestBuilder | falsePositiveRules keysAndValuesDo: [:package :rules | manifestBuilder := BuilderManifest ofPackageNamed: package packageName. (manifestBuilder rejectRules \ rules) do: [:rule | manifestBuilder removeRejectRule: rule]. (rules \ manifestBuilder rejectRules) do: [:rule | manifestBuilder addRejectRule: rule]]. ! ! !CriticsCache methodsFor: 'private' stamp: 'SimonAllier 2/1/2013 12:57'! logToDosInManifest |rId rV removeFp addFp| toDos keysAndValuesDo: [:rule :criticss | rId := rule class uniqueIdentifierName. rV := rule class identifierMinorVersionNumber. removeFp := (checker toDoOf: rule) \ criticss. addFp := criticss \ (checker toDoOf: rule). (removeFp groupedBy: [:each | BuilderManifest of: each]) keysAndValuesDo: [:manifestBuilder :value | self removeAllCriticToToDo: value forRule: rule on: manifestBuilder]. (addFp groupedBy: [:each | BuilderManifest of: each]) keysAndValuesDo: [:manifestBuilder :value | (manifestBuilder rejectRules includes: (rule class uniqueIdentifierName)) ifFalse: [ self addAllCriticToToDo: value forRule: rule on: manifestBuilder]] ]. ! ! !CriticsCache methodsFor: 'private' stamp: 'SimonAllier 1/25/2013 15:28'! packageOf: aCritc aCritc isCompiledMethod ifTrue: [MCWorkingCopy managersForClass: (aCritc methodClass) selector: (aCritc selector) do: [: package | ^ package ]] ifFalse: [MCWorkingCopy managersForClass: aCritc do: [: package | ^ package ]] ! ! !CriticsCache methodsFor: 'private' stamp: 'SimonAllier 1/25/2013 15:09'! 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: 'private' stamp: 'SimonAllier 1/25/2013 13:41'! 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: 'private' stamp: 'SimonAllier 2/5/2013 11:19'! updateBrowser self cacheChanged. browser updateTree ! ! Array variableSubclass: #Cubic instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Basic'! !Cubic commentStamp: 'wiz 6/17/2004 20:31' prior: 0! 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'! 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 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:14'! leeway "How close can measure be" ^ 0.1! ! !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 class instanceVariableNames: ''! !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}! ! Announcement subclass: #CurrentChangeSetChanged instanceVariableNames: 'new old' classVariableNames: '' poolDictionaries: '' category: 'System-Changes'! !CurrentChangeSetChanged methodsFor: 'accessing' stamp: 'StephaneDucasse 11/2/2012 14:22'! new ^ new! ! !CurrentChangeSetChanged methodsFor: 'accessing' stamp: 'StephaneDucasse 11/2/2012 14:22'! new: anObject new := anObject! ! !CurrentChangeSetChanged methodsFor: 'accessing' stamp: 'StephaneDucasse 11/2/2012 14:23'! old ^ old! ! !CurrentChangeSetChanged methodsFor: 'accessing' stamp: 'StephaneDucasse 11/2/2012 16:37'! old: anObject old := anObject ! ! Form subclass: #Cursor instanceVariableNames: '' classVariableNames: 'BlankCursor BottomLeftCursor BottomRightCursor CornerCursor CrossHairCursor CurrentCursor DownCursor MarkerCursor MenuCursor MoveCursor NormalCursor OriginCursor OverEditableText ReadCursor ResizeLeftCursor ResizeTopCursor ResizeTopLeftCursor ResizeTopRightCursor RightArrowCursor SquareCursor TargetCursor TopLeftCursor TopRightCursor UpCursor WaitCursor WebLinkCursor WriteCursor XeqCursor' poolDictionaries: '' category: 'Graphics-Display Objects'! !Cursor commentStamp: '' prior: 0! 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: '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 methodsFor: 'converting' stamp: 'bf 2/2/1999 19:32'! withMask ^CursorWithMask derivedFrom: self! ! !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: '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: 'primitives'! 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: '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: 'printing'! printOn: aStream self storeOn: aStream base: 2! ! !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: '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 class instanceVariableNames: ''! !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'! blank "Answer the instance of me that is all white." ^BlankCursor! ! !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:13'! bottomRight "Cursor bottomRight showWhile: [Sensor waitButton]" ^BottomRightCursor ! ! !Cursor class methodsFor: 'constants'! corner "Answer the instance of me that is the shape of the bottom right corner of a rectangle." ^CornerCursor! ! !Cursor class methodsFor: 'constants'! crossHair "Answer the instance of me that is the shape of a cross." ^CrossHairCursor! ! !Cursor class methodsFor: 'constants'! down "Answer the instance of me that is the shape of an arrow facing downward." ^DownCursor! ! !Cursor class methodsFor: 'constants'! 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: 'constants'! marker "Answer the instance of me that is the shape of a small ball." ^MarkerCursor! ! !Cursor class methodsFor: 'constants'! menu "Answer the instance of me that is the shape of a menu." ^MenuCursor! ! !Cursor class methodsFor: 'constants'! move "Answer the instance of me that is the shape of a cross inside a square." ^MoveCursor! ! !Cursor class methodsFor: 'constants'! normal "Answer the instance of me that is the shape of an arrow slanted left." ^NormalCursor! ! !Cursor class methodsFor: 'constants'! origin "Answer the instance of me that is the shape of the top left corner of a rectangle." ^OriginCursor! ! !Cursor class methodsFor: 'constants' stamp: 'AlainPlantec 12/22/2010 18:15'! overEditableText ^ OverEditableText ! ! !Cursor class methodsFor: 'constants'! read "Answer the instance of me that is the shape of eyeglasses." ^ReadCursor! ! !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:46'! resizeBottomLeft "Cursor resizeBottomLeft showWhile: [Sensor waitButton]" ^self resizeTopRight! ! !Cursor class methodsFor: 'constants' stamp: 'ar 8/16/2001 14:45'! resizeBottomRight "Cursor resizeBottomRight showWhile: [Sensor waitButton]" ^self resizeTopLeft! ! !Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 18:58'! resizeLeft "Cursor resizeLeft showWhile: [Sensor waitButton]" ^ResizeLeftCursor! ! !Cursor class methodsFor: 'constants' stamp: 'ar 8/16/2001 14:45'! resizeRight "Cursor resizeRight showWhile: [Sensor waitButton]" ^self resizeLeft! ! !Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:19'! resizeTop "Cursor resizeTop showWhile: [Sensor waitButton]" ^ResizeTopCursor! ! !Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:00'! resizeTopLeft "Cursor resizeTopLeft showWhile: [Sensor waitButton]" ^ ResizeTopLeftCursor! ! !Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:00'! resizeTopRight "Cursor resizeTopRight showWhile: [Sensor waitButton]" ^ResizeTopRightCursor! ! !Cursor class methodsFor: 'constants'! rightArrow "Answer the instance of me that is the shape of an arrow pointing to the right." ^RightArrowCursor! ! !Cursor class methodsFor: 'constants'! square "Answer the instance of me that is the shape of a square." ^SquareCursor! ! !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: 'constants' stamp: 'JMM 10/21/2003 19:01'! topLeft "Cursor topLeft showWhile: [Sensor waitButton]" ^ TopLeftCursor! ! !Cursor class methodsFor: 'constants' stamp: 'JMM 10/21/2003 19:02'! topRight "Cursor topRight showWhile: [Sensor waitButton]" ^ TopRightCursor! ! !Cursor class methodsFor: 'constants'! up "Answer the instance of me that is the shape of an arrow facing upward." ^UpCursor! ! !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: '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'! write "Answer the instance of me that is the shape of a pen writing." ^WriteCursor! ! !Cursor class methodsFor: 'current cursor'! currentCursor "Answer the instance of Cursor that is the one currently displayed." ^CurrentCursor! ! !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: '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: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: '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'! 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: 'initialization'! 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: '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: '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: 'initialization'! 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: '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'! 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: '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: '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: '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: '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: '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: '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: 'initialization'! 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: '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: '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: '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: '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: 'initialization'! 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: '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: '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'! 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: '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: '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'! startUp self currentCursor: self currentCursor! ! !Cursor class methodsFor: 'instance creation'! 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: '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: '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 subclass: #CursorWithAlpha instanceVariableNames: 'fallback' classVariableNames: 'Constants' poolDictionaries: '' category: 'Graphics-Display Objects'! !CursorWithAlpha commentStamp: '' prior: 0! 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:57'! fallback ^fallback ifNil: [NormalCursor]! ! !CursorWithAlpha methodsFor: 'accessing' stamp: 'bf 3/30/2007 18:58'! fallback: aCursor fallback := aCursor! ! !CursorWithAlpha methodsFor: 'converting' stamp: 'MarcusDenker 4/10/2011 10:14'! asCursorForm ^ Form newFrom: self! ! !CursorWithAlpha methodsFor: 'primitives' stamp: 'yo 5/11/2007 16:20'! primBeCursor self fallback primBeCursor! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CursorWithAlpha class instanceVariableNames: ''! !CursorWithAlpha class methodsFor: '*Morphic' stamp: 'ar 3/9/2010 22:39'! biggerNormal "self biggerNormal showWhile:[Sensor waitButton]" "(Base64MimeConverter mimeEncode: ((FileStream readOnlyFileNamed: 'EtoysCursor.png') binary)) upToEnd" ^self constants at: #biggerNormal ifAbsentPut: [ | form cursor | form := (PNGReadWriter on: (Base64MimeConverter mimeDecodeToBytes: 'iVBORw0KGgoAAAANSUhEUgAAABsAAAArCAYAAACJrvP4AAAACXBIWXMAAAsTAAALEwEAmpwY AAAEF0lEQVRYCb2XS0hcVxjHj2/G8ZWMQQbSGO2iRhERwRALBmJNoOOqwUXtYtxOTQJxI8SN CyXJqggVEghusrAuBB8IddUWF64CvnCj+AJrsYKio6JJOPn/j+dc5s6MztyZMR/857v3PL7f /c4595w7QmiTUvrN9ZV7wGhfB3jOunpgOoYtPQQm19fXn6DsulY2PJUSi4ARvLm5+SuiE5hS mAsBXSYzv99vLuXExMRL1H2jlRKoDYbAMhS4uLj4PJUwN4K5TTqEhQPHxsZeayCzTCrDqLC0 tLQryTAqjNmFA1OR4YWwaMBk5/BSWDRgMhnGhEUDJpphXDACqdDXIpEMHcHCF43TDB3Bks0w IVj4kMabYcKwcGA8c+gIlp2drRaKGc5wYKwMHcFycnIiYOHACzLkhi9SAgsHRsnQOSzaMBJk FPoejo6OvkJ5iZY67R1lZoJe5kOBKysrzxzBCgoKrCcnpKysTO7v75sjMKafmZl5gX6uNPww M4EeQXrsEAJDJc7Ozngr8vPzRVVVldjZ2RGrq6uqrLi4WPT394u2tjZxeHj4P8C7qiLkJzMz 8zNvc3NzT+jR/yl9xDBmZWWpTAoLC2V9fb3c29uTXV1dtuwaGxtVRgcHBzuI0QY91vLBUw+0 voOnXPyyijBEUWWVlZViampKFBUVCcyDKC8vt9pitYnp6WlmfqO7u/uOVRHjIiKzjIwM2dDQ oDIKnZCWlhZbdoFAQFUvLCz8Bcb3WrfgqWItFR/XKrEIWG1trQWam5v7Z3Bw8C2jjoyMyNLS UgvIYeYQ05A5h5HA+GE1NTVWgPn5+b/RubWiosJ/enoaZNDq6moLhjrZ19fHYjk7O/sO9/eg G1oZ8JTNbJmZJ9Wgn9GyleJQMWhPT48NhnllsTw+Pv4X7WLCuI1YX8TsuLy8/CfKmrXuwt9t b2//iXX4LJder9cCut1uOT4+zio5PDz8G9pWaqm4uLaZDaZBXLY2GO4bdnd3PzAowDZYc3Mz i+X29vY82l0K4ypR/2JOTk7e49qsIuMLUEbdXFpaes6gk5OT0uPxWECeBGtra6ySvb29v6Bt ve7DfjZTsKOjo99RyvkzEOMtGOpuBoPBbQblQsK9Ejfnzs5OFsuNjY0JlF8IQ11clodWeVgo bxh0YGDABmOmNGxzh2j3EPJqRV2VqLvUFKyjo+NHBuWqxb4nS0pKVFZmGFG+gihJw8wTerHx /kEgXng6y7a2thYxnAHAHkHfavEcoxyZBcOh+AOHixS+7HwnfT4f/6nynSQoaZh5MjWcTU1N 94aGhtrr6up8qLgPcVFQd7SuwVPmIdN5njk1wmi31a8QHu3VuYVrLhDaf+dOHGgvE4Gp3RsB cnUQMx+f9P1H7c9PXyHUIcoy01HXX637AibwgHAnFRPGAAAAAElFTkSuQmCC' readStream) readStream) nextImage. cursor := CursorWithAlpha extent: form extent depth: 32. form displayOn: cursor. cursor offset: -2 @ -1. cursor preMultiplyAlpha. cursor]! ! !CursorWithAlpha class methodsFor: 'constants' stamp: 'bf 3/30/2007 18:47'! constants ^Constants ifNil: [Constants := Dictionary new]! ! !CursorWithAlpha class methodsFor: 'constants' stamp: 'bf 8/17/2009 12:56'! resetConstants Constants := nil. ! ! Cursor subclass: #CursorWithMask instanceVariableNames: 'maskForm' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Display Objects'! !CursorWithMask commentStamp: '' prior: 0! 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: '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: 'bf 2/2/1999 19:34'! hasMask ^true! ! !CursorWithMask methodsFor: 'mask' stamp: 'di 10/8/1998 16:46'! maskForm ^ maskForm! ! !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 methodsFor: 'mask' stamp: 'bf 2/2/1999 19:31'! withMask ^self! ! !CursorWithMask methodsFor: 'primitives' stamp: 'di 10/6/1998 15:16'! beCursor maskForm unhibernate. ^ self beCursorWithMask: maskForm! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CursorWithMask class instanceVariableNames: ''! !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! ! PolygonMorph subclass: #CurveMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Basic'! !CurveMorph commentStamp: '' prior: 0! 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: 'wiz 1/7/2005 20:02'! 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 instanceVariableNames: ''! !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! ! Object subclass: #CustomHelp instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Utilities'! !CustomHelp commentStamp: 'tbn 3/29/2010 13:23' prior: 0! 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 instanceVariableNames: ''! !CustomHelp class methodsFor: 'accessing' stamp: 'tbn 3/29/2010 13:20'! bookName "Returns the name of the custom help book" ^'Help'! ! !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! ! !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'! 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: '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: '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: '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]. ! ! HelpBuilder subclass: #CustomHelpHelpBuilder instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Builders'! !CustomHelpHelpBuilder commentStamp: 'tbn 3/29/2010 13:30' prior: 0! 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! ! TestCase subclass: #CustomHelpTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Tests-Core-Utilities'! !CustomHelpTest methodsFor: 'testing' stamp: 'tbn 1/14/2011 01:41'! testOpenBrowserOnThisHelpType |block| block := [ |browser| browser := HelpBrowser openOn: CustomHelp. World doOneCycleNow. browser close ]. self shouldnt: block raise: Error ! ! TestCase subclass: #CustomParserTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CompilerTests'! !CustomParserTest methodsFor: 'tests' stamp: 'StephaneDucasse 1/12/2011 15:42'! testCustomParser "Test whether the compiler uses a custom parser class to parse the source code. This custom parser class is answered by the class side #parserClass message, instead of default one" "self debug: #testCustomParser" | compiler result | compiler := self class compilerClass new. "let compiler initialize its class ivar" result := compiler parse: ' a ^1 + 1' in: self class notifying: nil. self assert: compiler parserClass == MockCustomParser ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! CustomParserTest class instanceVariableNames: ''! !CustomParserTest class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 1/10/2011 19:03'! parserClass ^ MockCustomParser! ! QuestionDialogWindow subclass: #CustomQuestionDialogWindow instanceVariableNames: 'yesButton noButton cancelButton' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Windows'! !CustomQuestionDialogWindow commentStamp: 'gvc 9/23/2008 11:59' prior: 0! QuestionDialog supporting custom text/buttons for yes/no choices.! !CustomQuestionDialogWindow methodsFor: 'accessing' stamp: 'GaryChambers 8/23/2010 11:36'! cancelButton ^ cancelButton! ! !CustomQuestionDialogWindow methodsFor: 'accessing' stamp: 'GaryChambers 8/23/2010 11:36'! cancelButton: anObject cancelButton := anObject! ! !CustomQuestionDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/10/2008 11:30'! noButton "Answer the value of noButton" ^ noButton! ! !CustomQuestionDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/10/2008 11:30'! noButton: anObject "Set the value of noButton" noButton := anObject! ! !CustomQuestionDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/10/2008 11:30'! yesButton "Answer the value of yesButton" ^ yesButton! ! !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 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]! ! !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: 'as yet unclassified' stamp: 'GaryChambers 8/23/2010 12:16'! defaultCancelButton "Answer a default cancel button." ^self newCancelButton! ! !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 11:36'! initialize "Initialize the receiver." self yesButton: self defaultYesButton; noButton: self defaultNoButton; cancelButton: self defaultCancelButton. super initialize! ! !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'! 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: '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]! ! Object subclass: #DamageRecorder instanceVariableNames: 'invalidRects totalRepaint' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Support'! !DamageRecorder methodsFor: 'initialization' stamp: 'sma 6/5/2000 11:55'! reset "Clear the damage list." invalidRects := OrderedCollection new: 15. totalRepaint := false ! ! !DamageRecorder methodsFor: 'recording'! doFullRepaint "Record that a full redisplay is needed. No further damage rectangles will be recorded until after the next reset." ^ totalRepaint := true. ! ! !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 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: 'testing' stamp: 'dgd 2/22/2003 14:43'! updateIsNeeded "Return true if the display needs to be updated." ^totalRepaint or: [invalidRects notEmpty]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DamageRecorder class instanceVariableNames: ''! !DamageRecorder class methodsFor: 'instance creation'! new ^ super new reset ! ! SimpleBorder subclass: #DashedBorder instanceVariableNames: 'dashColors dashLengths' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Borders'! !DashedBorder commentStamp: 'gvc 5/18/2007 13:28' prior: 0! Border style supporting dashed lines of configurable patterns and colours.! !DashedBorder methodsFor: 'accessing' stamp: 'gvc 4/24/2007 15:48'! dashColors "Answer the value of dashColors" ^ dashColors! ! !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 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: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'gvc 4/24/2007 15:50'! initialize "Initialize the receiver." super initialize. self dashColors: {Color black. Color white}; dashLengths: #(1 1)! ! !DashedBorder methodsFor: 'as yet unclassified' stamp: 'gvc 8/8/2007 17:21'! style "Answer #dashed." ^#dashed! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DashedBorder class instanceVariableNames: ''! !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! ! Timespan subclass: #Date instanceVariableNames: '' classVariableNames: '' poolDictionaries: 'ChronologyConstants' category: 'Kernel-Chronology'! !Date commentStamp: '' prior: 0! 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: '*Fuel' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^ aGeneralMapper visitHookPrimitive: self ! ! !Date methodsFor: '*Fuel' stamp: 'MaxLeske 2/18/2013 22:36'! serializeOn: anEncoder start serializeOn: anEncoder! ! !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: '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: '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: 'BP 3/23/2001 12:27'! printOn: aStream self printOn: aStream format: #(1 2 3 $ 3 1 )! ! !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: 'printing' stamp: 'BP 3/23/2001 12:27'! storeOn: aStream aStream print: self printString; nextPutAll: ' asDate'! ! !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: 'smalltalk-80' stamp: 'brp 8/23/2003 22:09'! addDays: dayCount ^ (self asDateAndTime + (dayCount days)) asDate! ! !Date methodsFor: 'smalltalk-80' 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: 'smalltalk-80' 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: 'smalltalk-80' 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: 'smalltalk-80' stamp: 'brp 8/23/2003 22:05'! subtractDays: dayCount ^ (self asDateAndTime - (dayCount days)) asDate! ! !Date methodsFor: 'smalltalk-80' 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: 'smalltalk-80' stamp: 'brp 8/24/2003 12:04'! weekdayIndex "Sunday=1, ... , Saturday=7" ^ self dayOfWeek! ! !Date methodsFor: 'squeak protocol' stamp: 'sd 3/16/2008 14:43'! asDate ^ self! ! !Date methodsFor: 'squeak protocol' 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: 'squeak protocol' stamp: 'avi 2/21/2004 18:12'! month ^ self asMonth! ! !Date methodsFor: 'squeak protocol' stamp: 'avi 2/29/2004 13:10'! monthIndex ^ super month! ! !Date methodsFor: 'utils' stamp: 'tbn 7/11/2006 10:30'! 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 newDay: day month: month year: year! ! !Date methodsFor: 'utils' stamp: 'spfa 3/8/2004 13:52'! onNextMonth ^ self addMonths: 1 ! ! !Date methodsFor: 'utils' stamp: 'spfa 3/8/2004 13:52'! onPreviousMonth ^ self addMonths: -1 ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Date class instanceVariableNames: ''! !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: '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: 'importing' stamp: 'StephaneDucasse 5/1/2010 16:13'! 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 isNil ifTrue: ["MM DD YY" day := Integer readFrom: aStream] ifFalse: [ year isNil ifTrue: ["DD MM YY" day := parsedNumber]]] ifFalse: ["MM-DD-YY or DD-MM-YY or YY-MM-DD" year isNil ifTrue: ["MM-DD-YY or DD-MM-YY" parsedNumber > 12 ifTrue: ["DD-MM-YY" day := parsedNumber. month := Month nameOfMonth: (Integer readFrom: aStream)] ifFalse: ["MM-DD-YY" month := Month nameOfMonth: parsedNumber. day := Integer readFrom: aStream]] ifFalse: ["YY-MM-DD" month := Month nameOfMonth: (Integer readFrom: aStream)]]. [aStream peek isAlphaNumeric] whileFalse: [aStream skip: 1]. year isNil ifTrue: [year := Integer readFrom: aStream] ifFalse: [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: 'importing' stamp: 'StephaneDucasse 1/31/2010 21:47'! readFrom: inputStream pattern: pattern "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." | day month year patternStream char | patternStream := pattern readStream. [patternStream atEnd] whileFalse: [ inputStream atEnd ifTrue: [^nil]. char := patternStream next. char = $\ ifTrue: [inputStream next = patternStream next ifFalse: [^nil]] ifFalse: [ char = $y ifTrue: [ (patternStream nextMatchAll: 'yyy') ifTrue: [year := (inputStream next: 4) asInteger] ifFalse: [ (patternStream peekFor: $y) ifTrue: [ year := (inputStream next: 2) asInteger] ifFalse: [ year := Integer readFrom: inputStream]]] ifFalse: [ char = $m ifTrue: [ (patternStream peekFor: $m) ifTrue: [ month := (inputStream next: 2) asInteger] ifFalse: [ month := Integer readFrom: inputStream]] ifFalse: [ char = $d ifTrue: [ (patternStream peekFor: $d) ifTrue: [ day := (inputStream next: 2) asInteger] ifFalse: [ day := Integer readFrom: inputStream]] ifFalse: [ inputStream next = char ifFalse: [^nil]]]]]]. (year isNil | month isNil | day isNil) ifTrue: [^nil]. ^self year: year month: month day: day! ! !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: '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: 'instance creation' stamp: 'brp 7/27/2003 18:25'! julianDayNumber: aJulianDayNumber ^ self starting: (DateAndTime julianDayNumber: aJulianDayNumber)! ! !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: '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: 'instance creation' stamp: 'brp 7/27/2003 16:01'! newDay: dayCount year: yearInteger ^ self year: yearInteger day: dayCount! ! !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: 'instance creation' stamp: 'sd 3/16/2008 14:57'! today ^ self current! ! !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 22:03'! year: year day: dayOfYear ^ self starting: (DateAndTime year: year day: dayOfYear) ! ! !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: 'instance creation' stamp: 'brp 7/1/2003 18:09'! yesterday ^ self today previous! ! !Date class methodsFor: 'simple queries' stamp: 'sd 3/16/2008 14:57'! dateAndTimeNow "Answer an Array whose with Date today and Time now." ^ Time dateAndTimeNow! ! !Date class methodsFor: 'simple queries' stamp: 'brp 7/1/2003 13:35'! dayOfWeek: dayName ^ Week indexOfDay: dayName! ! !Date class methodsFor: 'simple queries' stamp: 'brp 7/1/2003 13:59'! daysInMonth: monthName forYear: yearInteger ^ Month daysInMonth: monthName forYear: yearInteger. ! ! !Date class methodsFor: 'simple queries' stamp: 'brp 7/1/2003 13:53'! daysInYear: yearInteger ^ Year daysInYear: yearInteger.! ! !Date class methodsFor: 'simple queries' stamp: 'brp 1/16/2004 14:35'! firstWeekdayOfMonth: month year: year "Answer the weekday index of the first day in in the ." ^ (self newDay: 1 month: month year: year) weekdayIndex ! ! !Date class methodsFor: 'simple queries' stamp: 'brp 7/1/2003 13:39'! indexOfMonth: aMonthName ^ Month indexOfMonth: aMonthName. ! ! !Date class methodsFor: 'simple queries' stamp: 'brp 7/1/2003 13:56'! leapYear: yearInteger ^ Year leapYear: yearInteger! ! !Date class methodsFor: 'simple queries' stamp: 'brp 7/1/2003 13:37'! nameOfDay: dayIndex ^ Week nameOfDay: dayIndex ! ! !Date class methodsFor: 'simple queries' stamp: 'brp 7/1/2003 13:40'! nameOfMonth: anIndex ^ Month nameOfMonth: anIndex. ! ! !Date class methodsFor: 'specific inquiries' stamp: 'BG 3/16/2005 14:57'! 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 newDay: day month: 3 year: year ] ifFalse: [Date newDay: day - 31 month: 4 year: year].! ! !Date class methodsFor: 'specific inquiries' stamp: 'BG 3/16/2005 14:48'! 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 newDay: 3 month: 4 year: year. ^date addDays: rc.! ! Magnitude subclass: #DateAndTime instanceVariableNames: 'seconds offset julianDayNumber nanos' classVariableNames: 'ClockProvider DaysSinceEpoch LastMilliSeconds LastTick LastTickSemaphore LocalTimeZone MilliSecondOffset OffsetsAreValid' poolDictionaries: 'ChronologyConstants' category: 'Kernel-Chronology'! !DateAndTime commentStamp: 'sd 3/16/2008 14:58' prior: 0! I represent a point in UTC time as defined by ISO 8601. I have zero duration. My implementation uses three SmallIntegers and a Duration: jdn - julian day number. seconds - number of seconds since midnight. nanos - the number of nanoseconds since the second. offset - duration from UTC. The nanosecond attribute is almost always zero but it defined for full ISO compliance and is suitable for timestamping. ! !DateAndTime methodsFor: '*Fuel' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^ aGeneralMapper visitHookPrimitive: self ! ! !DateAndTime methodsFor: '*Fuel' stamp: 'MarianoMartinezPeck 7/22/2012 23:28'! fuelSet: julianDay nanoSecond: nanoSeconds seconds: numberOfSeconds offset: anOffset julianDayNumber := julianDay. nanos := nanoSeconds. seconds := numberOfSeconds. offset := anOffset.! ! !DateAndTime methodsFor: '*Fuel' stamp: 'MaxLeske 2/18/2013 22:36'! serializeOn: anEncoder anEncoder encodeUint32: self julianDayNumberUTC; encodeUint32: self nanoSecond; encodeInt24: self secondsSinceMidnight; encodeInt24: self offset asSeconds; encodeInt32: self offset nanoSeconds.! ! !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 9/13/2009 07:49'! setTimestampInMetacelloVersion: aMetacelloVersionSpec aMetacelloVersionSpec setTimestamp: (aMetacelloVersionSpec project valueHolderSpec value: self printString; yourself)! ! !DateAndTime methodsFor: 'accessing' stamp: 'brp 7/1/2003 17:53'! day ^ self dayOfYear! ! !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: 'CamilloBruni 3/30/2032 18:26'! dayOfWeek "Sunday=1, ... , Saturday=7" ^ (julianDayNumber + 1 rem: 7) + 1! ! !DateAndTime methodsFor: 'accessing' stamp: 'sd 3/16/2008 15:04'! dayOfWeekAbbreviation ^ self dayOfWeekName copyFrom: 1 to: 3! ! !DateAndTime methodsFor: 'accessing' stamp: 'sd 3/16/2008 15:04'! dayOfWeekName ^ Week nameOfDay: self dayOfWeek ! ! !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: 'brp 5/13/2003 07:48'! daysInMonth "Answer the number of days in the month represented by the receiver." ^ self asMonth daysInMonth! ! !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: '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: 'accessing' stamp: 'sd 3/16/2008 15:01'! duration ^ Duration zero! ! !DateAndTime methodsFor: 'accessing' stamp: 'brp 7/27/2003 15:44'! firstDayOfMonth ^ self asMonth start day! ! !DateAndTime methodsFor: 'accessing' stamp: 'sd 3/16/2008 15:04'! hour ^ self hour24 ! ! !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: 'accessing' stamp: 'CamilloBruni 7/13/2012 19:09'! 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 rem: SecondsInDay) / SecondsInHour) floor % 24! ! !DateAndTime methodsFor: 'accessing' stamp: 'brp 7/1/2003 18:30'! hours ^ self hour! ! !DateAndTime methodsFor: 'accessing' stamp: 'sd 3/16/2008 15:05'! isLeapYear ^ Year isLeapYear: self year. ! ! !DateAndTime methodsFor: 'accessing' stamp: 'CamilloBruni 7/12/2012 18:52'! julianDayNumber ^ julianDayNumber + self julianDayOffset! ! !DateAndTime methodsFor: 'accessing' stamp: 'CamilloBruni 7/17/2012 18:27'! julianDayNumberUTC ^ julianDayNumber! ! !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: 'accessing' stamp: 'CamilloBruni 7/13/2012 19:01'! localSeconds " Return the seconds since the epoch in local time." ^ seconds + self offset asSeconds! ! !DateAndTime methodsFor: 'accessing' stamp: 'sd 3/16/2008 15:05'! meridianAbbreviation ^ self asTime meridianAbbreviation! ! !DateAndTime methodsFor: 'accessing' stamp: 'CamilloBruni 7/13/2012 19:10'! 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 rem: SecondsInHour) / SecondsInMinute) floor % 60! ! !DateAndTime methodsFor: 'accessing' stamp: 'brp 1/7/2004 15:45'! minutes ^ self minute! ! !DateAndTime methodsFor: 'accessing' stamp: 'sd 3/16/2008 15:05'! month ^ self dayMonthYearDo: [ :d :m :y | m ].! ! !DateAndTime methodsFor: 'accessing' stamp: 'sd 3/16/2008 15:05'! monthAbbreviation ^ self monthName copyFrom: 1 to: 3 ! ! !DateAndTime methodsFor: 'accessing' stamp: 'brp 5/13/2003 07:50'! monthIndex ^ self month ! ! !DateAndTime methodsFor: 'accessing' stamp: 'sd 3/16/2008 15:05'! monthName ^ Month nameOfMonth: self month ! ! !DateAndTime methodsFor: 'accessing' stamp: 'sd 3/16/2008 15:02'! nanoSecond ^ nanos ! ! !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: 'sd 3/16/2008 15:06'! offset ^ offset ! ! !DateAndTime methodsFor: 'accessing' stamp: 'sd 3/16/2008 15:06'! offset: anOffset "Answer a equivalent to the receiver but with its local time being offset from UTC by offset." ^ self class basicNew ticks: self ticks offset: anOffset asDuration; yourself ! ! !DateAndTime methodsFor: 'accessing' stamp: 'CamilloBruni 7/13/2012 19:02'! 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 rem: SecondsInMinute) % 60! ! !DateAndTime methodsFor: 'accessing' stamp: 'brp 7/1/2003 18:31'! seconds ^ self second! ! !DateAndTime methodsFor: 'accessing' stamp: 'CamilloBruni 7/13/2012 16:44'! timeZone ^ TimeZone offset: self offset! ! !DateAndTime methodsFor: 'accessing' stamp: 'CamilloBruni 7/13/2012 16:43'! timeZoneAbbreviation ^ self timeZone abbreviation ! ! !DateAndTime methodsFor: 'accessing' stamp: 'CamilloBruni 7/13/2012 16:43'! timeZoneName ^ self timeZone name ! ! !DateAndTime methodsFor: 'accessing' stamp: 'sd 3/16/2008 15:06'! year ^ self dayMonthYearDo: [:d :m :y | y ]! ! !DateAndTime methodsFor: 'arithmetic' stamp: 'CamilloBruni 7/13/2012 20:12'! + operand "operand conforms to protocol Duration" | ticks | ticks := self ticks with: (operand asDuration ticks) collect: [:ticks1 :dticks | ticks1 + dticks ]. ^ self class basicNew ticks: ticks offset: self offset; yourself. ! ! !DateAndTime methodsFor: 'arithmetic' stamp: 'brp 1/9/2004 05:39'! - operand "operand conforms to protocol DateAndTime or protocol Duration" ^ (operand respondsTo: #asDateAndTime) ifTrue: [ | lticks rticks | lticks := self asLocal ticks. rticks := operand asDateAndTime asLocal ticks. Duration seconds: (SecondsInDay *(lticks first - rticks first)) + (lticks second - rticks second) nanoSeconds: (lticks third - rticks third) ] ifFalse: [ self + (operand negated) ]. ! ! !DateAndTime methodsFor: 'arithmetic' stamp: 'CamilloBruni 7/13/2012 20:29'! < comparand "comparand conforms to protocol DateAndTime, or can be converted into something that conforms." | other utcSeconds otherUTCSeconds | other := comparand asDateAndTime. julianDayNumber < other julianDayNumber ifTrue: [ ^ true ]. utcSeconds := self asSeconds. otherUTCSeconds := other asSeconds. ^ utcSeconds = otherUTCSeconds ifFalse: [ utcSeconds < otherUTCSeconds ] ifTrue: [ nanos < other nanoSecond ]! ! !DateAndTime methodsFor: 'arithmetic' stamp: 'CamilloBruni 7/13/2012 18:54'! = other self == other ifTrue: [ ^ true ]. (self species = other species) ifFalse: [ ^ false ]. ^ self asSeconds = other asSeconds and: [ self nanoSecond = other nanoSecond ]! ! !DateAndTime methodsFor: 'converting' stamp: 'sd 3/16/2008 15:00'! asDate ^ Date starting: self! ! !DateAndTime methodsFor: 'converting' stamp: 'sd 3/16/2008 15:00'! asDateAndTime ^ self ! ! !DateAndTime methodsFor: 'converting' stamp: 'SeanDeNigris 5/21/2012 18:35'! asDosTime self deprecated: 'Use asDosTimestamp' on: '21 May 2012' in: 'Pharo 2.0'. ^ self asDosTimestamp.! ! !DateAndTime methodsFor: 'converting' stamp: 'SeanDeNigris 5/21/2012 17:34'! asDosTimestamp ^ (DosTimestamp fromDateAndTime: self) value. ! ! !DateAndTime methodsFor: 'converting' stamp: 'CamilloBruni 7/13/2012 19:26'! asDuration "Answer the duration since midnight." ^ Duration seconds: self localSeconds 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: 'converting' stamp: 'sd 3/16/2008 15:01'! asMonth ^ Month starting: self ! ! !DateAndTime methodsFor: 'converting' stamp: 'sd 3/16/2008 15:01'! asNanoSeconds "Answer the number of nanoseconds since midnight" ^ self asDuration asNanoSeconds ! ! !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: 'converting' stamp: 'CamilloBruni 7/13/2012 19:26'! asTime ^ Time seconds: self localSeconds nanoSeconds: nanos! ! !DateAndTime methodsFor: 'converting' stamp: 'brp 8/24/2003 00:02'! asTimeStamp ^ self as: TimeStamp! ! !DateAndTime methodsFor: 'converting' stamp: 'CamilloBruni 7/13/2012 19:57'! asUTC ^ offset isZero ifTrue: [ self ] ifFalse: [ self offset: 0 ] ! ! !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: 'converting' stamp: 'sd 3/16/2008 15:01'! asWeek ^ Week starting: self ! ! !DateAndTime methodsFor: 'converting' stamp: 'sd 3/16/2008 15:01'! asYear ^ Year starting: self! ! !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: '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: '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: '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: '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: 'maintime' stamp: 'CamilloBruni 7/13/2012 20:43'! midnight "Answer a DateAndTime starting at midnight local time" self dayMonthYearDo: [ :day :month :year| ^self class year: year month: month day: day offset: offset ].! ! !DateAndTime methodsFor: 'offset' stamp: 'CamilloBruni 7/13/2012 21:07'! 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: 'offset' stamp: 'CamilloBruni 7/13/2012 19:52'! translateToUTC " Move this reprsenation to UTC" ^ self translateTo: 0 asDuration ! ! !DateAndTime methodsFor: 'offset' stamp: 'CamilloBruni 7/13/2012 16:37'! utcOffset: anOffset self deprecated: 'Use offset: instead' on: '7/13/2012 16:36' in: 'Pharo 2.0'. ^ self offset: anOffset! ! !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 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: '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: '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: '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: '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: 'truncation' stamp: 'StephaneDucasse 10/18/2010 14:07'! rounded "Answer a date and time to the nearest whole second" ^ NanosInSecond / 2 >= self nanoSecond abs ifTrue: [self species fromSeconds: self asSeconds] ifFalse: [self species fromSeconds: self asSeconds + 1]! ! !DateAndTime methodsFor: 'truncation' stamp: 'StephaneDucasse 10/18/2010 14:08'! truncated "Answer a date and time to the nearest preceding whole second" ^ self species year: self year month: self month day: self dayOfMonth hour: self hour minute: self minute second: self second offset: self offset ! ! !DateAndTime methodsFor: 'private' stamp: 'CamilloBruni 3/30/2032 18:26'! hasEqualTicks: aDateAndTime ^ (julianDayNumber = aDateAndTime julianDayNumber) and: [ (seconds = aDateAndTime secondsSinceMidnight) and: [ nanos = aDateAndTime nanoSecond ] ] ! ! !DateAndTime methodsFor: 'private' stamp: 'CamilloBruni 3/30/2032 18:26'! hash | totalSeconds | totalSeconds := seconds - offset asSeconds. ^ ((totalSeconds // 86400 + julianDayNumber) hashMultiply bitXor: totalSeconds \\ 86400) bitXor: nanos! ! !DateAndTime methodsFor: 'private' stamp: 'CamilloBruni 7/13/2012 20:17'! normalize: i ticks: ticks base: base | tick div quo rem | tick := ticks at: i. div := tick digitDiv: base neg: tick negative. quo := (div at: 1) normalize. rem := (div at: 2) normalize. rem < 0 ifTrue: [ quo := quo - 1. rem := base + rem ]. ticks at: (i-1) put: ((ticks at: i-1) + quo). ticks at: i put: rem ! ! !DateAndTime methodsFor: 'private' stamp: 'brp 7/28/2004 16:20'! secondsSinceMidnight ^ seconds! ! !DateAndTime methodsFor: 'private' stamp: 'CamilloBruni 8/12/-4693 18:26'! setJdn: julDays seconds: secs nano: nanoSecs offset: anOffset julianDayNumber := julDays. seconds := secs. nanos := nanoSecs. offset := anOffset.! ! !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: 'private' stamp: 'CamilloBruni 7/13/2012 20:18'! ticks: ticks offset: utcOffset "ticks is {julianDayNumber. secondCount. nanoSeconds}" self normalize: 3 ticks: ticks base: NanosInSecond. self normalize: 2 ticks: ticks base: SecondsInDay. julianDayNumber := ticks at: 1. seconds := ticks at: 2. nanos := ticks at: 3. offset := utcOffset! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DateAndTime class instanceVariableNames: ''! !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: 'clock provider' stamp: 'kph 12/11/2006 20:14'! clock "the provider of real time seconds/milliseconds." ^ ClockProvider ! ! !DateAndTime class methodsFor: 'initialize-release' stamp: 'dtl 7/13/2009 13:08'! initialize super initialize. ClockProvider := Time. LastTickSemaphore := Semaphore forMutualExclusion. LastMilliSeconds := 0. LastTick := 0. Smalltalk addToStartUpList: self. self startUp: true ! ! !DateAndTime class methodsFor: 'initialize-release' stamp: 'ul 11/6/2010 23:37'! initializeOffsets | durationSinceEpoch secondsSinceMidnight nowSecs | LastTick := 0. nowSecs := self clock secondsWhenClockTicks. LastMilliSeconds := self millisecondClockValue. durationSinceEpoch := Duration days: SqueakEpoch hours: 0 minutes: 0 seconds: nowSecs. DaysSinceEpoch := durationSinceEpoch days. secondsSinceMidnight := (durationSinceEpoch - (Duration days: DaysSinceEpoch hours: 0 minutes: 0 seconds: 0)) asSeconds. MilliSecondOffset := secondsSinceMidnight * 1000 - LastMilliSeconds! ! !DateAndTime class methodsFor: 'initialize-release' stamp: 'ul 11/6/2010 23:32'! startUp: resuming resuming ifFalse: [ ^ self ]. OffsetsAreValid := false. [ self initializeOffsets. OffsetsAreValid := true ] forkAt: Processor userInterruptPriority.! ! !DateAndTime class methodsFor: 'initialize-release' stamp: 'jmv 10/19/2010 14:10'! waitForOffsets OffsetsAreValid ifFalse: [ [ (Delay forSeconds: 1) wait. OffsetsAreValid ] whileFalse ]! ! !DateAndTime class methodsFor: 'input' stamp: 'damiencassou 5/30/2008 10:56'! fromString: aString ^ self readFrom: aString readStream! ! !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: 'input' stamp: 'CamilloBruni 7/20/2012 15:46'! readFrom: aStream | offset date time ch | date := Date readFrom: aStream. [aStream peek isDigit] whileFalse: [aStream next]. time := Time readFrom: aStream. aStream atEnd ifTrue: [ offset := self localOffset ] ifFalse: [ |upToEnd| ch := aStream next. ch = $+ ifTrue: [ch := Character space]. upToEnd := aStream upTo: Character space. (upToEnd includes: $:) ifFalse: [ upToEnd := (upToEnd first: 2), ':', (upToEnd allButFirst: 2)]. offset := Duration fromString: ch asString, '0:', upToEnd, ':0']. ^ self year: date year month: date monthIndex day: date dayOfMonth hour: time hour minute: time minute second: time second nanoSecond: time nanoSecond offset: offset " '-1199-01-05T20:33:14.321-05:00' asDateAndTime ' 2002-05-16T17:20:45.1+01:01' asDateAndTime ' 2002-05-16T17:20:45.02+01:01' asDateAndTime ' 2002-05-16T17:20:45.003+01:01' asDateAndTime ' 2002-05-16T17:20:45.0004+01:01' asDateAndTime ' 2002-05-16T17:20:45.00005' asDateAndTime ' 2002-05-16T17:20:45.000006+01:01' asDateAndTime ' 2002-05-16T17:20:45.0000007+01:01' asDateAndTime ' 2002-05-16T17:20:45.00000008-01:01' asDateAndTime ' 2002-05-16T17:20:45.000000009+01:01' asDateAndTime ' 2002-05-16T17:20:45.0000000001+01:01' asDateAndTime ' 2002-05-16T17:20' asDateAndTime ' 2002-05-16T17:20:45' asDateAndTime ' 2002-05-16T17:20:45+01:57' asDateAndTime ' 2002-05-16T17:20:45-02:34' asDateAndTime ' 2002-05-16T17:20:45+00:00' asDateAndTime ' 1997-04-26T01:02:03+01:02:3' asDateAndTime "! ! !DateAndTime class methodsFor: 'instance creation' stamp: 'sd 3/16/2008 15:07'! date: aDate time: aTime ^ self year: aDate year day: aDate dayOfYear hour: aTime hour minute: aTime minute second: aTime second ! ! !DateAndTime class methodsFor: 'instance creation' stamp: 'SeanDeNigris 5/21/2012 18:35'! fromDosTime: anInteger self deprecated: 'Use fromDosTimestamp:' on: '21 May 2012' in: 'Pharo 2.0'. ^ self fromDosTimestamp: anInteger.! ! !DateAndTime class methodsFor: 'instance creation' stamp: 'SeanDeNigris 5/21/2012 17:00'! fromDosTimestamp: anInteger ^ (DosTimestamp on: anInteger) asDateAndTime.! ! !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' 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: 'instance creation' stamp: 'CamilloBruni 7/17/2012 17:02'! fromUnixTime: anInteger ^ self fromSeconds: anInteger + 2177452800 "unix epoch constant"! ! !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: '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: '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: 'CamilloBruni 7/17/2012 15:51'! now " [ 10000 timesRepeat: [ self now. ] ] timeToRun / 10000.0 . If calls to DateAndTime-c-#now are within a single millisecond the semaphore code to ensure that (self now <= self now) slows things down considerably by a factor of about 20. The actual speed of a single call to DateAndTime-now in milliseconds is demonstrated by the unguarded method below. [ 100000 timesRepeat: [ self todayAtMilliSeconds: (self milliSecondsSinceMidnight) ] ] timeToRun / 100000.0 . 0.00494 0.00481 0.00492 0.00495 " | nanoTicks msm | nanoTicks := (msm := self milliSecondsSinceMidnight) * 1000000. (LastTick < nanoTicks) ifTrue: [ LastTick := nanoTicks. ^ self todayAtMilliSeconds: msm]. LastTickSemaphore critical: [ LastTick := LastTick + 1. ^ self todayAtNanoSeconds: LastTick]! ! !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: '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: '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: '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' 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/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: '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: '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:07'! current ^ self now ! ! !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: '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 queries' stamp: 'sd 3/16/2008 15:07'! midnight ^ self now midnight ! ! !DateAndTime class methodsFor: 'instance creation queries' stamp: 'sd 3/16/2008 15:08'! noon ^ self now noon! ! !DateAndTime class methodsFor: 'instance creation queries' stamp: 'sd 3/16/2008 15:08'! today ^ self midnight ! ! !DateAndTime class methodsFor: 'instance creation queries' stamp: 'sd 3/16/2008 15:08'! tomorrow ^ self today asDate next 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 queries' stamp: 'sd 3/16/2008 15:09'! yesterday ^ self today asDate previous asDateAndTime ! ! !DateAndTime class methodsFor: 'smalltalk-80' stamp: 'kph 12/11/2006 21:13'! millisecondClockValue ^ self clock millisecondClockValue! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'ul 11/6/2010 23:38'! milliSecondsSinceMidnight | msm msClock | "This is usually only during system startup..." self waitForOffsets. msClock := self millisecondClockValue. msClock < LastMilliSeconds ifTrue: [ "rolled over" MilliSecondOffset := MilliSecondOffset + (SmallInteger maxVal // 2) + 1 ]. LastMilliSeconds := msClock. [ msm := msClock + MilliSecondOffset. msm >= 86400000 ] whileTrue: [ "next day" LastTick := -1. DaysSinceEpoch := DaysSinceEpoch + 1. MilliSecondOffset := MilliSecondOffset - 86400000 ]. "day rolled over sanity check" (LastTick = -1 and: [ (Duration days: SqueakEpoch hours: 0 minutes: 0 seconds: self clock totalSeconds) days ~= DaysSinceEpoch ]) ifTrue: [ self initializeOffsets. ^ self milliSecondsSinceMidnight ]. ^ msm.! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'CamilloBruni 7/17/2012 08:29'! todayAtMilliSeconds: milliSecondsSinceMidnight "This is usually only during system startup... [ 100000 timesRepeat: [ self fromMilliSeconds: self milliSecondsSinceMidnight. ] ] timeToRun. " | offset milliSecondsSinceMidnightUTC | self waitForOffsets. offset := self localOffset. milliSecondsSinceMidnightUTC := milliSecondsSinceMidnight - offset asMilliSeconds. ^ self basicNew setJdn: DaysSinceEpoch seconds: (milliSecondsSinceMidnightUTC // 1000) nano: (milliSecondsSinceMidnightUTC \\ 1000 * 1000000 ) offset: offset! ! !DateAndTime class methodsFor: 'squeak protocol' stamp: 'CamilloBruni 7/17/2012 08:29'! todayAtNanoSeconds: nanoSecondsSinceMidnight "This is usually only during system startup..." | offset nanoSecondsSinceMidnightUTC | self waitForOffsets. offset := self localOffset. nanoSecondsSinceMidnightUTC := nanoSecondsSinceMidnight - offset asNanoSeconds. ^ self basicNew setJdn: DaysSinceEpoch seconds: (nanoSecondsSinceMidnightUTC // 1000000000) nano: (nanoSecondsSinceMidnightUTC \\ 1000000000) offset: offset ! ! !DateAndTime class methodsFor: 'system queries' stamp: 'gk 8/31/2006 00:49'! clockPrecision "One nanosecond precision" ^ Duration seconds: 0 nanoSeconds: 1 ! ! !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: 'system queries' stamp: 'BenjaminVanRyseghem 2/19/2013 17:09'! totalSeconds "Answer the total seconds since the Squeak epoch: 1 January 1901 in UTC" ^ Time totalSeconds - (self localOffset asSeconds)! ! !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: '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 ! ! TestCase subclass: #DateAndTimeDosEpochTest instanceVariableNames: 'aDateAndTime aDuration aTimeZone localTimeZoneToRestore' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Chronology'! !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: '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: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testAsDate self assert: aDateAndTime asDate = 'January 1, 1980' asDate. ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testAsDateAndTime self assert: aDateAndTime asDateAndTime = aDateAndTime ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testAsDuration self assert: aDateAndTime asDuration = 0 asDuration ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' stamp: 'CamilloBruni 7/13/2012 16:36'! testAsLocal self assert: aDateAndTime asLocal = aDateAndTime. self assert: aDateAndTime asLocal = (aDateAndTime offset: aDateAndTime class localOffset) ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:32'! testAsMonth self assert: aDateAndTime asMonth = (Month month: 'January' year: 1980). ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testAsNanoSeconds self assert: aDateAndTime asNanoSeconds = 0 asDuration asNanoSeconds ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:32'! testAsSeconds self assert: aDateAndTime asSeconds = 2492985600 ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testAsTime self assert: aDateAndTime asTime = Time midnight. ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:32'! testAsTimeStamp self assert: aDateAndTime asTimeStamp = (TimeStamp fromString: '1 January 1980 12:00 am').! ! !DateAndTimeDosEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testAsUTC self assert: aDateAndTime asUTC = aDateAndTime ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:32'! testAsWeek self assert: aDateAndTime asWeek = (Week starting: '12-31-1979' asDate). ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:33'! testAsYear self assert: aDateAndTime asYear = (Year starting: '01-01-1980' asDate). ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testCurrent self deny: aDateAndTime = (DateAndTime current). ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:33'! testDateTime self assert: aDateAndTime = (DateAndTime date: '01-01-1980' asDate time: '00:00:00' asTime) ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testDay self assert: aDateAndTime day = DateAndTime new day ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' 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: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testDayOfMonth self assert: aDateAndTime dayOfMonth = 1. ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' 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: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testDayOfYear self assert: aDateAndTime dayOfYear = 1. ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testDaysInMonth self assert: aDateAndTime daysInMonth = 31. ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:33'! testDaysInYear self assert: aDateAndTime daysInYear = 366. ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:34'! testDaysLeftInYear self assert: aDateAndTime daysLeftInYear = 365. ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testDuration self assert: aDateAndTime duration = 0 asDuration. ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:34'! testEpoch self assert: aDateAndTime = '1980-01-01T00:00:00+00:00' asDateAndTime ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testFirstDayOfMonth self assert: aDateAndTime firstDayOfMonth = 1 ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:34'! testFromSeconds self assert: aDateAndTime = (DateAndTime fromSeconds: 2492985600). ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' 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: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:34'! testHash self assert: aDateAndTime hash = (DateAndTime year: 1980 month: 1 day: 1) hash! ! !DateAndTimeDosEpochTest methodsFor: 'testing' 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: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testHour12 self assert: aDateAndTime hour12 = DateAndTime new hour12. self assert: aDateAndTime hour12 = 12 ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:35'! testIsLeapYear self assert: aDateAndTime isLeapYear ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:35'! testJulianDayNumber self assert: aDateAndTime = (DateAndTime julianDayNumber: 2444240). self assert: aDateAndTime julianDayNumber = 2444240.! ! !DateAndTimeDosEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testLessThan self assert: aDateAndTime < (aDateAndTime + '1:00:00:00'). self assert: aDateAndTime + -1 < aDateAndTime. ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testMeridianAbbreviation self assert: aDateAndTime meridianAbbreviation = 'AM'. ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' 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: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testMidnight self assert: aDateAndTime midnight = aDateAndTime ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' 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: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testMinute self assert: aDateAndTime minute = 0 ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testMinutes self assert: aDateAndTime minutes = 0 ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' 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: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testNanoSecond self assert: aDateAndTime nanoSecond = 0 ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:36'! testNoon self assert: aDateAndTime noon = '1980-01-01T12:00:00+00:00' asDateAndTime! ! !DateAndTimeDosEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testNow self deny: aDateAndTime = (DateAndTime now). ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' 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: 'testing' 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: 'testing' 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: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testSecond self assert: aDateAndTime second = 0 ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testSeconds self assert: aDateAndTime seconds = 0 ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' 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: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:37'! testTicksOffset self assert: aDateAndTime = (aDateAndTime ticks: #(2444240 0 0) offset: DateAndTime localOffset). ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' stamp: 'CamilloBruni 7/13/2012 16:53'! testTimeZone self assert: aDateAndTime timeZoneName = 'Universal Time'. self assert: aDateAndTime timeZoneAbbreviation = 'UTC' ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' 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: 'testing' 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: 'testing' 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: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testToday self deny: aDateAndTime = (DateAndTime today). ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' 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: 'testing' 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: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:37'! testYear self assert: aDateAndTime year = 1980. ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:38'! testYearDay self assert: aDateAndTime = (DateAndTime year: 1980 day: 1). ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:38'! testYearDayHourMinuteSecond self assert: aDateAndTime = (DateAndTime year: 1980 day: 1 hour: 0 minute: 0 second: 0). ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:38'! testYearMonthDay self assert: aDateAndTime = (DateAndTime year: 1980 month: 1 day: 1). ! ! !DateAndTimeDosEpochTest methodsFor: 'testing' 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: 'testing' 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: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:31'! testYesterday self deny: aDateAndTime = (DateAndTime yesterday). ! ! TestCase subclass: #DateAndTimeEpochTest instanceVariableNames: 'aDateAndTime aDuration aTimeZone localTimeZoneToRestore' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Chronology'! !DateAndTimeEpochTest commentStamp: 'tlk 1/6/2004 18:27' prior: 0! 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: '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: '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: 'testing' stamp: 'tlk 1/4/2004 14:01'! testAsDate self assert: aDateAndTime asDate = 'January 1, 1901' asDate. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 13:31'! testAsDateAndTime self assert: aDateAndTime asDateAndTime = aDateAndTime ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 13:34'! testAsDuration self assert: aDateAndTime asDuration = 0 asDuration ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'CamilloBruni 7/13/2012 16:36'! testAsLocal self assert: aDateAndTime asLocal = aDateAndTime. self assert: aDateAndTime asLocal = (aDateAndTime offset: aDateAndTime class localOffset) ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 09:27'! testAsMonth self assert: aDateAndTime asMonth = (Month month: 'January' year: 1901). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 13:59'! testAsNanoSeconds self assert: aDateAndTime asNanoSeconds = 0 asDuration asNanoSeconds ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 14:01'! testAsSeconds self assert: aDateAndTime asSeconds = 0 asDuration asSeconds ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 09:32'! testAsTime self assert: aDateAndTime asTime = Time midnight. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 14:51'! testAsTimeStamp self assert: aDateAndTime asTimeStamp = TimeStamp new. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 11:07'! testAsUTC self assert: aDateAndTime asUTC = aDateAndTime ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'brp 1/16/2004 13:43'! testAsWeek self assert: aDateAndTime asWeek = (Week starting: '12-31-1900' asDate). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 09:43'! testAsYear self assert: aDateAndTime asYear = (Year starting: '01-01-1901' asDate). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:28'! testCurrent self deny: aDateAndTime = (DateAndTime current). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 09:46'! testDateTime self assert: aDateAndTime = (DateAndTime date: '01-01-1901' asDate time: '00:00:00' asTime) ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:01'! testDay self assert: aDateAndTime day = DateAndTime new day ! ! !DateAndTimeEpochTest methodsFor: 'testing' 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: 'testing' stamp: 'tlk 1/1/2004 15:45'! testDayOfMonth self assert: aDateAndTime dayOfMonth = 1. ! ! !DateAndTimeEpochTest methodsFor: 'testing' 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: 'testing' stamp: 'tlk 1/4/2004 14:01'! testDayOfYear self assert: aDateAndTime dayOfYear = 1. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:02'! testDaysInMonth self assert: aDateAndTime daysInMonth = 31. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:02'! testDaysInYear self assert: aDateAndTime daysInYear = 365. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:02'! testDaysLeftInYear self assert: aDateAndTime daysLeftInYear = 364. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 16:24'! testDuration self assert: aDateAndTime duration = 0 asDuration. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'cmm 6/14/2010 17:19'! testEpoch self assert: aDateAndTime = '1901-01-01T00:00:00+00:00' asDateAndTime ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 10:44'! testFirstDayOfMonth self assert: aDateAndTime firstDayOfMonth = 1 ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:25'! testFromSeconds self assert: aDateAndTime = (DateAndTime fromSeconds: 0). ! ! !DateAndTimeEpochTest methodsFor: 'testing' 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: 'testing' stamp: 'al 6/12/2008 21:56'! testHash self assert: aDateAndTime hash = DateAndTime new hash! ! !DateAndTimeEpochTest methodsFor: 'testing' 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: 'testing' stamp: 'brp 3/12/2004 15:21'! testHour12 self assert: aDateAndTime hour12 = DateAndTime new hour12. self assert: aDateAndTime hour12 = 12 ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 14:02'! testIsLeapYear self deny: aDateAndTime isLeapYear ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 17:18'! testJulianDayNumber self assert: aDateAndTime = (DateAndTime julianDayNumber: 2415386). self assert: aDateAndTime julianDayNumber = 2415386.! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 13:20'! testLessThan self assert: aDateAndTime < (aDateAndTime + '1:00:00:00'). self assert: aDateAndTime + -1 < aDateAndTime. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 10:40'! testMeridianAbbreviation self assert: aDateAndTime meridianAbbreviation = 'AM'. ! ! !DateAndTimeEpochTest methodsFor: 'testing' 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: 'testing' stamp: 'tlk 1/1/2004 17:39'! testMidnight self assert: aDateAndTime midnight = aDateAndTime ! ! !DateAndTimeEpochTest methodsFor: 'testing' 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: 'testing' stamp: 'tlk 1/1/2004 19:35'! testMinute self assert: aDateAndTime minute = 0 ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'brp 1/16/2004 13:41'! testMinutes self assert: aDateAndTime minutes = 0 ! ! !DateAndTimeEpochTest methodsFor: 'testing' 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: 'testing' stamp: 'tlk 1/1/2004 19:47'! testNanoSecond self assert: aDateAndTime nanoSecond = 0 ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:27'! testNew self assert: aDateAndTime = (DateAndTime new). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'cmm 6/14/2010 17:19'! testNoon self assert: aDateAndTime noon = '1901-01-01T12:00:00+00:00' asDateAndTime! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:28'! testNow self deny: aDateAndTime = (DateAndTime now). ! ! !DateAndTimeEpochTest methodsFor: 'testing' 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: 'testing' 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: 'testing' 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: 'testing' stamp: 'tlk 1/1/2004 20:22'! testSecond self assert: aDateAndTime second = 0 ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 20:22'! testSeconds self assert: aDateAndTime seconds = 0 ! ! !DateAndTimeEpochTest methodsFor: 'testing' 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: 'testing' stamp: 'tlk 1/1/2004 20:31'! testTicksOffset self assert: aDateAndTime = (aDateAndTime ticks: #(2415386 0 0) offset: DateAndTime localOffset). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'CamilloBruni 7/13/2012 16:52'! testTimeZone self assert: aDateAndTime timeZoneName = 'Universal Time'. self assert: aDateAndTime timeZoneAbbreviation = 'UTC' ! ! !DateAndTimeEpochTest methodsFor: 'testing' 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: 'testing' 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: 'testing' 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: 'testing' stamp: 'tlk 1/1/2004 17:35'! testToday self deny: aDateAndTime = (DateAndTime today). ! ! !DateAndTimeEpochTest methodsFor: 'testing' 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: 'testing' 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: 'testing' stamp: 'tlk 1/1/2004 21:00'! testYear self assert: aDateAndTime year = 1901. ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:30'! testYearDay self assert: aDateAndTime = (DateAndTime year: 1901 day: 1). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:31'! testYearDayHourMinuteSecond self assert: aDateAndTime = (DateAndTime year: 1901 day: 1 hour: 0 minute: 0 second: 0). ! ! !DateAndTimeEpochTest methodsFor: 'testing' stamp: 'tlk 1/1/2004 12:31'! testYearMonthDay self assert: aDateAndTime = (DateAndTime year: 1901 month: 1 day: 1). ! ! !DateAndTimeEpochTest methodsFor: 'testing' 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: 'testing' 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: 'testing' stamp: 'tlk 1/4/2004 09:47'! testYesterday self deny: aDateAndTime = (DateAndTime yesterday). ! ! TestCase subclass: #DateAndTimeLeapTest instanceVariableNames: 'aDateAndTime aDuration aTimeZone localTimeZoneToRestore' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Chronology'! !DateAndTimeLeapTest commentStamp: 'tlk 1/6/2004 17:54' prior: 0! 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: '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: 'testing' stamp: 'CamilloBruni 7/13/2012 21:08'! testAsDate self assert: aDateAndTime asDate equals: ('February 29, 2004' asDate translateTo: 2 hours).! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'CamilloBruni 7/13/2012 19:25'! testAsDuration self assert: aDateAndTime asDuration equals: aDuration ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'CamilloBruni 7/13/2012 16:36'! testAsLocal self assert: aDateAndTime asLocal = aDateAndTime. self assert: aDateAndTime asLocal = (aDateAndTime offset: aDateAndTime class localOffset) ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 12:24'! testAsMonth self assert: aDateAndTime asMonth = (Month month: 'February' year: 2004). ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 21:59'! testAsNanoSeconds self assert: aDateAndTime asNanoSeconds = aDuration asNanoSeconds. self assert: aDateAndTime asNanoSeconds = 48780000000000 ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'CamilloBruni 7/17/2012 17:09'! testAsSeconds self assert: aDuration asSeconds = 48780. self assert: aDateAndTime asSeconds = 3255507180. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'CamilloBruni 7/13/2012 19:26'! testAsTime self assert: aDateAndTime asTime equals: (Time hour: 13 minute: 33 second: 0) ! ! !DateAndTimeLeapTest methodsFor: 'testing' 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: 'testing' stamp: 'tlk 1/4/2004 13:59'! testAsUTC self assert: aDateAndTime asUTC = aDateAndTime ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'CamilloBruni 7/13/2012 21:09'! testAsWeek self assert: aDateAndTime asWeek equals: ((Week starting: '02-29-2004' asDate) translateTo: 2 hours). ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'CamilloBruni 7/13/2012 21:10'! testAsYear self assert: aDateAndTime asYear equals: ((Year starting: '02-29-2004' asDate) translateTo: 2 hours ). self deny: aDateAndTime asYear = ((Year starting: '01-01-2004' asDate) translateTo: 2 hours) ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:23'! testDay self assert: aDateAndTime day = 60. self deny: aDateAndTime day = 29 ! ! !DateAndTimeLeapTest methodsFor: 'testing' 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: 'testing' stamp: 'tlk 1/2/2004 22:17'! testDayOfMonth self assert: aDateAndTime dayOfMonth = 29. ! ! !DateAndTimeLeapTest methodsFor: 'testing' 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: 'testing' stamp: 'tlk 1/4/2004 13:59'! testDayOfYear self assert: aDateAndTime dayOfYear = 60. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:58'! testDaysInMonth self assert: aDateAndTime daysInMonth = 29. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:58'! testDaysInYear self assert: aDateAndTime daysInYear = 366. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:58'! testDaysLeftInYear self assert: aDateAndTime daysLeftInYear = 306. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:38'! testFirstDayOfMonth self deny: aDateAndTime firstDayOfMonth = 1. self assert: aDateAndTime firstDayOfMonth = 32 ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 10:43'! testFromString self assert: aDateAndTime = (DateAndTime fromString: ' 2004-02-29T13:33:00+02:00'). ! ! !DateAndTimeLeapTest methodsFor: 'testing' 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: 'testing' stamp: 'brp 3/12/2004 15:19'! testHour12 self assert: aDateAndTime hour12 = 1. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 13:35'! testIsLeapYear self assert: aDateAndTime isLeapYear ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 21:30'! testLessThan self assert: aDateAndTime < (aDateAndTime + '1:00:00:00'). self assert: aDateAndTime + -1 < aDateAndTime. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/4/2004 10:42'! testMeridianAbbreviation self assert: aDateAndTime meridianAbbreviation = 'PM'. ! ! !DateAndTimeLeapTest methodsFor: 'testing' 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: 'testing' stamp: 'CamilloBruni 7/13/2012 20:56'! testMidnight self assert: aDateAndTime midnight equals: '2004-02-29T00:00:00+02:00' asDateAndTime. ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/3/2004 11:00'! testMinute self assert: aDateAndTime minute = 33 ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'brp 1/16/2004 13:44'! testMinutes self assert: aDateAndTime minutes = 33 ! ! !DateAndTimeLeapTest methodsFor: 'testing' 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: 'testing' stamp: 'tlk 1/2/2004 21:30'! testNanoSecond self assert: aDateAndTime nanoSecond = 0 ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'CamilloBruni 7/16/2012 19:22'! testNoon self assert: aDateAndTime noon equals: '2004-02-29T12:00:00+02:00' asDateAndTime! ! !DateAndTimeLeapTest methodsFor: 'testing' 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: 'testing' 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: 'testing' stamp: 'tlk 1/2/2004 21:30'! testSecond self assert: aDateAndTime second = 0 ! ! !DateAndTimeLeapTest methodsFor: 'testing' stamp: 'tlk 1/2/2004 21:30'! testSeconds self assert: aDateAndTime seconds = 0 ! ! !DateAndTimeLeapTest methodsFor: 'testing' 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: 'testing' stamp: 'tlk 1/4/2004 13:52'! testTicksOffset self assert: aDateAndTime = (aDateAndTime ticks: #(2453065 48780 0) offset: DateAndTime localOffset). ! ! !DateAndTimeLeapTest methodsFor: 'testing' 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: 'testing' 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: 'testing' stamp: 'tlk 1/3/2004 11:17'! testYear self assert: aDateAndTime year = 2004. ! ! !DateAndTimeLeapTest methodsFor: 'testing' 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: 'testing' 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). ! ! ClassTestCase subclass: #DateAndTimeTest uses: TDateTimeTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Chronology'! !DateAndTimeTest commentStamp: 'SeanDeNigris 8/5/2010 16:12' prior: 0! A DateAndTimeTest is xxxxxxxxx. Instance creation from strings and streams: if no offset is specified, the local offset is used. Instance Variables ! !DateAndTimeTest methodsFor: 'coverage' stamp: 'brp 9/25/2003 09:25'! classToBeTested ^ DateAndTime ! ! !DateAndTimeTest methodsFor: 'coverage' stamp: 'StephaneDucasse 4/23/2010 21:08'! selectorsToBeIgnored | private | private := #( #printOn: ). ^ super selectorsToBeIgnored, private ! ! !DateAndTimeTest methodsFor: 'helpers'! restoreLocalTimeZoneAfter: aBlock | realTimeZone | realTimeZone := DateAndTime localTimeZone. aBlock ensure: [ DateAndTime localTimeZone: realTimeZone ].! ! !DateAndTimeTest methodsFor: 'helpers'! useNonUtcTimeZoneDuring: aBlock self useTimeZone: 'EDT' during: aBlock.! ! !DateAndTimeTest methodsFor: 'helpers'! useTimeZone: abbreviation during: aBlock | timeZone | timeZone := TimeZone abbreviated: abbreviation. self restoreLocalTimeZoneAfter: [ DateAndTime localTimeZone: timeZone. aBlock cull: timeZone ].! ! !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' 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: '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' 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: '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' 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' 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: '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' 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: '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:33'! testSecondsRoundTrip | now now2 | now := DateAndTime fromSeconds: 0. now2 := DateAndTime fromSeconds: now asSeconds. self assert: now equals: now2.! ! !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' 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 - 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 - bogus date' stamp: 'StephaneDucasse 4/23/2010 21:45'! testErrorWhenDayIsAfterMonthEnd self should: [DateAndTime year: 2004 month: 2 day: 30] raise: Error. self shouldnt: [DateAndTime year: 2004 month: 2 day: 29] raise: Error. ! ! !DateAndTimeTest methodsFor: 'tests - bogus date' stamp: 'StephaneDucasse 4/23/2010 21:45'! testErrorWhenDayIsBeforeMonthStart self should: [DateAndTime year: 2004 month: 2 day: -1] raise: Error. self should: [DateAndTime year: 2004 month: 2 day: 0] raise: Error. self shouldnt: [DateAndTime year: 2004 month: 2 day: 1] raise: Error. ! ! !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 - 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 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 - 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 - 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 - 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 - under design' stamp: 'StephaneDucasse 4/24/2010 11:18'! 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 printString = each]! ! !DateAndTimeTest methodsFor: 'tests - under design' stamp: 'MarcusDenker 8/20/2011 13:42'! 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) = (t2 = t1) ! ! !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 - 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: '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 - 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: '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 - 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 - 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 - 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 class uses: TDateTimeTest classTrait instanceVariableNames: ''! TestCase subclass: #DateAndTimeUnixEpochTest instanceVariableNames: 'aDateAndTime aDuration aTimeZone localTimeZoneToRestore' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Chronology'! !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: '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: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:14'! testAsDate self assert: aDateAndTime asDate = 'January 1, 1970' asDate. ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testAsDateAndTime self assert: aDateAndTime asDateAndTime = aDateAndTime ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testAsDuration self assert: aDateAndTime asDuration = 0 asDuration ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' stamp: 'CamilloBruni 7/13/2012 16:36'! testAsLocal self assert: aDateAndTime asLocal = aDateAndTime. self assert: aDateAndTime asLocal = (aDateAndTime offset: aDateAndTime class localOffset) ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:15'! testAsMonth self assert: aDateAndTime asMonth = (Month month: 'January' year: 1970). ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testAsNanoSeconds self assert: aDateAndTime asNanoSeconds = 0 asDuration asNanoSeconds ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:29'! testAsSeconds self assert: aDateAndTime asSeconds = 2177452800 ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testAsTime self assert: aDateAndTime asTime = Time midnight. ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:16'! testAsTimeStamp self assert: aDateAndTime asTimeStamp = (TimeStamp fromString: '1 January 1970 12:00 am').! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testAsUTC self assert: aDateAndTime asUTC = aDateAndTime ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:17'! testAsWeek self assert: aDateAndTime asWeek = (Week starting: '12-31-1969' asDate). ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:17'! testAsYear self assert: aDateAndTime asYear = (Year starting: '01-01-1970' asDate). ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testCurrent self deny: aDateAndTime = (DateAndTime current). ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:17'! testDateTime self assert: aDateAndTime = (DateAndTime date: '01-01-1970' asDate time: '00:00:00' asTime) ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testDay self assert: aDateAndTime day = DateAndTime new day ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' 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: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testDayOfMonth self assert: aDateAndTime dayOfMonth = 1. ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' 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: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testDayOfYear self assert: aDateAndTime dayOfYear = 1. ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testDaysInMonth self assert: aDateAndTime daysInMonth = 31. ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testDaysInYear self assert: aDateAndTime daysInYear = 365. ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testDaysLeftInYear self assert: aDateAndTime daysLeftInYear = 364. ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testDuration self assert: aDateAndTime duration = 0 asDuration. ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:18'! testEpoch self assert: aDateAndTime = '1970-01-01T00:00:00+00:00' asDateAndTime ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testFirstDayOfMonth self assert: aDateAndTime firstDayOfMonth = 1 ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:19'! testFromSeconds self assert: aDateAndTime = (DateAndTime fromSeconds: 2177452800). ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' 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: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:20'! testHash self assert: aDateAndTime hash = (DateAndTime year: 1970 month: 1 day: 1) hash! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' 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: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testHour12 self assert: aDateAndTime hour12 = DateAndTime new hour12. self assert: aDateAndTime hour12 = 12 ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testIsLeapYear self deny: aDateAndTime isLeapYear ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:21'! testJulianDayNumber self assert: aDateAndTime = (DateAndTime julianDayNumber: 2440588). self assert: aDateAndTime julianDayNumber = 2440588.! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testLessThan self assert: aDateAndTime < (aDateAndTime + '1:00:00:00'). self assert: aDateAndTime + -1 < aDateAndTime. ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testMeridianAbbreviation self assert: aDateAndTime meridianAbbreviation = 'AM'. ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' 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: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testMidnight self assert: aDateAndTime midnight = aDateAndTime ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' 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: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testMinute self assert: aDateAndTime minute = 0 ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testMinutes self assert: aDateAndTime minutes = 0 ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' 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: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testNanoSecond self assert: aDateAndTime nanoSecond = 0 ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:23'! testNoon self assert: aDateAndTime noon = '1970-01-01T12:00:00+00:00' asDateAndTime! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testNow self deny: aDateAndTime = (DateAndTime now). ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' 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: 'testing' 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: 'testing' 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: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testSecond self assert: aDateAndTime second = 0 ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testSeconds self assert: aDateAndTime seconds = 0 ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' 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: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testTicksOffset self assert: aDateAndTime = (aDateAndTime ticks: #(2415386 0 0) offset: DateAndTime localOffset). ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' stamp: 'CamilloBruni 7/13/2012 16:51'! testTimeZone self assert: aDateAndTime timeZoneName = 'Universal Time'. self assert: aDateAndTime timeZoneAbbreviation = 'UTC' ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' 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: 'testing' 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: 'testing' 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: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testToday self deny: aDateAndTime = (DateAndTime today). ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' 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: 'testing' 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: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:28'! testYear self assert: aDateAndTime year = 1970. ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:28'! testYearDay self assert: aDateAndTime = (DateAndTime year: 1970 day: 1). ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:28'! testYearDayHourMinuteSecond self assert: aDateAndTime = (DateAndTime year: 1970 day: 1 hour: 0 minute: 0 second: 0). ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:28'! testYearMonthDay self assert: aDateAndTime = (DateAndTime year: 1970 month: 1 day: 1). ! ! !DateAndTimeUnixEpochTest methodsFor: 'testing' 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: 'testing' 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: 'testing' stamp: 'GabrielBarbuto 9/27/2010 10:13'! testYesterday self deny: aDateAndTime = (DateAndTime yesterday). ! ! ComposableModel subclass: #DateModel instanceVariableNames: 'dateLabel chooseDateButton dateModel' classVariableNames: '' poolDictionaries: '' category: 'Spec-Widgets-PolyWidgets'! !DateModel commentStamp: '' prior: 0! 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. As it is Spec-based, it can be easily adapted and composed into a larger UI.! !DateModel methodsFor: 'accessing' stamp: 'SeanDeNigris 1/28/2013 14:28'! date ^ self dateModel getText asDate.! ! !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: 'accessing-widgets' stamp: 'SeanDeNigris 1/28/2013 14:17'! dateModel ^ dateModel.! ! !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: 'protocol-events' stamp: 'BenjaminVanRyseghem 1/29/2013 16:16'! whenDateChanged: aBlock dateModel whenTextChanged: [:newText :oldText :announcement :announcer || newDate oldDate | newDate := Date readFrom: newText readStream. oldDate := Date readFrom: oldText readStream. aBlock cull: newDate cull: oldDate cull: announcement cull: announcer ]! ! !DateModel methodsFor: 'private' stamp: 'SeanDeNigris 1/28/2013 14:19'! chooseDate | calendar | calendar := CalendarMorph openOn: Date today. calendar onChoiceSend: #onDateChosen: to: self.! ! !DateModel methodsFor: 'private' stamp: 'SeanDeNigris 1/28/2013 15:47'! iconMorph ^ ImageMorph new image: ThemeIcons calendarIcon.! ! !DateModel methodsFor: 'private' stamp: 'SeanDeNigris 1/28/2013 14:20'! onDateChosen: aChoseDate aChoseDate calendar delete. dateModel text: aChoseDate date asString.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DateModel class instanceVariableNames: ''! !DateModel class methodsFor: 'as yet unclassified' 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.! ! Object subclass: #DatePrintFormatTester uses: TAssertable instanceVariableNames: 'dayPosition monthPosition yearPosition delimiter monthType yearType date' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Chronology'! !DatePrintFormatTester methodsFor: 'accessing' stamp: 'SeanDeNigris 6/20/2012 03:19'! date: aDate date := aDate.! ! !DatePrintFormatTester methodsFor: 'accessing' stamp: 'SeanDeNigris 6/20/2012 03:25'! delimiter: aCharacter delimiter := aCharacter.! ! !DatePrintFormatTester methodsFor: 'accessing' stamp: 'SeanDeNigris 6/20/2012 03:31'! monthType: anInteger monthType := anInteger.! ! !DatePrintFormatTester methodsFor: 'as yet unclassified'! fail: aDescriptionString ^self assert: false description: aDescriptionString! ! !DatePrintFormatTester methodsFor: 'as yet unclassified' stamp: 'SeanDeNigris 6/20/2012 03:33'! printFormat ^ date printFormat: { dayPosition. monthPosition. yearPosition. delimiter. monthType. yearType }.! ! !DatePrintFormatTester methodsFor: 'as yet unclassified'! skip: aComment "Don't run this test, and don't mark it as failure" TestSkip signal: aComment! ! !DatePrintFormatTester methodsFor: 'asserting'! assert: aBoolean aBoolean ifFalse: [self signalFailure: 'Assertion failed'] ! ! !DatePrintFormatTester methodsFor: 'asserting'! assert: aBooleanOrBlock description: aStringOrBlock aBooleanOrBlock value ifFalse: [ | message | message := aStringOrBlock value. self classForTestResult failure signal: message] ! ! !DatePrintFormatTester methodsFor: 'asserting'! assert: aBooleanOrBlock description: aString resumable: resumableBoolean | exception | aBooleanOrBlock value ifFalse: [self classForTestResult failure new isResumable: resumableBoolean; signal: aString] ! ! !DatePrintFormatTester methodsFor: 'asserting'! assert: actual equals: expected ^ self assert: expected = actual description: [self comparingStringBetween: actual and: expected]! ! !DatePrintFormatTester methodsFor: 'asserting'! classForTestResult "Returns the class of the test result" ^ TestResult! ! !DatePrintFormatTester methodsFor: 'asserting'! deny: aBooleanOrBlock self assert: aBooleanOrBlock value not ! ! !DatePrintFormatTester methodsFor: 'asserting'! deny: aBooleanOrBlock description: aString self assert: aBooleanOrBlock value not description: aString ! ! !DatePrintFormatTester methodsFor: 'asserting'! deny: aBooleanOrBlock description: aString resumable: resumableBoolean self assert: aBooleanOrBlock value not description: aString resumable: resumableBoolean ! ! !DatePrintFormatTester methodsFor: 'asserting'! executeShould: aBlock inScopeOf: anExceptionalEvent ^[aBlock value. false] on: anExceptionalEvent do: [:ex | ex return: true] ! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: 'EstebanLorenzano 8/17/2012 16:40'! executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionContaining: aString ^[aBlock value. false] on: anExceptionalEvent do: [:ex | ex return: (ex description includesSubstring: aString) ] ! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: 'EstebanLorenzano 8/17/2012 16:40'! executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionNotContaining: aString ^[aBlock value. false] on: anExceptionalEvent do: [:ex | ex return: (ex description includesSubstring: aString) not ] ! ! !DatePrintFormatTester methodsFor: 'asserting'! executeShould: aBlock inScopeOf: anException withExceptionDo: anotherBlock ^[aBlock value. false] on: anException do: [:exception | anotherBlock value: exception. exception return: true]! ! !DatePrintFormatTester methodsFor: 'asserting'! fail ^self assert: false! ! !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'! should: aBlock self assert: aBlock value ! ! !DatePrintFormatTester methodsFor: 'asserting'! should: aBlock description: aString self assert: aBlock value description: aString ! ! !DatePrintFormatTester methodsFor: 'asserting'! 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'! should: aBlock notTakeMoreThanMilliseconds: anInteger "For compatibility with other Smalltalks" self should: aBlock notTakeMoreThan: (Duration milliSeconds: anInteger).! ! !DatePrintFormatTester methodsFor: 'asserting'! should: aBlock raise: anExceptionalEvent ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent) ! ! !DatePrintFormatTester methodsFor: 'asserting'! should: aBlock raise: anExceptionalEvent description: aString ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent) description: aString ! ! !DatePrintFormatTester methodsFor: 'asserting'! should: aBlock raise: anExceptionalEvent whoseDescriptionDoesNotInclude: subString description: aString ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionNotContaining: subString) description: aString ! ! !DatePrintFormatTester methodsFor: 'asserting'! should: aBlock raise: anExceptionalEvent whoseDescriptionIncludes: subString description: aString ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionContaining: subString) description: aString ! ! !DatePrintFormatTester methodsFor: 'asserting'! should: aBlock raise: anException withExceptionDo: anotherBlock ^self assert: (self executeShould: aBlock inScopeOf: anException withExceptionDo: anotherBlock)! ! !DatePrintFormatTester methodsFor: 'asserting' stamp: 'SeanDeNigris 6/20/2012 03:33'! shouldEqual: expectedOutputString self assert: self printFormat equals: expectedOutputString. ! ! !DatePrintFormatTester methodsFor: 'asserting'! 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'! shouldnt: aBlock self deny: aBlock value ! ! !DatePrintFormatTester methodsFor: 'asserting'! shouldnt: aBlock description: aString self deny: aBlock value description: aString ! ! !DatePrintFormatTester methodsFor: 'asserting'! shouldnt: aBlock raise: anExceptionalEvent ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent) not ! ! !DatePrintFormatTester methodsFor: 'asserting'! shouldnt: aBlock raise: anExceptionalEvent description: aString ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent) not description: aString ! ! !DatePrintFormatTester methodsFor: 'asserting'! shouldnt: aBlock raise: anExceptionalEvent whoseDescriptionDoesNotInclude: subString description: aString ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionNotContaining: subString) not description: aString ! ! !DatePrintFormatTester methodsFor: 'asserting'! shouldnt: aBlock raise: anExceptionalEvent whoseDescriptionIncludes: subString description: aString ^self assert: (self executeShould: aBlock inScopeOf: anExceptionalEvent withDescriptionContaining: subString) not description: aString ! ! !DatePrintFormatTester methodsFor: 'asserting'! signalFailure: aString self classForTestResult failure signal: aString! ! !DatePrintFormatTester methodsFor: 'asserting'! skip "Don't run this test, and don't mark it as failure" TestSkip signal! ! !DatePrintFormatTester methodsFor: 'asserting'! 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: 'SeanDeNigris 6/20/2012 03:42'! tokens ^ self printFormat findTokens: { delimiter }.! ! !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: 'private'! comparingStringBetween: actual and: expected ^ String streamContents: [:stream | stream nextPutAll: 'Got '; nextPutAll: actual fullPrintString; nextPutAll: ' instead of '; nextPutAll: expected fullPrintString; nextPutAll: '.']! ! !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 class uses: TAssertable classTrait instanceVariableNames: ''! !DatePrintFormatTester class methodsFor: 'instance creation' stamp: 'SeanDeNigris 6/20/2012 03:17'! on: aDate ^ self new date: aDate.! ! ClassTestCase subclass: #DateTest uses: TDateTimeTest instanceVariableNames: 'aTime january23rd2004 june2nd1973' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Chronology'! !DateTest commentStamp: 'brp 7/26/2003 16:58' prior: 0! This is the unit test for the class Date. ! !DateTest methodsFor: 'Coverage' stamp: 'brp 7/27/2003 13:01'! classToBeTested ^ self dateClass! ! !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: 'Running' stamp: 'SeanDeNigris 6/20/2012 01:44'! setUp june2nd1973 := self dateClass newDay: 153 year: 1973. january23rd2004 := Date readFrom: '01-23-2004' readStream. aTime := Time readFrom: '12:34:56 pm' readStream! ! !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' 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: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: '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 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' stamp: 'CamilloBruni 7/17/2012 08:32'! testFromSeconds | d | d := self dateClass fromSeconds: june2nd1973 asSeconds. self assert: d equals: june2nd1973. ! ! !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:36'! testLeapYear self assert: (self dateClass leapYear: 1973) equals: 0; assert: (self dateClass leapYear: 1972) equals: 1.! ! !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: 'Tests' stamp: 'SeanDeNigris 6/20/2012 02:43'! testNew self assert: self dateClass new equals: self epoch.! ! !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' 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 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 04:04'! testStoring | expected actual | expected := '''2 June 1973'' asDate'. actual := june2nd1973 storeString. self assert: actual equals: expected; assert: (Compiler evaluate: expected) equals: june2nd1973. "Evaluating expected to avoid surprises when evaluating" ! ! !DateTest methodsFor: 'helpers' stamp: 'SeanDeNigris 6/20/2012 02:14'! epoch ^ '1 January 1901' asDate. ! ! !DateTest methodsFor: 'helpers'! restoreLocalTimeZoneAfter: aBlock | realTimeZone | realTimeZone := DateAndTime localTimeZone. aBlock ensure: [ DateAndTime localTimeZone: realTimeZone ].! ! !DateTest methodsFor: 'helpers'! useNonUtcTimeZoneDuring: aBlock self useTimeZone: 'EDT' during: aBlock.! ! !DateTest methodsFor: 'helpers'! useTimeZone: abbreviation during: aBlock | timeZone | timeZone := TimeZone abbreviated: abbreviation. self restoreLocalTimeZoneAfter: [ DateAndTime localTimeZone: timeZone. aBlock cull: timeZone ].! ! !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 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 01:46'! testAsDate self assert: january23rd2004 asDate equals: january23rd2004.! ! !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 02:32'! testDateAndTimeNow "Not a great test: could falsely fail if midnight come in between the two executions and doesnt catch time errors" | now | now := self dateClass dateAndTimeNow. self assert: now size equals: 2; assert: now first equals: self dateClass today; assert: (now second isKindOf: Time). ! ! !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' 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 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: 'SeanDeNigris 6/20/2012 01:50'! testDuration self assert: january23rd2004 duration equals: 24 hours.! ! !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 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: '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 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 02:42'! testMmddyyyy self assert: january23rd2004 mmddyyyy equals: '1/23/2004'! ! !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 02:43'! testNewDayMonthYear self assert: (Date newDay: 23 month: 1 year: 2004) equals: january23rd2004. ! ! !DateTest methodsFor: 'tests' stamp: 'SeanDeNigris 6/20/2012 02:43'! testNewDayYear self assert: (Date newDay: 23 year: 2004) equals: january23rd2004 ! ! !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: '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 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 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 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: '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.! ! !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: '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: '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' 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 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: 'tests' stamp: 'SeanDeNigris 6/20/2012 04:10'! testYyyymmdd self assert: january23rd2004 yyyymmdd equals: '2004-01-23'! ! !DateTest methodsFor: 'Private' stamp: 'brp 8/24/2003 00:10'! dateClass ^ Date! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DateTest class uses: TDateTimeTest classTrait instanceVariableNames: ''! Object subclass: #DebugSystemSettings instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Settings-Tools'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DebugSystemSettings class instanceVariableNames: ''! !DebugSystemSettings class methodsFor: 'settings' stamp: 'CamilloBruni 7/19/2011 16:52'! 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: 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: Debugger; description: 'When true, always directly open the full Debugger view when debugging instead of showing only a small popup' translated. (aBuilder setting: #filterCommonMessageSends) label: 'Filter out common message sends' translated; target: Debugger; description: 'When true, filter out uninteresting message sends in the Debugger view while debugging' translated. (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: Debugger; description: 'A name of the file, which will be used for logging all errors and notifications' ]! ! CodeHolder subclass: #Debugger instanceVariableNames: 'interruptedProcess interruptedController contextStack contextStackTop contextStackIndex contextStackList receiverInspector contextVariablesInspector externalInterrupt proceedValue selectingPC savedCursor errorWasInUIProcess labelString widget' classVariableNames: 'AlwaysOpenFullDebugger ContextStackKeystrokes ErrorRecursion ExtraDebuggerButtons FilterCommonMessageSends LogDebuggerStackToFile LogFileName RestartAlsoProceeds' poolDictionaries: '' category: 'Tools-Debugger'! !Debugger commentStamp: '' prior: 0! I represent the machine state at the time of an interrupted process. I also represent a query path into the state of the process. The debugger is typically viewed through a window that views the stack of suspended contexts, the code for, and execution point in, the currently selected message, and inspectors on both the receiver of the currently selected message, and the variables in the current context. Special note on recursive errors: Some errors affect Squeak's ability to present a debugger. This is normally an unrecoverable situation. However, if such an error occurs in an isolation layer, Squeak will attempt to exit from the isolation layer and then present a debugger. Here is the chain of events in such a recovery. * A recursive error is detected. * The current project is queried for an isolationHead * Changes in the isolationHead are revoked * The parent project of isolated project is returned to * The debugger is opened there and execution resumes. If the user closes that debugger, execution continues in the outer project and layer. If, after repairing some damage, the user proceeds from the debugger, then the isolationHead is re-invoked, the failed project is re-entered, and execution resumes in that world. ! !Debugger methodsFor: '*FuelTools-Debugger' stamp: 'EstebanLorenzano 2/18/2013 18:40'! 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..." ].! ! !Debugger methodsFor: '*Polymorph-TaskbarIcons' stamp: 'FernandoOlivero 4/12/2011 09:44'! taskbarIcon ^ self theme smallDebugIcon! ! !Debugger methodsFor: '*Shout-Styling'! shoutAboutToStyle: aPluggableShoutMorphOrView self shoutIsModeStyleable ifFalse: [^ false]. aPluggableShoutMorphOrView classOrMetaClass: self selectedClassOrMetaClass. ^ true! ! !Debugger methodsFor: '*UI-Basic-edits' stamp: 'BenjaminVanRyseghem 8/2/2012 16:15'! hasUnacceptedEdits ^ (self dependents select:[ :e | e respondsTo: #hasUnacceptedEdits ]) anySatisfy: [:e | e hasUnacceptedEdits ]! ! !Debugger methodsFor: '*necompletion' stamp: 'lr 3/26/2010 13:53'! guessTypeForName: aString | index object | index := self selectedContext tempNames indexOf: aString ifAbsent: [ nil ]. object := index isNil ifFalse: [ self selectedContext namedTempAt: index ] ifTrue: [ index := self receiver class allInstVarNames indexOf: aString ifAbsent: [ ^ super guessTypeForName: aString ]. self receiver instVarAt: index ]. ^ object class ! ! !Debugger methodsFor: '*necompletion'! guessTypeForNameFromOCompletion: aString "we should study that because it may be better" | index object | index := (self selectedContext debuggerMap tempNamesForContext: self selectedContext) indexOf: aString ifAbsent: []. object := index ifNil: [index := self receiver class allInstVarNames indexOf: aString ifAbsent: []. index ifNil: [^ nil]. self receiver instVarAt: index] ifNotNil: [self selectedContext tempAt: index]. ^ object class ! ! !Debugger methodsFor: 'accessing' stamp: 'CamilloBruni 4/27/2012 10:47'! blockContents: aText notifying: aController |h result | h := self selectedContext activeHome. h ifNil: [ self blockNotFoundDialog: self selectedContext method with: aText. ^false ]. (self confirm: 'I will have to revert to the method from\which this block originated. Is that OK?' withCRs) ifFalse: [ ^ false ]. self resetContext: h. result := self contents: aText notifying: aController. self contentsChanged. ^ result! ! !Debugger methodsFor: 'accessing' stamp: 'CamilloBruni 2/4/2012 12:39'! 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 setSelection: self codeTextMorph selectionInterval; hasUnacceptedEdits: true! ! !Debugger methodsFor: 'accessing' stamp: 'EstebanLorenzano 6/7/2012 17:28'! contents "Depending on the current selection, different information is retrieved. Answer a string description of that information. This information is the method in the currently selected context." ^(contextStackIndex == 0) ifTrue: [ String new ] ifFalse: [ contents ifNil: [ self selectedContext ifNotNil: [ self selectedMessage ] ifNil: [ String new ] ] ]! ! !Debugger methodsFor: 'accessing' stamp: 'CamilloBruni 4/27/2012 10:47'! contents: aText notifying: aController "The retrieved information has changed and its source must now be updated. In this case, the retrieved information is the method of the selected context." | newMethod | contextStackIndex = 0 ifTrue: [ ^ false ]. "check if we're currently in a block" self selectedContext isExecutingBlock ifTrue: [ ^ self blockContents: aText notifying: aController ]. newMethod := self recompileCurrentMethodTo: aText notifying: aController. newMethod ifNil: [ ^ false ]. self restartRecompiledMethod: newMethod. World addAlarm: #changed: withArguments: #(contentsSelection) for: self at: (Time millisecondClockValue + 200). ^ true! ! !Debugger methodsFor: 'accessing'! contextVariablesInspector "Answer the instance of Inspector that is providing a view of the variables of the selected context." ^contextVariablesInspector! ! !Debugger methodsFor: 'accessing'! interruptedContext "Answer the suspended context of the interrupted process." ^contextStackTop! ! !Debugger methodsFor: 'accessing' stamp: 'StephaneDucasse 2/6/2011 21:52'! interruptedProcess ^ interruptedProcess! ! !Debugger methodsFor: 'accessing' stamp: 'CamilloBruni 8/30/2012 17:19'! isPostMortem "return whether we're inspecting a frozen exception without a process attached" |selectedContext suspendedContext | selectedContext := self selectedContext. suspendedContext := interruptedProcess suspendedContext. suspendedContext ifNil: [ ^ false ]. (suspendedContext == selectedContext) ifTrue: [ ^ false ]. ^ (suspendedContext findContextSuchThat: [:c | c sender == selectedContext]) isNil ! ! !Debugger methodsFor: 'accessing' stamp: 'hmm 7/16/2001 21:54'! labelString ^labelString! ! !Debugger methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'! labelString: aString labelString := aString. self changed: #relabel! ! !Debugger methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'! proceedValue: anObject "Set the value to be returned to the selected context when the interrupted process proceeds." proceedValue := anObject! ! !Debugger methodsFor: 'accessing'! receiver "Answer the receiver of the selected context, if any. Answer nil otherwise." contextStackIndex = 0 ifTrue: [^nil] ifFalse: [^self selectedContext receiver]! ! !Debugger methodsFor: 'accessing'! receiverInspector "Answer the instance of Inspector that is providing a view of the variables of the selected context's receiver." ^receiverInspector! ! !Debugger methodsFor: 'accessing' stamp: 'CamilloBruni 8/8/2011 17:36'! recompileCurrentMethodTo: aText notifying: aController |classOfMethod category selector newMethod| classOfMethod := self selectedClass. category := self selectedMessageCategoryName. selector := self selectedClass parserClass new parseSelector: aText. (selector == self selectedMessageName or: [(self selectedMessageName beginsWith: 'DoIt') and: [selector numArgs = self selectedMessageName numArgs]]) ifFalse: [self inform: 'can''t change selector'. ^nil]. selector := classOfMethod compile: aText classified: category notifying: aController. selector ifNil: [^nil]. "compile cancelled" contents := aText. newMethod := classOfMethod compiledMethodAt: selector. newMethod isQuick ifTrue: [self down. self selectedContext jump: (self selectedContext previousPc - self selectedContext pc)]. ^ newMethod ! ! !Debugger methodsFor: 'accessing' stamp: 'CamilloBruni 8/8/2011 17:38'! restartRecompiledMethod: newMethod |ctxt| ctxt := interruptedProcess popTo: self selectedContext. ctxt == self selectedContext ifFalse: [self inform: 'Method saved, but current context unchanged\because of unwind error. Click OK to see error' withCRs] ifTrue: [newMethod isQuick ifFalse: [interruptedProcess restartTopWith: newMethod; stepToSendOrReturn]. contextVariablesInspector object: nil]. self resetContext: ctxt. "Issue 3015 - Hernan" self isInterruptedContextATest ifTrue: [ self prepareTestToRunAgain ].! ! !Debugger methodsFor: 'accessing' stamp: 'hfm 12/21/2008 22:57'! runToSelection | currentContext selectionInterval | selectionInterval := self codeTextMorph selectionInterval. self pc first >= selectionInterval first ifTrue: [ ^self ]. currentContext := self selectedContext. [ currentContext == self selectedContext and: [ self pc first < selectionInterval first ] ] whileTrue: [ self doStep ].! ! !Debugger methodsFor: 'accessing' stamp: 'CamilloBruni 9/21/2012 14:33'! widget ^ widget! ! !Debugger methodsFor: 'accessing' stamp: 'CamilloBruni 9/21/2012 14:33'! widget: aUIWidget widget := aUIWidget! ! !Debugger methodsFor: 'class list' stamp: 'md 2/17/2006 09:32'! selectedClass "Answer the class in which the currently selected context's method was found." ^self selectedContext methodClass! ! !Debugger methodsFor: 'code pane' stamp: 'tk 4/15/1998 18:31'! contentsSelection ^ self pcRange! ! !Debugger methodsFor: 'code pane'! doItContext "Answer the context in which a text selection can be evaluated." contextStackIndex = 0 ifTrue: [^super doItContext] ifFalse: [^self selectedContext]! ! !Debugger methodsFor: 'code pane'! doItReceiver "Answer the object that should be informed of the result of evaluating a text selection." ^self receiver! ! !Debugger methodsFor: 'code pane' stamp: 'tk 5/2/1998 10:04'! pc ^ self pcRange! ! !Debugger methodsFor: 'code pane' stamp: 'eem 3/12/2009 14:54'! pcRange "Answer the indices in the source code for the method corresponding to the selected context's program counter value." (selectingPC and: [contextStackIndex ~= 0]) ifFalse: [^1 to: 0]. self selectedContext isDead ifTrue: [^1 to: 0]. ^self selectedContext debuggerMap rangeForPC: self selectedContext pc contextIsActiveContext: contextStackIndex = 1! ! !Debugger methodsFor: 'code pane menu' stamp: 'EstebanLorenzano 1/31/2013 19:25'! codePaneMenu: aMenu shifted: shifted aMenu addAllFromPragma: 'debuggerCodePaneMenu' target: {self. thisContext sender receiver selectionInterval}. ^super codePaneMenu: aMenu shifted: shifted. ! ! !Debugger methodsFor: 'code pane menu' stamp: 'sd 11/20/2005 21:27'! perform: selector orSendTo: otherTarget "Selector was just chosen from a menu by a user. If can respond, then perform it on myself. If not, send it to otherTarget, presumably the editPane from which the menu was invoked." | result | (#(debug proceed) includes: selector) "When I am a notifier window" ifTrue: [^ self perform: selector] ifFalse: [result := super perform: selector orSendTo: otherTarget. selector == #doIt ifTrue: [ result ~~ #failedDoit ifTrue: [self proceedValue: result]]. ^ result]! ! !Debugger methodsFor: 'code pane menu' stamp: 'sd 11/20/2005 21:27'! runToSelection: selectionInterval | currentContext | self pc first >= selectionInterval first ifTrue: [ ^self ]. currentContext := self selectedContext. [ currentContext == self selectedContext and: [ self pc first < selectionInterval first ] ] whileTrue: [ self doStep ].! ! !Debugger methodsFor: 'construction' stamp: 'StephaneDucasse 12/19/2012 16:31'! addOptionalButtonsTo: window at: fractions plus: verticalOffset "Add button panes to the window. A row of custom debugger-specific buttons (Proceed, Restart, etc.) is always added, and if optionalButtons is in force, then the standard code-tool buttons are also added. Answer the verticalOffset plus the height added." | delta buttons anOffset | anOffset := (CodeHolder optionalButtons and: [ self class extraDebuggerButtons]) ifTrue: [super addOptionalButtonsTo: window at: fractions plus: verticalOffset] ifFalse: [verticalOffset]. buttons := self customButtonRow. buttons := OverflowRowMorph new baseMorph: buttons; height: buttons minExtent y; setNameTo: buttons assureExtension externalName. delta := buttons minExtent y + 2. buttons color: Color white; borderWidth: 0. window addMorph: buttons fullFrame: ( fractions asLayoutFrame topOffset: anOffset ; bottomOffset: (anOffset + delta - 1)). ^ anOffset + delta! ! !Debugger methodsFor: 'construction' stamp: 'MarcusDenker 11/2/2012 10:34'! buildContextInspectorFor: aDebugger ^ PluggableTextMorph on: aDebugger contextVariablesInspector text: #contents accept: #accept: readSelection: #contentsSelection menu: #codePaneMenu:shifted:! ! !Debugger methodsFor: 'construction' stamp: 'MarcusDenker 11/2/2012 10:34'! buildFieldInspectorFor: aDebugger ^ PluggableTextMorph on: aDebugger receiverInspector text: #contents accept: #accept: readSelection: #contentsSelection menu: #codePaneMenu:shifted:! ! !Debugger methodsFor: 'construction' stamp: 'MarcusDenker 11/2/2012 10:34'! buildListOfContextFor: aDebugger ^ PluggableListMorph new doubleClickSelector: #inspectSelection; on: aDebugger contextVariablesInspector list: #fieldList selected: #selectionIndex changeSelected: #toggleIndex: menu: #fieldListMenu: keystroke: #inspectorKey:from:! ! !Debugger methodsFor: 'construction' stamp: 'MarcusDenker 11/2/2012 10:34'! buildListOfElementsFor: aDebugger ^ (PluggableMultiColumnListMorph on: aDebugger list: #contextStackList selected: #contextStackIndex changeSelected: #toggleContextStackIndex: menu: #contextStackMenu: keystroke: #contextStackKey:from: wrapSelector: #createColumnsFor:) gapSize: 40; yourself! ! !Debugger methodsFor: 'construction' stamp: 'MarcusDenker 11/2/2012 10:34'! buildListOfFieldsFor: aDebugger ^ (PluggableListMorph new doubleClickSelector: #inspectSelection; on: aDebugger receiverInspector list: #fieldList selected: #selectionIndex changeSelected: #toggleIndex: menu: #fieldListMenu: keystroke: #inspectorKey:from:) autoDeselect: false; yourself! ! !Debugger methodsFor: 'construction' stamp: 'StephaneDucasse 12/21/2012 11:37'! buildMorphicNotifierLabelled: label message: messageString | notifyPane window extentToUse row| self expandStack. window := (PreDebugWindow labelled: label) model: self. extentToUse := 450 @ 156. "nice and wide to show plenty of the error msg" window addMorph: (row := self buttonRowForPreDebugWindow: window) fullFrame: ((0@0 corner: 1@0) asLayoutFrame bottomOffset: row minExtent y). row color: Color transparent. messageString notNil ifFalse: [notifyPane := self buildNotifyListPane: self ] ifTrue: [notifyPane := self buildNotifyTextPane: self. notifyPane editString: (self preDebugNotifierContentsFrom: messageString); askBeforeDiscardingEdits: false]. window addMorph: notifyPane fullFrame: (LayoutFrame identity topOffset: 24). window setBalloonTextForCloseBox. window openInWorldExtent: extentToUse. window currentWorld displayWorld. "helps with interrupt not working somehow." ^window ! ! !Debugger methodsFor: 'construction' stamp: 'MarcusDenker 11/2/2012 10:34'! buildNotifyListPane: aDebugger ^ (PluggableMultiColumnListMorph on: aDebugger list: #contextStackList selected: #contextStackIndex changeSelected: #debugAt: menu: nil keystroke: nil wrapSelector: #createColumnsFor:) gapSize: 40; yourself! ! !Debugger methodsFor: 'construction' stamp: 'MarcusDenker 11/2/2012 10:34'! buildNotifyTextPane: aDebugger ^ (PluggableTextMorph on: aDebugger text: nil accept: nil readSelection: nil menu: #debugProceedMenu:) styled: false; yourself! ! !Debugger methodsFor: 'construction' stamp: 'FernandoOlivero 4/12/2011 09:44'! buttonRowForPreDebugWindow: aDebugWindow "Answer a row of button for a pre-debug notifier." | buttons quads | buttons := OrderedCollection with: (AlignmentMorph newVariableTransparentSpacer). quads := OrderedCollection withAll: self preDebugButtonQuads. (self interruptedContext selector == #doesNotUnderstand:) ifTrue: [ quads add: { 'Create'. #createMethod. #magenta. 'create the missing method' }]. quads do: [:quad | buttons add: ((PluggableButtonMorph on: aDebugWindow getState: nil action: quad second) label: quad first; setBalloonText: quad fourth; useSquareCorners; hResizing: #shrinkWrap; vResizing: #spaceFill). buttons add: AlignmentMorph newVariableTransparentSpacer]. ^(self theme builder newRow: buttons) cellInset: 2! ! !Debugger methodsFor: 'construction' stamp: 'FernandoOlivero 4/12/2011 09:44'! customButtonRow "Answer a button pane affording the user one-touch access to certain functions; the pane is given the formal name 'customButtonPane' by which it can be retrieved by code wishing to send messages to widgets residing on the pane" | buttons buttonsSpec | buttons := OrderedCollection new. buttonsSpec := OrderedCollection withAll: self customButtonSpecs. buttonsSpec add: { 'Create'. #createMethod. 'create the missing method'. #isInterruptedContextDoesNotUnderstand}. buttonsSpec do: [:buttonSpec | | button | button := (PluggableButtonMorph on: self getState: nil action: buttonSpec second) hResizing: #spaceFill; vResizing: #spaceFill; askBeforeChanging: (#(proceed restart send doStep stepIntoBlock fullStack where) includes: buttonSpec second); label: buttonSpec first asString; setBalloonText: (buttonSpec size > 2 ifTrue: [buttonSpec third]); yourself. buttonSpec size > 3 ifTrue: [ button getEnabledSelector: buttonSpec fourth]. buttons add: button ]. ^(self theme builder newRow: buttons) layoutInset: (0@0 corner: 0@1); cellInset: 2! ! !Debugger methodsFor: 'construction' stamp: 'FernandoOlivero 4/12/2011 09:44'! optionalButtonRow "Answer a button pane affording the user one-touch access to certain functions; the pane is given the formal name 'buttonPane' by which it can be retrieved by code wishing to send messages to widgets residing on the pane" | buttons | buttons := OrderedCollection new. self optionalButtonPairs do: [:tuple | buttons add: ((PluggableButtonMorph on: self getState: nil action: tuple second) hResizing: #spaceFill; vResizing: #spaceFill; askBeforeChanging: (#(proceed restart send doStep stepIntoBlock fullStack where) includes: tuple second); label: tuple first asString; setBalloonText: (tuple size > 2 ifTrue: [tuple third]))]. ^(self theme builder newRow: buttons) cellInset: 2! ! !Debugger methodsFor: 'context stack (message list)'! contextStackIndex "Answer the index of the selected context." ^contextStackIndex! ! !Debugger methodsFor: 'context stack (message list)'! contextStackList "Answer the array of contexts." ^contextStackList! ! !Debugger methodsFor: 'context stack (message list)' stamp: 'CamilloBruni 10/20/2012 23:26'! contextStackListWithMultiColumn "Answer the array of contexts." | classes separators selectors | ^ (contextStackList collect: [:string || tokens | tokens := string splitOn: '>>'. {(self buildClassNameFor: tokens first). ' '. tokens second}]) inspect "classes := OrderedCollection new. selectors := OrderedCollection new. separators := OrderedCollection new. contextStackList do: [:string || tokens | tokens := string subStrings: '>>'. classes add: (self buildClassNameFor: tokens first). separators add: ' '. selectors add: tokens second ]. ^ { classes. separators. selectors }"! ! !Debugger methodsFor: 'context stack (message list)' stamp: 'BenjaminVanRyseghem 11/21/2011 17:35'! createColumnsFor: aString "Answer the array of contexts." | first second index | index := aString findString: '>>'. first := aString copyFrom: 1 to: index-1. second := aString copyFrom: index+2 to: aString size. ^ {(self buildClassNameFor: first). second}! ! !Debugger methodsFor: 'context stack (message list)' stamp: 'IgorStasenko 3/6/2011 18:38'! expandStack "A Notifier is being turned into a full debugger. Show a substantial amount of stack in the context pane." self newStack: (contextStackTop stackOfSize: 20). contextStackIndex := 0. receiverInspector := Smalltalk tools inspector inspect: nil. contextVariablesInspector := ContextVariablesInspector inspect: nil. proceedValue := nil! ! !Debugger methodsFor: 'context stack (message list)' stamp: 'sd 5/15/2010 23:01'! fullyExpandStack "Expand the stack to include all of it, rather than the first four or five contexts." self okToChange ifFalse: [^ self]. self newStack: (contextStackTop stackOfSize: contextStack size + 100000). self changed: #contextStackList! ! !Debugger methodsFor: 'context stack (message list)'! messageListIndex "Answer the index of the currently selected context." ^contextStackIndex! ! !Debugger methodsFor: 'context stack (message list)' stamp: 'CamilloBruni 7/19/2011 14:27'! partiallyExpandStack "Expand the stack to include a bit more of it, rather than the first four or five contexts." self okToChange ifFalse: [^ self]. self newStack: (contextStackTop stackOfSize: contextStack size + 20). self changed: #contextStackList! ! !Debugger methodsFor: 'context stack (message list)' stamp: 'MarcusDenker 4/29/2012 14:34'! selectedMessage "Answer the source code of the currently selected context." ^contents := self selectedContext sourceCode asText makeSelectorBold! ! !Debugger methodsFor: 'context stack (message list)' stamp: 'eem 9/5/2008 13:57'! selectedMessageName "Answer the message selector of the currently selected context. If the method is unbound we can still usefully answer its old selector." | selector | selector := self selectedContext methodSelector. ^(selector ~~ self selectedContext method selector and: [selector beginsWith: 'DoIt']) ifTrue: [self selectedContext method selector] ifFalse: [selector]! ! !Debugger methodsFor: 'context stack (message list)' stamp: 'CamilloBruni 7/19/2011 14:29'! toggleContextStackIndex: anInteger "If anInteger is the same as the index of the selected context, deselect it. Otherwise, the context whose index is anInteger becomes the selected context." self contextStackIndex: (contextStackIndex = anInteger ifTrue: [0] ifFalse: [anInteger]) oldContextWas: (contextStackIndex = 0 ifTrue: [nil] ifFalse: [contextStack at: contextStackIndex]). "if the last context is selected expand the stack automatically a bit" contextStack size = anInteger ifTrue: [ self partiallyExpandStack ].! ! !Debugger methodsFor: 'context stack menu' stamp: 'EstebanLorenzano 11/21/2009 17:01'! askForCategoryIn: aClass default: aString | categories category | categories := OrderedCollection withAll: (aClass allMethodCategoriesIntegratedThrough: Object). category := UIManager default chooseOrRequestFrom: categories title: 'Please provide a good category for the new method!!' translated. category ifNil: [^aString]. ^ category isEmptyOrNil ifTrue: [^ aString] ifFalse: [ category ]! ! !Debugger methodsFor: 'context stack menu' stamp: 'wod 5/15/1998 00:24'! browseMessages "Present a menu of all messages sent by the currently selected message. Open a message set browser of all implementors of the message chosen. Do nothing if no message is chosen." contextStackIndex = 0 ifTrue: [^ self]. super browseMessages.! ! !Debugger methodsFor: 'context stack menu' stamp: 'wod 5/15/1998 00:23'! browseSendersOfMessages "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 message chosen." contextStackIndex = 0 ifTrue: [^ self]. super browseSendersOfMessages! ! !Debugger methodsFor: 'context stack menu' stamp: 'IgorStasenko 3/6/2011 18:39'! browseVersions "Create and schedule a message set browser on all versions of the currently selected message selector." | class selector | class := self selectedClassOrMetaClass. selector := self selectedMessageName. Smalltalk tools versionBrowser browseVersionsOf: (class compiledMethodAt: selector) class: self selectedClass theNonMetaClass meta: class isMeta category: self selectedMessageCategoryName selector: selector! ! !Debugger methodsFor: 'context stack menu'! close: aScheduledController "The argument is a controller on a view of the receiver. That view is closed." aScheduledController close ! ! !Debugger methodsFor: 'context stack menu' stamp: 'sd 11/20/2005 21:27'! contextStackKey: aChar from: view "Respond to a keystroke in the context list" | selector | selector := ContextStackKeystrokes at: aChar ifAbsent: [nil]. selector ifNil: [self messageListKey: aChar from: view] ifNotNil: [self perform: selector]! ! !Debugger methodsFor: 'context stack menu' stamp: 'EstebanLorenzano 1/31/2013 19:25'! contextStackMenu: aMenu self selectedContext selector = #doesNotUnderstand: ifTrue: [ self implementStackMenu: aMenu ]. self isPostMortem ifTrue: [ self postMortemStackActionMenu: aMenu] ifFalse: [ self stackActionMenu: aMenu ]. ^aMenu addAllFromPragma: 'debuggerStackMenu' target: self.! ! !Debugger methodsFor: 'context stack menu' stamp: 'CamilloBruni 10/5/2012 17:21'! copyToClipboard Clipboard clipboardText: (String streamContents: [ :s| self interruptedContext shortDebugStackOn: s ]).! ! !Debugger methodsFor: 'context stack menu' stamp: 'EstebanLorenzano 1/31/2013 19:25'! debugProceedMenu: aMenu ^aMenu addAllFromPragma: 'debuggerStackProceedMenu' target: self.! ! !Debugger methodsFor: 'context stack menu' stamp: 'CamilloBruni 2/13/2012 19:59'! doStep "Send the selected message in the accessed method, and regain control after the invoked method returns." | currentContext newContext | self okToChange ifFalse: [^ self]. self isPostMortem ifTrue: [^ self]. self checkContextSelection. currentContext := self selectedContext. newContext := interruptedProcess completeStep: currentContext. newContext == currentContext ifTrue: [ newContext := interruptedProcess stepToSendOrReturn]. self contextStackIndex > 1 ifTrue: [self resetContext: newContext] ifFalse: [newContext == currentContext ifTrue: [self changed: #contentsSelection. self updateInspectors] ifFalse: [self resetContext: newContext]]. ! ! !Debugger methodsFor: 'context stack menu' stamp: 'tk 4/15/1998 16:55'! down "move down the context stack to the previous (enclosing) context" self toggleContextStackIndex: contextStackIndex+1! ! !Debugger methodsFor: 'context stack menu' stamp: 'sd 5/15/2010 23:06'! fullStack "Change from displaying the minimal stack to a full one." contextStack last sender isNil ifTrue: [self changed: #flash] ifFalse: [| oldContextStackIndex | oldContextStackIndex := contextStackIndex. self fullyExpandStack. oldContextStackIndex = contextStackIndex ifFalse: [self toggleContextStackIndex: oldContextStackIndex]]! ! !Debugger methodsFor: 'context stack menu' stamp: 'HernanWilkinson 10/13/2010 10:49'! implement: aMessage inClass: aClass aClass compile: (DynamicMessageImplementor for: aMessage in: aClass) value classified: (self askForCategoryIn: aClass default: 'as yet unclassified'). self setContentsToForceRefetch. self selectedContext privRefreshWith: (aClass lookupSelector: aMessage selector). self selectedContext method numArgs > 0 ifTrue: [(self selectedContext tempAt: 1) arguments withIndexDo: [:arg :index| self selectedContext tempAt: index put: arg]]. self resetContext: self selectedContext. self debug. ! ! !Debugger methodsFor: 'context stack menu' stamp: 'EstebanLorenzano 1/31/2013 19:25'! implementStackMenu: aMenu ^ aMenu addAllFromPragma: 'debuggerStackImplementMenu' target: self.! ! !Debugger methodsFor: 'context stack menu' stamp: 'MarcusDenker 10/5/2012 17:52'! messageListMenu: aMenu shifted: shifted "The context-stack menu takes the place of the message-list menu in the debugger, so pass it on" ^ self contextStackMenu: aMenu! ! !Debugger methodsFor: 'context stack menu' stamp: 'CamilloBruni 2/13/2012 19:59'! peelToFirst "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 isPostMortem ifTrue: [^ self]. contextStackIndex = 0 ifTrue: [^ Beeper beep]. "self okToChange ifFalse: [^ self]." ctxt := interruptedProcess popTo: self selectedContext findSecondToOldestSimilarSender. self resetContext: ctxt. ! ! !Debugger methodsFor: 'context stack menu' stamp: 'sd 11/20/2005 21:27'! populateImplementInMenu: aMenu | msg | msg := self selectedContext at: 1. self selectedContext receiver class withAllSuperclasses do: [:each | aMenu add: each name target: self selector: #implement:inClass: argumentList: (Array with: msg with: each)]. ^ aMenu ! ! !Debugger methodsFor: 'context stack menu' stamp: 'EstebanLorenzano 1/31/2013 19:25'! postMortemStackActionMenu: aMenu ^ aMenu addAllFromPragma: 'debuggerStackPostMortemActionMenu' target: self! ! !Debugger methodsFor: 'context stack menu' stamp: 'di 5/5/1998 00:07'! proceed "Proceed execution of the receiver's model, starting after the expression at which an interruption occurred." Smalltalk okayToProceedEvenIfSpaceIsLow ifTrue: [ self proceed: self topView]. ! ! !Debugger methodsFor: 'context stack menu' stamp: 'CamilloBruni 2/13/2012 19:59'! proceed: aTopView "Proceed from the interrupted state of the currently selected context. The argument is the topView of the receiver. That view is closed." self okToChange ifFalse: [^ self]. self isPostMortem ifTrue: [^ self]. self checkContextSelection. self resumeProcess: aTopView! ! !Debugger methodsFor: 'context stack menu' stamp: 'CamilloBruni 2/13/2012 20:00'! restart "Proceed from the initial state of the currently selected context. The argument is a controller on a view of the receiver. That view is closed." "Closing now depends on a setting (RestartAlsoProceeds class variable)" | ctxt noUnwindError | self okToChange ifFalse: [^ self]. self isPostMortem ifTrue: [^ self]. self checkContextSelection. ctxt := interruptedProcess popTo: self selectedContext. noUnwindError := false. ctxt == self selectedContext ifTrue: [ noUnwindError := true. interruptedProcess restartTop; stepToSendOrReturn]. self resetContext: ctxt. "Issue 3015 - Hernan" self isInterruptedContextATest ifTrue: [ self prepareTestToRunAgain ]. (self class restartAlsoProceeds and: [noUnwindError]) ifTrue: [self proceed]. ! ! !Debugger methodsFor: 'context stack menu' stamp: 'CamilloBruni 2/13/2012 20:00'! returnValue "Force a return of a given value to the previous context!!" | previous selectedContext expression value | contextStackIndex = 0 ifTrue: [^Beeper beep]. self isPostMortem ifTrue: [^ self]. selectedContext := self selectedContext. expression := UIManager default request: 'Enter expression for return value:'. value := self class evaluatorClass new evaluate: expression in: selectedContext to: selectedContext receiver. previous := selectedContext sender. self resetContext: previous. interruptedProcess popTo: previous value: value! ! !Debugger methodsFor: 'context stack menu' stamp: 'CamilloBruni 2/13/2012 20:00'! send "Send the selected message in the accessed method, and take control in the method invoked to allow further step or send." self okToChange ifFalse: [^ self]. self isPostMortem ifTrue: [^ self]. self checkContextSelection. interruptedProcess step: self selectedContext. self resetContext: interruptedProcess stepToSendOrReturn. ! ! !Debugger methodsFor: 'context stack menu' stamp: 'EstebanLorenzano 1/31/2013 19:25'! stackActionMenu: aMenu ^ aMenu addAllFromPragma: 'debuggerStackActionMenu' target: self ! ! !Debugger methodsFor: 'context stack menu' stamp: 'CamilloBruni 2/13/2012 20:00'! stepIntoBlock "Send messages until you return to the present method context. Used to step into a block in the method." self isPostMortem ifTrue: [^ self]. interruptedProcess stepToHome: self selectedContext. self resetContext: interruptedProcess stepToSendOrReturn.! ! !Debugger methodsFor: 'context stack menu' stamp: 'tk 4/15/1998 16:55'! up "move up the context stack to the next (enclosed) context" contextStackIndex > 1 ifTrue: [self toggleContextStackIndex: contextStackIndex-1]! ! !Debugger methodsFor: 'context stack menu' stamp: 'sd 11/20/2005 21:27'! where "Select the expression whose evaluation was interrupted." selectingPC := true. self contextStackIndex: contextStackIndex oldContextWas: self selectedContext ! ! !Debugger methodsFor: 'dependents access' stamp: 'CamilloBruni 2/13/2012 22:33'! step "Update the inspectors." self isPostMortem ifTrue: [ ^ self ]. receiverInspector ifNotNil: [receiverInspector step]. contextVariablesInspector ifNotNil: [contextVariablesInspector step]. ! ! !Debugger methodsFor: 'dependents access' stamp: 'hmm 7/15/2001 19:48'! updateInspectors "Update the inspectors on the receiver's variables." receiverInspector == nil ifFalse: [receiverInspector update]. contextVariablesInspector == nil ifFalse: [contextVariablesInspector update]! ! !Debugger methodsFor: 'dependents access' stamp: 'di 1/14/1999 09:25'! wantsSteps ^ true! ! !Debugger methodsFor: 'initialize' stamp: 'CamilloBruni 2/13/2012 19:42'! customButtonSpecs "Answer an array of elements of the form wording, selector, help-message, that characterize the custom button row of a debugger." | list | self isPostMortem ifTrue: [ ^ self postMortemCustomeButtonSpecs ]. list := #(('Proceed' proceed 'Close the debugger and proceed.') ('Restart' restart 'Reset this context to its start.') ('Into' send 'Step Into message sends') ('Over' doStep 'Step Over message sends') ('Through' stepIntoBlock 'Step into a block') ('Full Stack' fullStack 'Show full stack') ('Run to Here' runToSelection 'Run to selection') ('Where' where 'Select current pc range')). self class restartAlsoProceeds ifTrue: [list := list collect: [:each | each second == #restart ifTrue: [each copy at: 3 put: 'Proceed from the beginning of this context.'; yourself] ifFalse: [each]]]. ^ list! ! !Debugger methodsFor: 'initialize' stamp: 'kfr 10/4/2000 22:13'! debugAt: anInteger self toggleContextStackIndex: anInteger. ^ self debug.! ! !Debugger methodsFor: 'initialize' stamp: 'sd 11/20/2005 21:27'! errorWasInUIProcess: boolean errorWasInUIProcess := boolean! ! !Debugger methodsFor: 'initialize' stamp: 'AlainPlantec 1/5/2012 22:40'! initialExtent "Make the full debugger longer!!" dependents size < 9 ifTrue: [^ super initialExtent]. "Pre debug window" RealEstateAgent standardWindowExtent y < 400 "a tiny screen" ifTrue: [^ super initialExtent]. ^ [ | w h | w := Display width. h := Display height. (w - (w // 3)) @ (h - (h // 5)) ] on: Error do: [800@600 ] ! ! !Debugger methodsFor: 'initialize' stamp: 'MarcusDenker 11/2/2012 10:37'! openFullMorphicLabel: aLabelString "Open a full morphic debugger with the given label" "Open a full morphic debugger with the given label" | window aListMorph oldContextStackIndex label | oldContextStackIndex := self contextStackIndex. self expandStack. "Sets contextStackIndex to zero." label := self isPostMortem ifTrue: [ 'PostMortem: ', aLabelString ] ifFalse: [ aLabelString ] . window := (SystemWindow labelled: label) model: self. aListMorph := self buildListOfElementsFor: self. aListMorph menuTitleSelector: #messageListSelectorTitle. window addMorph: aListMorph frame: (0@0 corner: 1@0.25). self addLowerPanesTo: window at: (0@0.25 corner: 1@0.8) with: nil. window addMorph: (self buildListOfFieldsFor: self) "For doubleClick to work best disable autoDeselect" frame: (0@0.8 corner: 0.2@1). window addMorph: (self buildFieldInspectorFor: self) frame: (0.2@0.8 corner: 0.5@1). window addMorph: (self buildListOfContextFor: self) frame: (0.5@0.8 corner: 0.7@1). window addMorph: (self buildContextInspectorFor: self) frame: (0.7@0.8 corner: 1@1). window openInWorld. window center: Display center. self toggleContextStackIndex: oldContextStackIndex. self widget: window. ^ window! ! !Debugger methodsFor: 'initialize' stamp: 'JuanVuletich 11/1/2010 10:08'! openFullNoSuspendLabel: aString "Create and schedule a full debugger with the given label. Do not terminate the current active process." self openFullMorphicLabel: aString. errorWasInUIProcess := UIManager default spawnNewProcessIfThisIsUI: interruptedProcess! ! !Debugger methodsFor: 'initialize' stamp: 'StephaneDucasse 5/13/2012 17:31'! openNotifierContents: msgString label: label "Create and schedule a notifier view with the given label and message. A notifier view shows just the message or the first several lines of the stack, with a menu that allows the user to open a full debugger if so desired. " "NOTE: When this method returns, a new process has been scheduled to run the windows, and thus this notifier, but the previous active porcess has not been suspended. The sender will do this." | msg | savedCursor := Cursor currentCursor. Cursor normal show. msg := (label beginsWith: 'Space is low') ifTrue: [ self lowSpaceChoices , (msgString ifNil: [ '' ]) ] ifFalse: [ msgString ]. self buildMorphicNotifierLabelled: label message: msg. errorWasInUIProcess := UIManager default spawnNewProcessIfThisIsUI: interruptedProcess! ! !Debugger methodsFor: 'initialize' stamp: 'CamilloBruni 2/13/2012 19:43'! postMortemCustomeButtonSpecs ^ #(('Full Stack' fullStack 'Show full stack') ('Where' where 'Select current pc range'))! ! !Debugger methodsFor: 'initialize' stamp: 'CamilloBruni 2/13/2012 19:44'! postMortemPreDebugButtonQuads ^ { {'Abandon' translated. #abandon. #black. 'Abandon this execution by closing this window' translated}. {'Debug' translated. #debug. #red. 'Bring up a debugger' translated} }! ! !Debugger methodsFor: 'initialize' stamp: 'CamilloBruni 2/13/2012 22:34'! preDebugButtonQuads | buttons | self isPostMortem ifTrue: [ ^ self postMortemPreDebugButtonQuads ]. ^ { {'Proceed' translated. #proceed. #blue. 'Continue execution' translated}. {'Abandon' translated. #abandon. #black. 'Abandon this execution by closing this window' translated}. {'Debug' translated. #debug. #red. 'Bring up a debugger' translated} }! ! !Debugger methodsFor: 'initialize' stamp: 'stephane.ducasse 10/26/2008 15:33'! preDebugNotifierContentsFrom: messageString ^ messageString ! ! !Debugger methodsFor: 'initialize' stamp: 'jm 8/20/1998 18:31'! release self windowIsClosing. super release. ! ! !Debugger methodsFor: 'initialize' stamp: 'sw 1/24/2001 21:22'! wantsOptionalButtons "The debugger benefits so majorly from the optional buttons that we put them up regardless of the global setting. Some traditionalists will want to change this method manually!!" ^ true! ! !Debugger methodsFor: 'initialize' stamp: 'sd 11/20/2005 21:27'! windowIsClosing "My window is being closed; clean up. Restart the low space watcher." interruptedProcess == nil ifTrue: [^ self]. interruptedProcess terminate. interruptedProcess := nil. interruptedController := nil. contextStack := nil. contextStackTop := nil. receiverInspector := nil. contextVariablesInspector := nil. Smalltalk installLowSpaceWatcher. "restart low space handler" ! ! !Debugger methodsFor: 'notifier menu' stamp: 'alain.plantec 5/30/2008 11:43'! debug "Open a full DebuggerView." | topView | topView := self topView. topView model: nil. "so close won't release me." self breakDependents. topView delete. ^ self openFullMorphicLabel: topView label! ! !Debugger methodsFor: 'notifier menu' stamp: 'IgorStasenko 1/21/2011 19:03'! storeLog Smalltalk logError: labelString printString inContext: contextStackTop ! ! !Debugger methodsFor: 'open close' stamp: 'CamilloBruni 9/21/2012 14:29'! close ^ self delete! ! !Debugger methodsFor: 'open close' stamp: 'CamilloBruni 9/21/2012 14:34'! delete self widget ifNotNil: [ :w| w close ]! ! !Debugger methodsFor: 'tally support' stamp: 'ab 3/23/2005 16:43'! getTextMorph ^ (self dependents select: [:m| m class == PluggableTextMorph]) first! ! !Debugger methodsFor: 'tally support' stamp: 'ab 3/23/2005 16:42'! tally self getTextMorph tallyIt. ! ! !Debugger methodsFor: 'testing' stamp: 'HernanWilkinson 9/30/2010 13:54'! isInterruptedContextATest ^ (self isTestObject: self interruptedContext receiver) and: [ self isTestMethod: self interruptedContext method of: self interruptedContext receiver ]! ! !Debugger methodsFor: 'testing' stamp: 'HernanWilkinson 9/28/2010 12:11'! isInterruptedContextDoesNotUnderstand ^ self interruptedContext selector == #doesNotUnderstand:! ! !Debugger methodsFor: 'testing' stamp: 'HernanWilkinson 9/30/2010 13:57'! isTestMethod: aCompiledMethod of: aTestCase ^ aCompiledMethod selector = aTestCase selector! ! !Debugger methodsFor: 'testing' stamp: 'HernanWilkinson 9/30/2010 13:56'! 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! ! !Debugger methodsFor: 'private' stamp: 'sd 11/20/2005 21:27'! askForSuperclassOf: aClass toImplement: aSelector ifCancel: cancelBlock | classes chosenClassIndex | classes := aClass withAllSuperclasses. chosenClassIndex := UIManager default chooseFrom: (classes collect: [:c | c name]) title: 'Define #', aSelector, ' in which class?'. chosenClassIndex = 0 ifTrue: [^ cancelBlock value]. ^ classes at: chosenClassIndex! ! !Debugger methodsFor: 'private' stamp: 'CamilloBruni 10/20/2012 23:28'! buildClassNameFor: aString "shrink the name shown in the debugger " aString first = $[ ifTrue: [ ^ '[...] in ', (aString splitOn: ' in ') last ]. ^ aString ! ! !Debugger methodsFor: 'private' stamp: 'yo 8/12/2003 16:34'! checkContextSelection contextStackIndex = 0 ifTrue: [self contextStackIndex: 1 oldContextWas: nil]. ! ! !Debugger methodsFor: 'private' stamp: 'LucFabresse 10/1/2010 12:15'! contextStackIndex: anInteger oldContextWas: oldContext "Change the context stack index to anInteger, perhaps in response to user selection." | isNewMethod selectedContextSlotName index | contextStackIndex := anInteger. anInteger = 0 ifTrue: [currentCompiledMethod := contents := nil. self changed: #contextStackIndex. self decorateButtons. self contentsChanged. contextVariablesInspector object: nil. receiverInspector object: self receiver. ^ self]. selectedContextSlotName := contextVariablesInspector selectedSlotName. isNewMethod := oldContext == nil or: [oldContext method ~~ (currentCompiledMethod := self selectedContext method)]. isNewMethod ifTrue: [contents := self selectedMessage. self contentsChanged. self pcRange]. self changed: #contextStackIndex. "update the state of create button" self isInterruptedContextDoesNotUnderstand ifTrue: [self changed: #isInterruptedContextDoesNotUnderstand]. self decorateButtons. contextVariablesInspector object: self selectedContext. ((index := contextVariablesInspector fieldList indexOf: selectedContextSlotName) ~= 0 and: [index ~= contextVariablesInspector selectionIndex]) ifTrue: [contextVariablesInspector toggleIndex: index]. receiverInspector object: self receiver. isNewMethod ifFalse: [self changed: #contentsSelection]! ! !Debugger methodsFor: 'private' stamp: 'HernanWilkinson 9/28/2010 13:23'! createMethod "Should only be called when this Debugger was created in response to a MessageNotUnderstood exception. Create a stub for the method that was missing and proceed into it." | msg chosenClass | "Added due to error 3011 - Hernan" self selectedContext = self interruptedContext ifFalse: [ ^ UIManager default inform: 'Please select the #doesNotUnderstand: context']. msg := contextStackTop tempAt: 1. chosenClass := self askForSuperclassOf: contextStackTop receiver class toImplement: msg selector ifCancel: [^self]. self implement: msg inClass: chosenClass. ! ! !Debugger methodsFor: 'private' stamp: 'sd 11/20/2005 21:27'! externalInterrupt: aBoolean externalInterrupt := aBoolean ! ! !Debugger methodsFor: 'private' stamp: 'MarcusDenker 11/27/2012 12:21'! filterStack: stack "if the global settings are switched of simply return the full stack" self class filterCommonMessageSends ifFalse: [ ^ stack ]. "ask if we should keep each context or not" ^ stack select: [ :context| [self shouldDisplayContext: context] on: Exception do: [ :e| Transcript show: 'Exception occured while filtering context:', context asString; cr; show: '------------------------------------------------------'; cr; show: e asString; cr; show: '------------------------------------------------------'; cr. false]]! ! !Debugger methodsFor: 'private' stamp: 'adrian_lienhard 7/18/2009 15:53'! lowSpaceChoices "Return a notifier message string to be presented when space is running low." ^ 'Warning!! Pharo is almost out of memory!! Low space detection is now disabled. It will be restored when you close or proceed from this error notifier. Don''t panic, but do proceed with caution. Here are some suggestions: If you suspect an infinite recursion (the same methods calling each other again and again), then close this debugger, and fix the problem. If you want this computation to finish, then make more space available (read on) and choose "proceed" in this debugger. Here are some ways to make more space available... > Close any windows that are not needed. > Get rid of some large objects (e.g., images). > Leave this window on the screen, choose "save as..." from the screen menu, quit, restart the Pharo VM with a larger memory allocation, then restart the image you just saved, and choose "proceed" in this window. If you want to investigate further, choose "debug" in this window. Do not use the debugger "fullStack" command unless you are certain that the stack is not very deep. (Trying to show the full stack will definitely use up all remaining memory if the low-space problem is caused by an infinite recursion!!). ' ! ! !Debugger methodsFor: 'private' stamp: 'CamilloBruni 7/19/2011 14:45'! newStack: stack | oldStack diff | oldStack := contextStack. contextStack := self filterStack: stack. ((oldStack == nil or: [ oldStack isEmpty]) or: [oldStack last ~~ stack last]) ifTrue: [contextStackList := contextStack collect: [:ctx | ctx printString]. ^ self]. "May be able to re-use some of previous list" diff := stack size - oldStack size. contextStackList := diff <= 0 ifTrue: [contextStackList copyFrom: 1-diff to: oldStack size] ifFalse: [diff > 1 ifTrue: [contextStack collect: [:ctx | ctx printString]] ifFalse: [(Array with: stack first printString) , contextStackList]]! ! !Debugger methodsFor: 'private' stamp: 'HernanWilkinson 9/30/2010 13:57'! prepareTestToRunAgain self interruptedContext receiver prepareToRunAgain ! ! !Debugger methodsFor: 'private' stamp: 'lr 3/14/2010 21:13'! process: aProcess controller: aController context: aContext super initialize. Smalltalk globals at: #MessageTally ifPresent: [ :c | c new close ]. contents := nil. interruptedProcess := aProcess. interruptedController := aController. contextStackTop := aContext. self newStack: (contextStackTop stackOfSize: 1). contextStackIndex := 1. externalInterrupt := false. selectingPC := true. errorWasInUIProcess := false! ! !Debugger methodsFor: 'private' stamp: 'sd 11/20/2005 21:27'! resetContext: aContext "Used when a new context becomes top-of-stack, for instance when the method of the selected context is re-compiled, or the simulator steps or returns to a new method. There is room for much optimization here, first to save recomputing the whole stack list (and text), and secondly to avoid recomposing all that text (by editing the paragraph instead of recreating it)." | oldContext | oldContext := self selectedContext. contextStackTop := aContext. self newStack: contextStackTop contextStack. self changed: #contextStackList. self contextStackIndex: 1 oldContextWas: oldContext. self contentsChanged. ! ! !Debugger methodsFor: 'private' stamp: 'FernandoOlivero 3/6/2011 22:03'! resumeProcess: aTopView savedCursor notNil ifTrue:[ savedCursor show]. interruptedProcess isTerminated ifFalse: [errorWasInUIProcess ifTrue: [UIManager default resumeUIProcess: interruptedProcess] ifFalse: [interruptedProcess resume]]. "if old process was terminated, just terminate current one" interruptedProcess := nil. "Before delete, so release doesn't terminate it" aTopView delete. World displayWorld. Smalltalk installLowSpaceWatcher. "restart low space handler" errorWasInUIProcess == false ifFalse: [Processor terminateActive]! ! !Debugger methodsFor: 'private' stamp: 'MarcusDenker 9/24/2012 14:36'! selectedContext ((contextStackIndex = 0) or: [contextStack isEmpty]) ifTrue: [ ^ contextStackTop ]. (contextStackIndex > contextStack size) ifTrue: [ ^ contextStack first]. ^contextStack at: contextStackIndex! ! !Debugger methodsFor: 'private' stamp: 'CamilloBruni 4/27/2012 15:20'! shouldDisplayContext: context "called by filterStack: on each context to see if it should be displayed in the Debugger view or not." |selector receiver| selector := context method selector. receiver := context receiver. "special case for the DoIt selector" (receiver class == UndefinedObject and: [selector == #DoIt]) ifTrue: [ ^ true ]. "skip common slectors" (#(isNil ifNil: ifNotNil: ifNotNilDo:) includes: selector) ifTrue: [ ^ false ]. "skip sends to kernel classes" ({Boolean. True. False. BlockClosure. MethodContext. Array. OrderedCollection. Set. IdentitySet. Dictionary. IdentityDictionary. Class. Metaclass. Behavior. SmallInteger. Float. Error. Exception. UndefinedObject. MessageSend} includes: receiver class) ifTrue: [ ^ false ]. "skip common message sends to TestCase" (((receiver isKindOf: TestCase) and: [TestCase includesSelector: selector]) and: [(receiver class includesSelector: selector) not]) ifTrue: [ ^ false ]. "...otherwise display the context" ^ true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Debugger class instanceVariableNames: ''! !Debugger class methodsFor: '*FuelTools-Debugger' stamp: 'EstebanLorenzano 2/18/2013 18:37'! 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 platform platformName asString; nextPutAll: ' - '; nextPutAll: Smalltalk platform platformSubtype 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.! ! !Debugger class methodsFor: '*FuelTools-Debugger' stamp: 'EstebanLorenzano 2/19/2013 11:45'! serializeTestFailureContext: aContext toFileNamed: aFilename | serializer | serializer := FLSerializer newDefault. self encodeDebugInformationOn: serializer. serializer addPostMaterializationAction: [ :materialization | Smalltalk tools debugger openContext: materialization root label: 'External stack' contents: nil ]. serializer " use the sender context, generally the current context is not interesting" serialize: aContext toFileNamed: aFilename! ! !Debugger class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'FernandoOlivero 4/12/2011 09:43'! taskbarIcon "Answer the icon for the receiver in a task bar." ^ self theme smallDebugIcon! ! !Debugger class methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:28'! initialize ErrorRecursion := false. ContextStackKeystrokes := Dictionary new at: $e put: #send; at: $t put: #doStep; at: $T put: #stepIntoBlock; at: $p put: #proceed; at: $r put: #restart; at: $f put: #fullStack; at: $w put: #where; yourself. "Debugger initialize"! ! !Debugger class methodsFor: 'instance creation' stamp: 'StephaneDucasse 1/8/2010 16:04'! context: aContext "Answer an instance of me for debugging the active process starting with the given context." ^ self new process: Processor activeProcess controller: nil context: aContext ! ! !Debugger class methodsFor: 'instance creation' stamp: 'MarcusDenker 1/23/2011 09:14'! informExistingDebugger: aContext label: aString "Walking the context chain, we try to find out if we're in a debugger stepping situation. If we find the relevant contexts, we must rearrange them so they look just like they would if the methods were excuted outside of the debugger." | ctx quickStepMethod oldSender baseContext | ctx := thisContext. quickStepMethod := ContextPart compiledMethodAt: #quickSend:to:with:super:. [ctx sender == nil or: [ctx sender method == quickStepMethod]] whileFalse: [ctx := ctx sender]. ctx sender == nil ifTrue: [^self]. baseContext := ctx. "baseContext is now the context created by the #quickSend... method." oldSender := ctx := ctx sender home sender. "oldSender is the context which originally sent the #quickSend... method" [ctx isNil or: [ctx receiver isKindOf: self]] whileFalse: [ctx := ctx sender]. ctx ifNil: [^self]. "ctx is the context of the Debugger method #doStep" ctx receiver labelString: aString. ctx receiver externalInterrupt: false; proceedValue: aContext receiver. baseContext swapSender: baseContext sender sender sender. "remove intervening contexts" thisContext swapSender: oldSender. "make myself return to debugger" ErrorRecursion := false. ^aContext! ! !Debugger class methodsFor: 'menu' stamp: 'EstebanLorenzano 1/31/2013 18:30'! menuCodePane: aBuilder | target selectionInterval | target := aBuilder model first. selectionInterval := aBuilder model second. (aBuilder item: #'Run to here' translated) order: 0; "Place it on top" action: [ target runToSelection: selectionInterval ]; withSeparatorAfter. ! ! !Debugger class methodsFor: 'menu' stamp: 'MarcusDenker 2/16/2013 14:22'! menuStack: aBuilder (aBuilder item: #'Senders of...') keyText: 'n'; selector: #browseSendersOfMessages. (aBuilder item: #'Implementors of...') keyText: 'm'; selector: #browseMessages. (aBuilder item: #'Inheritance') keyText: 'i'; selector: #methodHierarchy. (aBuilder item: #'Versions') keyText: 'v'; selector: #browseVersions. (aBuilder item: #'Inst var refs...') selector: #browseInstVarRefs. (aBuilder item: #'Class var refs...') selector: #browseClassVarRefs. (aBuilder item: #'Class variables') selector: #browseClassVariables; withSeparatorAfter. (aBuilder item: #'Class refs') keyText: 'N'; selector: #browseClassRefs. (aBuilder item: #'Browse full') keyText: 'b'; selector: #browseMethodFull. (aBuilder item: #'File out') selector: #fileOutMessage. (aBuilder item: #'Inspect instances') selector: #inspectInstances. (aBuilder item: #'Inspect subinstances') selector: #inspectSubInstances; withSeparatorAfter. (aBuilder item: #'Copy to clipboard') selector: #copyToClipboard. (aBuilder item: #'Fuel out Stack') selector: #serializeStack. ! ! !Debugger class methodsFor: 'menu' stamp: 'EstebanLorenzano 1/31/2013 18:31'! menuStackAction: aBuilder (aBuilder item: #'FullStack') keyText: 'f'; selector: #fullStack. (aBuilder item: #'Restart') keyText: 'r'; selector: #restart. (aBuilder item: #'Proceed') keyText: 'p'; selector: #proceed. (aBuilder item: #'Step') keyText: 't'; selector: #doStep. (aBuilder item: #'Step through') keyText: 'T'; selector: #stepIntoBlock. (aBuilder item: #'Send') keyText: 'e'; selector: #send. (aBuilder item: #'Where') keyText: 'w'; selector: #where. (aBuilder item: #'Peel to first like this') selector: #peelToFirst; withSeparatorAfter. (aBuilder item: #'Return entered value') selector: #returnValue; withSeparatorAfter. (aBuilder item: #'Toggle break on entry') selector: #toggleBreakOnEntry. ! ! !Debugger class methodsFor: 'menu' stamp: 'EstebanLorenzano 1/31/2013 18:31'! menuStackImplement: aBuilder | target | target := aBuilder model. (aBuilder item: #'Implement in...') action: [ target populateImplementInMenu: (UIManager default newMenuIn: target for: target) ].! ! !Debugger class methodsFor: 'menu' stamp: 'EstebanLorenzano 1/31/2013 18:31'! menuStackPostMortemAction: aBuilder (aBuilder item: #'FullStack') keyText: 'f'; selector: #fullStack. (aBuilder item: #'Where') keyText: 'w'; selector: #where. ! ! !Debugger class methodsFor: 'menu' stamp: 'EstebanLorenzano 1/31/2013 18:30'! menuStackProceed: aBuilder | target | target := aBuilder model. (aBuilder item: #'Proceed' translated) selector: #proceed. (aBuilder item: #'Debug' translated) selector: #debug. ! ! !Debugger class methodsFor: 'opening' stamp: 'IgorStasenko 3/6/2011 18:39'! openContext: aContext label: aString contents: contentsStringOrNil "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." "Simulation guard" ErrorRecursion not & self logDebuggerStackToFile ifTrue: [Smalltalk logError: aString inContext: aContext]. ErrorRecursion ifTrue:[ ErrorRecursion := false. self primitiveError: aString]. ErrorRecursion := true. self informExistingDebugger: aContext label: aString. (self context: aContext) openNotifierContents: contentsStringOrNil label: aString. ErrorRecursion := false. Processor activeProcess suspend. ! ! !Debugger class methodsFor: 'opening' stamp: 'EstebanLorenzano 8/17/2012 16:40'! openInterrupt: aString onProcess: interruptedProcess "Open a notifier in response to an interrupt. An interrupt occurs when the user types the interrupt key (cmd-. on Macs, ctrl-c or alt-. on other systems) or when the low-space watcher detects that memory is low." | debugger | "Simulation guard" debugger := self new. debugger process: interruptedProcess controller: nil context: interruptedProcess suspendedContext. debugger externalInterrupt: true. self logDebuggerStackToFile ifTrue: [(aString includesSubstring: 'Space') & (aString includesSubstring: 'low') ifTrue: [Smalltalk logError: aString inContext: debugger interruptedContext ]]. ^ debugger openNotifierContents: nil label: aString! ! !Debugger class methodsFor: 'opening' stamp: 'CamilloBruni 9/21/2012 13:53'! openOn: 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." |fullView| fullView := (bool or: [self alwaysOpenFullDebugger]). ^ UIManager default openDebuggerOn: process context: context label: title contents: contentsStringOrNil fullView: fullView! ! !Debugger class methodsFor: 'settings' stamp: 'CamilloBruni 2/21/2011 11:29'! alwaysOpenFullDebugger ^ AlwaysOpenFullDebugger ifNil: [AlwaysOpenFullDebugger := false]! ! !Debugger class methodsFor: 'settings' stamp: 'MarcusDenker 3/27/2011 17:20'! alwaysOpenFullDebugger: aBoolean AlwaysOpenFullDebugger := aBoolean.! ! !Debugger class methodsFor: 'settings' stamp: 'IgorStasenko 1/21/2011 17:16'! defaultLogFileName ^ 'PharoDebug.log'! ! !Debugger class methodsFor: 'settings' stamp: 'AlainPlantec 12/6/2009 21:55'! extraDebuggerButtons ^ ExtraDebuggerButtons ifNil: [ExtraDebuggerButtons := false]! ! !Debugger class methodsFor: 'settings' stamp: 'AlainPlantec 12/6/2009 21:54'! extraDebuggerButtons: aBoolean ExtraDebuggerButtons := aBoolean! ! !Debugger class methodsFor: 'settings' stamp: 'CamilloBruni 7/19/2011 15:53'! filterCommonMessageSends ^ FilterCommonMessageSends ifNil: [FilterCommonMessageSends := false]! ! !Debugger class methodsFor: 'settings' stamp: 'StephaneDucasse 7/22/2011 18:13'! filterCommonMessageSends: aBoolean FilterCommonMessageSends := aBoolean! ! !Debugger class methodsFor: 'settings' stamp: 'AlainPlantec 12/6/2009 21:57'! logDebuggerStackToFile ^ LogDebuggerStackToFile ifNil: [LogDebuggerStackToFile := true]! ! !Debugger class methodsFor: 'settings' stamp: 'AlainPlantec 12/6/2009 21:57'! logDebuggerStackToFile: aBoolean LogDebuggerStackToFile := aBoolean! ! !Debugger class methodsFor: 'settings' stamp: 'IgorStasenko 1/21/2011 17:16'! logFileName ^ LogFileName ifNil: [ self defaultLogFileName ] ! ! !Debugger class methodsFor: 'settings' stamp: 'IgorStasenko 1/21/2011 17:17'! logFileName: newName LogFileName := newName! ! !Debugger class methodsFor: 'settings' stamp: 'AlainPlantec 12/6/2009 22:06'! restartAlsoProceeds ^ RestartAlsoProceeds ifNil: [RestartAlsoProceeds := false]! ! !Debugger class methodsFor: 'settings' stamp: 'StephaneDucasse 7/22/2011 18:13'! restartAlsoProceeds: aBoolean RestartAlsoProceeds := aBoolean! ! !Debugger class methodsFor: 'tools registry' stamp: 'IgorStasenko 2/19/2011 03:02'! registerToolsOn: registry "Add ourselves to registry. See [Smalltalk tools]" registry register: self as: #debugger ! ! !Debugger class methodsFor: 'utilities' stamp: 'IgorStasenko 4/26/2011 16:11'! closeAllDebuggers "Debugger closeAllDebuggers" (SystemWindow allSubInstances select: [:w | w model isKindOf: self ]) do: [:w | w delete]! ! !Debugger 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 lightRed ! ! Object subclass: #DebuggerMethodMap instanceVariableNames: 'methodReference methodNode abstractSourceRanges sortedSourceMap blockExtentsToTempRefs startpcsToTempRefs' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Support'! !DebuggerMethodMap commentStamp: '' prior: 0! 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: 'accessing' stamp: 'eem 6/5/2008 09:21'! method ^methodReference at: 1! ! !DebuggerMethodMap methodsFor: 'accessing' stamp: 'MarcusDenker 12/7/2011 15:16'! 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: aContext method startpcsToBlockExtents! ! !DebuggerMethodMap methodsFor: 'accessing' stamp: 'MarcusDenker 12/7/2011 15:16'! 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: aContext method startpcsToBlockExtents! ! !DebuggerMethodMap methodsFor: 'accessing' stamp: 'MarcusDenker 12/7/2011 15:17'! 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: aContext method startpcsToBlockExtents) 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: 'initialize-release' stamp: 'MarcusDenker 10/9/2012 17:48'! forMethod: aMethod "" methodNode: theMethodNode "" methodReference := WeakArray with: aMethod. methodNode := theMethodNode.! ! !DebuggerMethodMap methodsFor: 'source mapping' stamp: 'MarcusDenker 12/7/2011 15:15'! 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 method abstractPCForConcretePC: (contextIsActive ifTrue: [concretePC] ifFalse: [(self method pcPreviousTo: concretePC) ifNil: [concretePC]])! ! !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: '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: 'HenrikSperreJohansen 9/8/2011 20:42'! sortedSourceMap "Answer a sorted collection of associations, pcRangeStart -> pcRangeInterval " ^ sortedSourceMap ifNil: [sortedSourceMap := self abstractSourceMap associations sorted]! ! !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 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: 'private' stamp: 'MarcusDenker 12/7/2011 15:16'! privateIsOuter: anObject ^anObject last isArray and: [anObject last first == #outer]! ! !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'! 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: '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 class instanceVariableNames: ''! !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 ! ! TestCase subclass: #DebuggerTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolsTest-Debugger'! !DebuggerTest methodsFor: 'testing' stamp: 'MarcusDenker 4/27/2012 13:12'! testBasic | context process debugger indice| context := [ 20 factorial ] asContext. indice := 1. process := Process forContext: context priority: Processor userInterruptPriority. debugger := Smalltalk tools debugger new process: process controller: nil context: context. debugger expandStack. debugger toggleContextStackIndex: 1. "The index of the message list is 1 " self assert: debugger messageListIndex = 1. " debugger openFullNoSuspendLabel: 'hello'." " debugger down." " debugger up." self assert: debugger messageListIndex = 1. " debugger toggleContextStackIndex: 1." self assert: debugger selectedContext printString = '[20 factorial] in DebuggerTest>>testBasic'. " self assert: debugger selectedMessage = self." " debugger openFullNoSuspendLabel: 'Text'." debugger send. debugger send. self assert: debugger contents = (Integer>>#factorial) sourceCode. self assert: debugger selectedContext printString = 'SmallInteger(Integer)>>factorial'.! ! AbstractMethodConverter subclass: #DecompileMethodConverter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tools-MethodConverters'! !DecompileMethodConverter commentStamp: '' prior: 0! A DecompileMessageConverter is a wrapper wich display the decompile source code of the provided message! !DecompileMethodConverter methodsFor: 'initialization'! shouldShout ^ true.! ! !DecompileMethodConverter methodsFor: 'private'! internalGetText ^ method method decompileWithTemps decompileString asText makeSelectorBoldIn: method methodClass! ! InstructionStream subclass: #Decompiler instanceVariableNames: 'constructor method instVars tempVars constTable stack statements lastPc exit caseExits lastJumpPc lastReturnPc limit hasValue blockStackBase numLocalTemps blockStartsToTempVars tempVarCount lastJumpIfPcStack' classVariableNames: 'ArgumentFlag CascadeFlag CaseFlag IfNilFlag' poolDictionaries: '' category: 'Compiler-Kernel'! !Decompiler commentStamp: 'nice 2/3/2011 22:54' prior: 0! 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: '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'! 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: '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: '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: '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: '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: 'control'! 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: '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: 'initialize-release' stamp: 'nice 10/21/2009 00:29'! mapFromBlockStartsIn: aMethod toTempVarsFrom: schematicTempNamesString constructor: aDecompilerConstructor | map | map := aMethod mapFromBlockKeys: aMethod startpcsToBlockExtents keys asArray sort toSchematicTemps: schematicTempNamesString. 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: 'initialize-release' stamp: 'eem 6/29/2009 09:41'! withTempNames: tempNames "" "Optionally initialize the temp names to be used when decompiling. For backward-copmpatibility, if tempNames is an Array it is a single vector of temp names, probably for a blue-book-compiled method. If tempNames is a string it is a schematic string that encodes the layout of temp vars in the method and any closures/blocks within it. Decoding encoded tempNames is done in decompile:in:method:using: which has the method from which to derive blockStarts. See e.g. BytecodeEncoder>>schematicTempNamesString for syntax." tempVars := tempNames! ! !Decompiler methodsFor: 'instruction decoding'! blockReturnTop "No action needed"! ! !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: 'instruction decoding'! doDup stack last == CascadeFlag ifFalse: ["Save position and mark cascade" stack addLast: statements size. stack addLast: CascadeFlag]. stack addLast: CascadeFlag! ! !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'! doStore: stackOrBlock "Only called internally, not from InstructionStream. StackOrBlock is stack for store, statements for storePop." | var expr | var := stack removeLast. expr := stack removeLast. stackOrBlock addLast: (expr == ArgumentFlag ifTrue: [var] ifFalse: [constructor codeAssignTo: var value: expr])! ! !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: '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: 'instruction decoding'! methodReturnConstant: value self pushConstant: value; methodReturnTop! ! !Decompiler methodsFor: 'instruction decoding'! methodReturnReceiver self pushReceiver; methodReturnTop! ! !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'! popIntoLiteralVariable: value self pushLiteralVariable: value; doStore: statements! ! !Decompiler methodsFor: 'instruction decoding'! popIntoReceiverVariable: offset self pushReceiverVariable: offset; doStore: statements! ! !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: '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'! pushActiveContext stack addLast: constructor codeThisContext! ! !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: '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'! 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'! pushLiteralVariable: assoc stack addLast: (constructor codeAnyLitInd: assoc)! ! !Decompiler methodsFor: 'instruction decoding' stamp: 'eem 6/4/2008 14:45'! pushNewArrayOfSize: size self sawClosureBytecode. stack addLast: #pushNewArray -> (Array new: size)! ! !Decompiler methodsFor: 'instruction decoding'! pushReceiver stack addLast: (constTable at: 1)! ! !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: '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'! pushTemporaryVariable: offset stack addLast: (tempVars at: offset + 1)! ! !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'! storeIntoLiteralVariable: assoc self pushLiteralVariable: assoc; doStore: stack! ! !Decompiler methodsFor: 'instruction decoding'! storeIntoReceiverVariable: offset self pushReceiverVariable: offset; doStore: stack! ! !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'! storeIntoTemporaryVariable: offset self pushTemporaryVariable: offset; doStore: stack! ! !Decompiler methodsFor: 'public access'! 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 decompile: aSelector in: aClass method: (aClass compiledMethodAt: aSelector)! ! !Decompiler methodsFor: 'public access' stamp: 'eem 10/20/2008 14:09'! decompile: aSelector in: aClass method: aMethod "Answer a MethodNode that is the root of the parse tree for the argument, aMethod, which is the CompiledMethod associated with the message, aSelector. Variables are determined with respect to the argument, aClass." ^self decompile: aSelector in: aClass method: aMethod using: (self constructorForMethod: aMethod)! ! !Decompiler methodsFor: 'public access' 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: 'public access' stamp: 'StephaneDucasse 5/20/2012 18:33'! decompileBlock: aBlock "Decompile aBlock, returning the result as a BlockNode. Show temp names from source if available." "Decompiler new decompileBlock: [3 + 4]" | startpc end homeClass blockNode methodNode home | (home := aBlock home) ifNil: [^ nil]. method := home method. (homeClass := home methodClass) == #unknown ifTrue: [^ nil]. aBlock isClosure ifTrue: [(methodNode := [method decompileWithTemps] ifError: [method decompile]) ifNil: [^nil] ifNotNil: [methodNode nodesDo: [:node| node pc = aBlock startpc ifTrue: [^node]]]. ^self error: 'cannot find block node matching aBlock']. constructor := self constructorForMethod: aBlock method. self withTempNames: method methodNode tempNames. self initSymbols: homeClass. startpc := aBlock startpc. end := aBlock endPC. stack := OrderedCollection new: method frameSize. lastJumpIfPcStack := OrderedCollection new. caseExits := OrderedCollection new. statements := OrderedCollection new: 20. super method: method pc: startpc - 5. blockNode := self blockTo: end. stack isEmpty ifFalse: [self error: 'stack not empty']. ^blockNode statements first! ! !Decompiler methodsFor: 'public access'! tempAt: offset "Needed by BraceConstructor 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: 'private' stamp: 'MarcusDenker 2/26/2012 10:46'! constructorForMethod: aMethod ^DecompilerConstructorForClosures new! ! !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: 'fbs 12/19/2010 22:24'! interpretNextInstructionFor: client | code varNames | "Change false here will trace all state in Transcript." true ifTrue: [^ super interpretNextInstructionFor: client]. varNames := self class allInstVarNames. code := (self method at: pc) radix: 16. Transcript cr; cr; print: pc; space; nextPutAll: '<' , code, '>'. 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: 'di 2/6/2000 10:55'! methodRefersOnlyOnceToTemp: offset | nRefs byteCode extension scanner | nRefs := 0. offset <= 15 ifTrue: [byteCode := 16 + offset. (InstructionStream on: method) scanFor: [:instr | instr = byteCode ifTrue: [nRefs := nRefs + 1]. nRefs > 1]] ifFalse: [extension := 64 + offset. scanner := InstructionStream on: method. scanner scanFor: [:instr | (instr = 128 and: [scanner followingByte = extension]) ifTrue: [nRefs := nRefs + 1]. nRefs > 1]]. ^ nRefs = 1 ! ! !Decompiler methodsFor: 'private'! 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: '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: 'private' stamp: 'eem 6/4/2008 14:43'! sawClosureBytecode constructor isForClosures ifFalse: [constructor primitiveChangeClassTo: DecompilerConstructorForClosures new]! ! !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 instanceVariableNames: ''! !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"! ! !Decompiler class methodsFor: 'testing' stamp: 'MarcusDenker 7/12/2012 17:58'! recompileAllTest "[Decompiler recompileAllTest]" "decompile every method and compile it back; if the decompiler is correct then the system should keep running. :)" SystemNavigation new allBehaviorsDo: [ :behavior | UIManager new informUser: (behavior printString) during: [ behavior selectorsAndMethodsDo: [ :sel :meth | | ast decompiled compiled | decompiled := Decompiler new decompile: sel in: behavior. ast := self class compilerClass new compile: decompiled in: behavior notifying: nil ifFail: [ self error: 'failed' ]. compiled := ast generate: meth trailer. behavior addSelector: sel withMethod: compiled. ] ] ]! ! ParseNode subclass: #DecompilerConstructor instanceVariableNames: 'method instVars nArgs literalValues tempVars' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Support'! !DecompilerConstructor commentStamp: '' prior: 0! I construct the node tree for a Decompiler.! !DecompilerConstructor methodsFor: 'constructor'! codeAnyLitInd: association ^VariableNode new name: association key key: association index: 0 type: LdLitIndType! ! !DecompilerConstructor methodsFor: 'constructor'! codeAnyLiteral: value ^LiteralNode new key: value index: 0 type: LdLitType! ! !DecompilerConstructor methodsFor: 'constructor'! codeAnySelector: selector ^SelectorNode new key: selector index: 0 type: SendType! ! !DecompilerConstructor methodsFor: 'constructor'! codeArguments: args block: block ^block arguments: args! ! !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'! codeAssignTo: variable value: expression ^AssignmentNode new variable: variable value: expression! ! !DecompilerConstructor methodsFor: 'constructor' stamp: 'sma 3/3/2000 13:34'! codeBlock: statements returns: returns ^ BlockNode statements: statements returns: returns! ! !DecompilerConstructor methodsFor: 'constructor'! codeBrace: elements ^BraceNode new elements: elements! ! !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'! codeCascadedMessage: selector arguments: arguments ^self codeMessage: nil selector: selector arguments: arguments! ! !DecompilerConstructor methodsFor: 'constructor'! 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: 'sma 3/3/2000 13:35'! codeEmptyBlock ^ BlockNode withJust: NodeNil! ! !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: '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: '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'! codeSelector: sel code: code ^SelectorNode new key: sel code: code! ! !DecompilerConstructor methodsFor: 'constructor'! codeSuper ^NodeSuper! ! !DecompilerConstructor methodsFor: 'constructor'! codeTemp: index ^ TempVariableNode new name: 't' , (index + 1) printString index: index type: LdTempType scope: 0! ! !DecompilerConstructor methodsFor: 'constructor'! codeTemp: index named: tempName ^ TempVariableNode new name: tempName index: index type: LdTempType scope: 0! ! !DecompilerConstructor methodsFor: 'constructor'! codeThisContext ^NodeThisContext! ! !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: 'initialize-release'! method: aMethod class: aClass literals: literals method := aMethod. instVars := aClass allInstVarNames. nArgs := method numArgs. literalValues := literals! ! !DecompilerConstructor methodsFor: 'testing' stamp: 'eem 6/4/2008 14:41'! isForClosures ^false! ! !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 subclass: #DecompilerConstructorForClosures instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Support'! !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! ! !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! ! Object subclass: #DeepCopier instanceVariableNames: 'references' classVariableNames: 'NextVariableCheckTime' poolDictionaries: '' category: 'Kernel-Objects'! !DeepCopier commentStamp: 'stephane.ducasse 9/25/2008 17:47' prior: 0! 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: '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: 'like fullCopy' stamp: 'tk 3/7/2001 15:42'! 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 warnIverNotCopiedIn: aClass sel: #veryDeepInner:]]]. (aClass includesSelector: #veryDeepCopyWith:) ifTrue: [ meth := aClass compiledMethodAt: #veryDeepCopyWith:. (meth size > 20) & (meth literals includes: #veryDeepCopyWith:) not ifTrue: [ (meth writesField: aClass instSize) ifFalse: [ self warnIverNotCopiedIn: aClass sel: #veryDeepCopyWith:]]]. ! ! !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: 'eem 6/11/2008 17:21'! 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 warnIverNotCopiedIn: aClass sel: #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 warnIverNotCopiedIn: aClass sel: #veryDeepCopyWith:]]]! ! !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: 'alain.plantec 5/28/2009 09:50'! initialize super initialize. self initialize: 4096. ! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'stephane.ducasse 9/25/2008 17:46'! initialize: size references := IdentityDictionary new: size. ! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 11/24/1999 17:53'! intervalForChecks "set delay interval for checking for new instance variables to 10 minutes. hg 11/23/1999" ^600 ! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 11/25/1999 14:37'! isItTimeToCheckVariables | now isIt | NextVariableCheckTime ifNil: [ NextVariableCheckTime := Time totalSeconds. ^ true]. now := Time totalSeconds. isIt := NextVariableCheckTime < now. isIt ifTrue: ["update time for next check" NextVariableCheckTime := now + self intervalForChecks]. ^isIt ! ! !DeepCopier methodsFor: 'like fullCopy' stamp: 'tk 8/20/1998 22:13'! references ^ references! ! !DeepCopier methodsFor: 'like fullcopy' stamp: 'StephaneDucasse 10/15/2011 20:59'! warnIverNotCopiedIn: aClass sel: sel "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 ', sel, '.\Please rewrite it to handle all instance variables.\See DeepCopier class comment.') withCRs. (Smalltalk respondsTo: #tools) ifTrue: [Smalltalk tools browser fullOnClass: aClass selector: sel].! ! CommandLineHandler subclass: #DefaultCommandLineHandler instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-CommandLine'! !DefaultCommandLineHandler commentStamp: '' prior: 0! Usage: [] [--help] [--copyright] [--version] [--list] --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 a valid subcommand in --list Documentation: A DefaultCommandLineHandler handles default command line arguments and options. The DefaultCommandLineHandler is activated before all other handlers. It first checks if another handler is available. If so it will activate the found handler.! !DefaultCommandLineHandler methodsFor: 'activation' stamp: 'CamilloBruni 7/24/2012 16:38'! activate self arguments ifEmpty: [ ^ self ]. ^ self handleArgument: self arguments first.! ! !DefaultCommandLineHandler methodsFor: 'activation' stamp: 'CamilloBruni 5/2/2012 00:24'! handleArgument: aString "give priority to subcommands" self handleSubcommand == self ifFalse: [ ^ self ]. "check for default options" aString = '--version' ifTrue: [ ^ self version ]. aString = '--help' ifTrue: [ ^ self help ]. aString = '--list' ifTrue: [ ^ self list ]. aString = '--copyright' ifTrue: [ ^ self copyright ]. "none of the previous options matched hence we output an error message" self error.! ! !DefaultCommandLineHandler methodsFor: 'activation' stamp: 'CamilloBruni 5/2/2012 00:24'! handleSubcommand "check if there is an active subcommand" | handlers | handlers := self selectHandlers. "ignore the default command line handler" handlers first = DefaultCommandLineHandler ifTrue: [ ^ self ]. ^ handlers first activateWith: commandLine.! ! !DefaultCommandLineHandler methodsFor: 'activation' stamp: 'CamilloBruni 2/6/2013 18:10'! list | handlers shortNames maxShortNameSize | self stdout nextPutAll: 'Currently installed Command Line Handlers:'; lf. handlers := self allHandlers reject: [ :cls| cls = DefaultCommandLineHandler ]. 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.! ! !DefaultCommandLineHandler methodsFor: 'commands' stamp: 'CamilloBruni 4/28/2012 21:54'! copyright self stdout nextPutAll: Smalltalk licenseString; cr. self quit.! ! !DefaultCommandLineHandler methodsFor: 'commands' stamp: 'CamilloBruni 10/13/2012 15:47'! 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.! ! !DefaultCommandLineHandler methodsFor: 'commands' stamp: 'CamilloBruni 4/28/2012 22:00'! version self stdout nextPutAll: 'Image: '; print: SystemVersion current; cr; nextPutAll: 'VM: '; nextPutAll: Smalltalk vm version; cr. self quit.! ! !DefaultCommandLineHandler methodsFor: 'initialize-release' stamp: 'CamilloBruni 5/1/2012 21:24'! initialize super initialize. commandLine := CommandLineArguments new! ! !DefaultCommandLineHandler methodsFor: 'private' stamp: 'CamilloBruni 5/1/2012 21:22'! selectHandlers | handlers | handlers := CommandLineHandler selectHandlersFor: commandLine. handlers := handlers sort: [ :a :b| a priority >= b priority ]. ^ handlers! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DefaultCommandLineHandler class instanceVariableNames: ''! !DefaultCommandLineHandler class methodsFor: 'accessing' stamp: 'CamilloBruni 1/25/2013 01:23'! commandName ^ ''! ! !DefaultCommandLineHandler class methodsFor: 'class initialization' stamp: 'CamilloBruni 5/2/2012 11:34'! initialize "hook into the startup list" Smalltalk addToStartUpList: self.! ! !DefaultCommandLineHandler class methodsFor: 'class initialization' stamp: 'CamilloBruni 5/1/2012 21:18'! startUp: resuming "only handle when lauching a new image" resuming ifFalse: [ ^ self ]. Smalltalk addDeferredStartupAction: [ self new activate ]! ! !DefaultCommandLineHandler class methodsFor: 'handler selection' stamp: 'CamilloBruni 5/3/2012 14:13'! description ^ 'responsible for the default options and activating other commands'! ! !DefaultCommandLineHandler class methodsFor: 'handler selection' stamp: 'CamilloBruni 4/28/2012 01:27'! isResponsibleFor: aCommandLine ^ true! ! !DefaultCommandLineHandler class methodsFor: 'handler selection' stamp: 'CamilloBruni 5/2/2012 11:34'! priority "low priority" ^ Float infinity negated! ! Object subclass: #DefaultExternalDropHandler instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Support'! !DefaultExternalDropHandler commentStamp: 'dgd 4/5/2004 19:07' prior: 0! An alternative default handler that uses the file-list services to process files. ! !DefaultExternalDropHandler methodsFor: '*Morphic' 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'! 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'! 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'! unwantedSelectors "private - answer a collection well known unwanted selectors " ^ #(#removeLineFeeds: #addFileToNewZip: #compressFile: #putUpdate: )! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DefaultExternalDropHandler class instanceVariableNames: ''! !DefaultExternalDropHandler class methodsFor: 'initialization'! initialize "initialize the receiver" ExternalDropHandler defaultHandler: self new! ! !DefaultExternalDropHandler class methodsFor: 'initialization'! unload "initialize the receiver" ExternalDropHandler defaultHandler: nil! ! WriteStream subclass: #DeflateStream instanceVariableNames: 'hashHead hashTail hashValue blockPosition blockStart' classVariableNames: '' poolDictionaries: 'ZipConstants' category: 'Compression-Streams'! !DeflateStream commentStamp: 'LaurentLaffont 6/8/2011 22:23' prior: 0! 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: '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: '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: '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! ! !DeflateStream methodsFor: 'accessing' stamp: 'CamilleTeruel 11/2/2012 11:52'! nextPutAll: aCollection ^ self next: aCollection size putAll: aCollection startingAt: 1! ! !DeflateStream methodsFor: 'accessing' stamp: 'ar 12/28/1999 17:35'! pastEndPut: anObject self deflateBlock. ^self nextPut: anObject! ! !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: '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: '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: '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: 'deflating' stamp: 'ar 12/28/1999 17:37'! flushBlock "Flush a deflated block"! ! !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: '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: '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/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: '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: '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: '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/29/1999 17:32'! initializeHashTables hashHead := WordArray new: 1 << HashBits. hashTail := WordArray new: WindowSize. ! ! !DeflateStream methodsFor: 'initialization' stamp: 'ar 12/29/1999 17:33'! on: aCollection self initialize. super on: (aCollection species new: WindowSize * 2).! ! !DeflateStream methodsFor: 'initialization' stamp: 'ar 12/28/1999 17:34'! on: aCollection from: firstIndex to: lastIndex "Not for DeflateStreams please" ^self shouldNotImplement! ! !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: '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]].! ! Object subclass: #Delay instanceVariableNames: 'delayDuration resumptionTime delaySemaphore beingWaitedOn' classVariableNames: 'AccessProtect ActiveDelay ActiveDelayStartTime DelaySuspended FinishedDelay RunTimerEventLoop ScheduledDelay SuspendedDelays TimerEventLoop TimingSemaphore' poolDictionaries: '' category: 'Kernel-Processes'! !Delay commentStamp: 'VeronicaUquillas 6/11/2010 14:54' prior: 0! 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: 'delaying' stamp: 'nk 3/14/2001 08:52'! isExpired ^delaySemaphore isSignaled. ! ! !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: '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: '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: 'ar 7/10/2007 21:49'! beingWaitedOn: aBool "Indicate whether this delay is currently scheduled, e.g., being waited on" beingWaitedOn := aBool! ! !Delay methodsFor: 'public' stamp: 'ar 7/10/2007 20:56'! delayDuration ^delayDuration! ! !Delay methodsFor: 'public' stamp: 'brp 10/21/2004 16:05'! delaySemaphore ^ delaySemaphore! ! !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: '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: '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: '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: '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: '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: 'private' stamp: 'jm 9/11/97 11:54'! signalWaitingProcess "The delay time has elapsed; signal the waiting process." beingWaitedOn := false. delaySemaphore signal. ! ! !Delay methodsFor: 'private' stamp: 'ar 3/2/2009 14:42'! unschedule AccessProtect critical:[ FinishedDelay := self. TimingSemaphore signal. ].! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Delay class instanceVariableNames: ''! !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: 'instance creation' stamp: 'brp 9/25/2003 13:43'! forDuration: aDuration ^ self forMilliseconds: aDuration asMilliSeconds ! ! !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: 'instance creation' stamp: 'laza 1/30/2005 22:11'! forSeconds: aNumber ^ self forMilliseconds: aNumber * 1000 ! ! !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: '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: 'snapshotting' stamp: 'ar 3/2/2009 14:44'! 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: [:d | d adjustResumptionTimeOldBase: 0 newBase: newBaseTime]. ActiveDelay == nil ifFalse: [ ActiveDelay adjustResumptionTimeOldBase: 0 newBase: newBaseTime. ]. ! ! !Delay class methodsFor: 'snapshotting' stamp: 'jm 9/11/97 15:15'! 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: [:d | d adjustResumptionTimeOldBase: oldBaseTime newBase: 0]. ! ! !Delay class methodsFor: 'snapshotting' stamp: 'ar 9/30/2007 12:46'! 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 wait. self primSignal: nil atMilliseconds: 0. self saveResumptionTimes. DelaySuspended := true.! ! !Delay class methodsFor: 'snapshotting' stamp: 'GuillermoPolito 12/7/2012 13:52'! 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. self restoreResumptionTimes. AccessProtect signal. ! ! !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: 'testing'! nextWakeUpTime ^ AccessProtect critical: [ActiveDelay isNil ifTrue: [0] ifFalse: [ActiveDelay resumptionTime]]! ! !Delay class methodsFor: 'timer process' stamp: 'ar 8/24/2007 12:36'! 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 initSignals. 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" ! ! !Delay class methodsFor: 'timer process' stamp: 'ar 3/2/2009 14:40'! runTimerEventLoop "Run the timer event loop." [RunTimerEventLoop] whileTrue: [self handleTimerEvent]! ! !Delay class methodsFor: 'timer process' stamp: 'GaryChambers 4/11/2011 10:05'! scheduleDelay: aDelay "Private. Schedule this Delay." aDelay resumptionTime: Time millisecondClockValue + aDelay delayDuration. "Gary Chambers: 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: 'timer process' stamp: 'StephaneDucasse 5/18/2012 18:19'! schedulingProcess ^ TimerEventLoop ! ! !Delay class methodsFor: 'timer process' stamp: 'ar 3/2/2009 14:40'! startTimerEventLoop "Start the timer event loop" "Delay startTimerEventLoop" self stopTimerEventLoop. AccessProtect := Semaphore forMutualExclusion. ActiveDelayStartTime := Time millisecondClockValue. SuspendedDelays := Heap withAll: (SuspendedDelays ifNil:[#()]) sortBlock: [:d1 :d2 | d1 resumptionTime <= d2 resumptionTime]. TimingSemaphore := Semaphore new. RunTimerEventLoop := true. TimerEventLoop := [self runTimerEventLoop] newProcess. TimerEventLoop priority: Processor timingPriority. TimerEventLoop resume. TimingSemaphore signal. "get going" ! ! !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: 'timer process' stamp: 'ar 8/30/2007 19:59'! 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.! ! TestCase subclass: #DelayTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Processes'! !DelayTest methodsFor: 'testing' stamp: 'nice 4/19/2009 21:21'! testBounds "self run: #testBounds" self should: [Delay forMilliseconds: -1] raise: Error. self shouldnt: [Delay forMilliseconds: SmallInteger maxVal // 2 + 1] raise: Error. self shouldnt: [Delay forMilliseconds: SmallInteger maxVal + 1] raise: Error. self shouldnt: [(Delay forMilliseconds: Float pi) wait] raise: Error. "Wait 3ms" ! ! !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: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-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. ! ! Delay subclass: #DelayWaitTimeout instanceVariableNames: 'process expired' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Processes'! !DelayWaitTimeout commentStamp: '' prior: 0! DelayWaitTimeout is a special kind of Delay used in waitTimeoutMSecs: to avoid signaling the underlying semaphore when the wait times out.! !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: '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: 'private' stamp: 'ar 3/23/2009 16:38'! setDelay: anInteger forSemaphore: aSemaphore super setDelay: anInteger forSemaphore: aSemaphore. process := Processor activeProcess. expired := false.! ! FileSystemVisitor subclass: #DeleteVisitor instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Core-Implementation'! !DeleteVisitor commentStamp: 'cwp 11/18/2009 12:30' prior: 0! 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: 'EstebanLorenzano 4/2/2012 11:38'! visit: aReference PostorderGuide show: aReference to: self! ! !DeleteVisitor methodsFor: 'visiting' stamp: 'cwp 11/16/2009 10:53'! visitReference: anEntry anEntry reference delete! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DeleteVisitor class instanceVariableNames: ''! !DeleteVisitor class methodsFor: 'instance creation' stamp: 'cwp 11/17/2009 13:02'! delete: aReference ^ self new visit: aReference! ! SingleTreeTest subclass: #DeleteVisitorTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Tests-Core'! !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'). ! ! MessageDialogWindow subclass: #DenyDialogWindow instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Windows'! !DenyDialogWindow commentStamp: 'gvc 5/18/2007 13:27' prior: 0! 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: 'gvc 5/18/2007 10:27'! icon "Answer an icon for the receiver." ^self theme lockIcon! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DenyDialogWindow class instanceVariableNames: ''! !DenyDialogWindow class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'gvc 5/22/2007 11:52'! taskbarIcon "Answer the icon for the receiver in a task bar." ^self theme smallLockIcon! ! Collection weakSubclass: #DependentsArray instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Models'! !DependentsArray commentStamp: 'nice 11/11/2009 20:30' prior: 0! 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: '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: '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: 'accessing' stamp: 'nice 11/11/2009 17:19'! first self do: [:dep | ^dep]. self error: 'this collection is empty'! ! !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: 'converting' stamp: 'nice 12/18/2009 11:05'! writeStream ^ WriteStream on: self! ! !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: '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 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: '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: '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: '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 class instanceVariableNames: ''! !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'! with: firstObject with: secondObject ^(self basicNew: 2) basicAt: 1 put: firstObject; basicAt: 2 put: secondObject; 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: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 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: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'! withAll: aCollection | newInstance | newInstance := self basicNew: aCollection size. 1 to: aCollection size do: [:i | newInstance basicAt: i put: (aCollection at: i)]. ^newInstance! ! TestCase subclass: #DependentsArrayTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Objects'! !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! ! Warning subclass: #Deprecation instanceVariableNames: 'methodReference explanationString deprecationDate versionString' classVariableNames: 'Log RaiseWarning ShowWarning' poolDictionaries: '' category: 'Kernel-Exceptions'! !Deprecation commentStamp: 'dew 5/21/2003 17:46' prior: 0! 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'! deprecationDate "Answer the value of deprecationDate" ^ deprecationDate! ! !Deprecation methodsFor: 'accessing' stamp: 'eem 7/3/2009 19:07'! explanationString "Answer the value of explanationString" ^ explanationString! ! !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'! 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: 'comparing' stamp: 'eem 7/3/2009 19:08'! hash ^(methodReference ifNil: [explanationString]) hash! ! !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: '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: 'settings' stamp: 'AlainPlantec 12/11/2009 10:08'! raiseWarning ^ self class raiseWarning! ! !Deprecation methodsFor: 'settings' stamp: 'AlainPlantec 12/11/2009 10:08'! showWarning ^ self class showWarning! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Deprecation class instanceVariableNames: ''! !Deprecation class methodsFor: 'class initialization' stamp: 'GuillermoPolito 5/21/2012 01:57'! initialize Log := nil! ! !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! ! !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 ^ ShowWarning ifNil: [ShowWarning := true]! ! !Deprecation class methodsFor: 'settings' stamp: 'AlainPlantec 12/11/2009 10:07'! showWarning: aBoolean ShowWarning := aBoolean! ! DialogGroupManager subclass: #DialogGroupAdder instanceVariableNames: 'elementToAdd elementsToAdd' classVariableNames: '' poolDictionaries: '' category: 'GroupManagerUI'! !DialogGroupAdder methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/28/2011 14:01'! elementsToAdd ^ elementsToAdd! ! !DialogGroupAdder methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/28/2011 14:02'! elementsToAdd: anObject elementsToAdd := anObject! ! !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 ]! ! DialogGroupManagerUI subclass: #DialogGroupAdderUI instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'GroupManagerUI'! !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: 'build items' stamp: 'BenjaminVanRyseghem 3/28/2011 14:02'! elementsToAdd ^ self groupManager elementsToAdd! ! !DialogGroupAdderUI methodsFor: 'build items' stamp: 'BenjaminVanRyseghem 2/25/2012 16:41'! text ^ (self groupManager elementsToAdd collect: [:elt | elt prettyName ]) asArray joinUsing: '. '! ! !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: 'tree' stamp: 'BenjaminVanRyseghem 3/24/2011 13:28'! groups ^ self groupManager groups groups select: [:group | group isFillable & group isReadOnly not ]! ! !DialogGroupAdderUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/14/2012 12:15'! valid self selectedGroup ifNotNil: [:group | self groupManager add: self elementsToAdd into: group ]! ! Object subclass: #DialogGroupManager instanceVariableNames: 'groups' classVariableNames: '' poolDictionaries: '' category: 'GroupManagerUI'! !DialogGroupManager methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/15/2011 13:34'! groups ^ groups! ! !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: 'display' stamp: 'BenjaminVanRyseghem 3/29/2011 11:14'! uiClass ^ DialogGroupManagerUI! ! DialogWindow subclass: #DialogGroupManagerUI instanceVariableNames: 'groupManager treeModel tree' classVariableNames: '' poolDictionaries: '' category: 'GroupManagerUI'! !DialogGroupManagerUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/15/2011 13:36'! groupManager ^ groupManager! ! !DialogGroupManagerUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/17/2011 15:11'! groupManager: aModel groupManager := aModel! ! !DialogGroupManagerUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 3/15/2011 14:33'! addAction self addAGroup! ! !DialogGroupManagerUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 3/15/2011 14:21'! addLabel ^ 'Create'! ! !DialogGroupManagerUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 3/15/2011 14:08'! addState ^ true! ! !DialogGroupManagerUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 9/15/2011 15:48'! removeAction self removeAGroup! ! !DialogGroupManagerUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 3/15/2011 14:08'! removeLabel ^ 'Remove'! ! !DialogGroupManagerUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 3/15/2011 14:08'! removeState ^ self selectedGroup notNil! ! !DialogGroupManagerUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 3/15/2011 15:33'! renameAction self renameGroup! ! !DialogGroupManagerUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 3/15/2011 15:34'! renameLabel ^ 'Rename'! ! !DialogGroupManagerUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 3/15/2011 15:34'! renameState ^ self selectedGroup notNil! ! !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: 'display' stamp: 'BenjaminVanRyseghem 3/15/2011 14:11'! buildRemoveButton ^ (PluggableButtonMorph on: self getState: #removeState action: #removeAction label: #removeLabel) hResizing: #spaceFill; yourself ! ! !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: 'display' stamp: 'BenjaminVanRyseghem 3/15/2011 15:32'! initialExtent ^ 300@400! ! !DialogGroupManagerUI methodsFor: 'display' stamp: 'BenjaminVanRyseghem 3/15/2011 15:25'! isResizeable ^true! ! !DialogGroupManagerUI methodsFor: 'display' stamp: 'BenjaminVanRyseghem 3/15/2011 15:45'! newContentMorph ^(self newColumn: {self treeBox}) hResizing: #spaceFill! ! !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: '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: 'tree' stamp: 'BenjaminVanRyseghem 3/22/2011 17:11'! groups ^ self groupManager groups groups! ! !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 9/15/2011 16:53'! addAGroup | group | group := self groupManager groups createAnEmptyStaticGroup. tree updateList. treeModel hardlySelectItem: group.! ! !DialogGroupManagerUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/17/2011 15:11'! applyChanges self valid! ! !DialogGroupManagerUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/15/2011 14:21'! okButtonAction self valid.! ! !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: 'private' stamp: 'BenjaminVanRyseghem 9/19/2011 16:35'! renameGroup self groupManager groups renameAGroup: self selectedGroup. tree updateList.! ! !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: '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: 'private' stamp: 'BenjaminVanRyseghem 3/15/2011 14:14'! updateSelectedNode self changed: #removeState! ! !DialogGroupManagerUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/15/2011 15:48'! valid! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DialogGroupManagerUI class instanceVariableNames: ''! !DialogGroupManagerUI class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 3/29/2011 15:33'! on: aModel ^ self basicNew groupManager: aModel; initialize.! ! Object subclass: #DialogItemsChooser instanceVariableNames: 'methodNameUI choicesList selection unselectedItems selectedItems resultList model title selectedItemsSetterSelector unselectedLabel selectedLabel' classVariableNames: '' poolDictionaries: '' category: 'Tools-Finder'! !DialogItemsChooser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/16/2010 20:56'! choicesList choicesList isNil ifTrue: [choicesList := OrderedCollection new]. ^choicesList! ! !DialogItemsChooser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/17/2010 02:27'! choicesList: anObject choicesList := anObject! ! !DialogItemsChooser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/17/2010 02:27'! methodNameUI ^ methodNameUI! ! !DialogItemsChooser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/17/2010 02:27'! methodNameUI: anObject methodNameUI := anObject! ! !DialogItemsChooser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/16/2010 21:02'! resultList ^ resultList! ! !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: 'accessing' stamp: 'BenjaminVanRyseghem 9/17/2010 02:13'! selectedItemsSetterSelector ^selectedItemsSetterSelector! ! !DialogItemsChooser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/17/2010 02:14'! selectedItemsSetterSelector: aSelector selectedItemsSetterSelector := aSelector! ! !DialogItemsChooser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 17:04'! selectedLabel ^selectedLabel! ! !DialogItemsChooser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 17:04'! selectedLabel: anObject selectedLabel := anObject! ! !DialogItemsChooser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/17/2010 02:12'! selection ^selection! ! !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/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'! unselectedItems ^ unselectedItems! ! !DialogItemsChooser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/17/2010 02:27'! unselectedItems: anObject unselectedItems := anObject! ! !DialogItemsChooser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 17:04'! unselectedLabel ^unselectedLabel! ! !DialogItemsChooser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 17:04'! unselectedLabel: anObject unselectedLabel := anObject! ! !DialogItemsChooser methodsFor: 'display' stamp: 'BenjaminVanRyseghem 11/1/2011 07:35'! open (self uiClass on: self) title: self title; openInWorld! ! !DialogItemsChooser methodsFor: 'initialize-release' stamp: 'BenjaminVanRyseghem 9/16/2010 00:26'! initialize super initialize. selection := OrderedCollection new.! ! !DialogItemsChooser methodsFor: 'initialize-release' stamp: 'BenjaminVanRyseghem 9/17/2010 02:02'! model ^model! ! !DialogItemsChooser methodsFor: 'initialize-release' stamp: 'BenjaminVanRyseghem 9/17/2010 02:02'! model: aModel model := aModel! ! !DialogItemsChooser methodsFor: 'initialize-release' stamp: 'BenjaminVanRyseghem 9/18/2010 16:59'! uiClass ^DialogItemsChooserUI! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DialogItemsChooser class instanceVariableNames: ''! !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.! ! DialogWindow subclass: #DialogItemsChooserUI instanceVariableNames: 'dialogItemsChooser selectedItems selectedItemsModel unselectedItems unselectedItemsModel unselectedItemsSearchingString selectedItemsSearchingString unselectedItemsTextArea selectedItemsTextArea unselectedSelection selectedSelectionIndex selectedSelectionList unselectedSelectionList unselectedSelectionIndex selectedItemsList' classVariableNames: 'AlreadySearchedSelectedItemsList AlreadySearchedUnselectedItemsList' poolDictionaries: '' category: 'Tools-Finder'! !DialogItemsChooserUI commentStamp: 'BenjaminVanRyseghem 9/17/2010 00:20' prior: 0! unselectedItems is the original list to search in selectItems is the list of the selected items! !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: '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: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 16:21'! alreadySearchedSelectedItemsList ^AlreadySearchedSelectedItemsList ifNil: [AlreadySearchedSelectedItemsList := OrderedCollection new]! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 16:24'! alreadySearchedSelectedItemsListMaxSize ^self class alreadySearchedSelectedItemsListMaxSize! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 16:41'! alreadySearchedSelectedItemsListMaxSize: anInteger [self alreadySearchedSelectedItemsList size > anInteger] whileTrue: [self alreadySearchedSelectedItemsList removeLast]! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 15:51'! alreadySearchedUnselectedItemsList ^AlreadySearchedUnselectedItemsList ifNil: [AlreadySearchedUnselectedItemsList := OrderedCollection new]! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 16:42'! alreadySearchedUnselectedItemsListMaxSize ^self class alreadySearchedUnselectedItemsListMaxSize! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 16:42'! alreadySearchedUnselectedItemsListMaxSize: anInteger [self alreadySearchedUnselectedItemsList size > anInteger] whileTrue: [self alreadySearchedUnselectedItemsList removeLast]! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 17:16'! dialogItemsChooser ^ dialogItemsChooser! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 17:16'! dialogItemsChooser: aDialogItemsChooser dialogItemsChooser := aDialogItemsChooser! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 14:10'! selectedItems ^ selectedItems! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/17/2010 00:53'! selectedItems: aList selectedItems := aList.! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/16/2010 23:49'! selectedItemsModel ^ selectedItemsModel! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/16/2010 23:49'! selectedItemsModel: anObject selectedItemsModel := anObject! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 16:44'! selectedItemsSearchingString ^ selectedItemsSearchingString! ! !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: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 16:46'! selectedItemsTextArea ^ selectedItemsTextArea! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 16:46'! selectedItemsTextArea: anObject selectedItemsTextArea := anObject! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 17:22'! selectedLabel ^self dialogItemsChooser isNil ifTrue: ['Selected Items' translated] ifFalse: [self dialogItemsChooser selectedLabel]! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/17/2010 00:43'! unselectedItems ^unselectedItems! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/17/2010 00:52'! unselectedItems: anOrderedCollection unselectedItems := anOrderedCollection.! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 14:16'! unselectedItemsModel ^ unselectedItemsModel! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 14:16'! unselectedItemsModel: anObject unselectedItemsModel := anObject! ! !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: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 15:36'! unselectedItemsTextArea ^unselectedItemsTextArea! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 15:35'! unselectedItemsTextArea: anObject unselectedItemsTextArea := 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 12/1/2010 15:52'! unselectedSelection unselectedSelection ifNil: [unselectedSelection := 0]. ^unselectedSelection! ! !DialogItemsChooserUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/1/2010 15:44'! unselectedSelection: anObject unselectedSelection := anObject! ! !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: '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: '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: '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: '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: '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: '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: '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: '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 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: '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 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: '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: '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: 'buttons creations' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! addAllButtonAction self addAllItems.! ! !DialogItemsChooserUI methodsFor: 'buttons creations' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! addAllButtonLabel ^'>>'! ! !DialogItemsChooserUI methodsFor: 'buttons creations' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! addAllButtonState ^false! ! !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'! addButtonLabel ^'>'! ! !DialogItemsChooserUI methodsFor: 'buttons creations' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! addButtonState ^false! ! !DialogItemsChooserUI methodsFor: 'buttons creations' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! cancelButtonLabel ^'Cancel'! ! !DialogItemsChooserUI methodsFor: 'buttons creations' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! cancelButtonState ^false! ! !DialogItemsChooserUI methodsFor: 'buttons creations' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! okButtonAction self valid.! ! !DialogItemsChooserUI methodsFor: 'buttons creations' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! okButtonLabel ^'Ok'! ! !DialogItemsChooserUI methodsFor: 'buttons creations' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! okButtonState ^false! ! !DialogItemsChooserUI methodsFor: 'buttons creations' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! removeAllButtonAction self removeAllItems.! ! !DialogItemsChooserUI methodsFor: 'buttons creations' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! removeAllButtonLabel ^'<<'! ! !DialogItemsChooserUI methodsFor: 'buttons creations' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! removeAllButtonState ^false! ! !DialogItemsChooserUI methodsFor: 'buttons creations' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! removeButtonAction self removeSelectedItems.! ! !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: 'buttons creations' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! searchButtonLabel ^'Search'! ! !DialogItemsChooserUI methodsFor: 'buttons creations' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! searchButtonState ^false! ! !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: 'display' stamp: 'bvr 9/19/2010 19:32'! isResizeable ^true! ! !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: 'display' stamp: 'BenjaminVanRyseghem 11/1/2011 07:42'! openInWorld super openInWorld. self width: 500. self height: 400. self centering ! ! !DialogItemsChooserUI methodsFor: 'initialize-release' 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: '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 13:58'! hasSelectedSelections "Answer whether the selected list has selected items." ^selectedSelectionList anySatisfy: [:selected | selected]! ! !DialogItemsChooserUI methodsFor: 'selectedList' stamp: 'BenjaminVanRyseghem 12/2/2010 17:50'! selectedSelectionAt: index ^selectedSelectionList at: index ifAbsent: [false]! ! !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: 'selectedList' stamp: 'BenjaminVanRyseghem 12/2/2010 17:34'! selectedSelectionIndex selectedSelectionIndex ifNil: [selectedSelectionIndex := 0]. ^selectedSelectionIndex! ! !DialogItemsChooserUI methodsFor: 'selectedList' stamp: 'BenjaminVanRyseghem 12/2/2010 17:34'! selectedSelectionIndex: anObject selectedSelectionIndex := anObject. self changed: #selectedSelectionIndex! ! !DialogItemsChooserUI methodsFor: 'unselectedList' stamp: 'GaryChambers 2/11/2011 13:47'! hasUnselectedItems "Answer whether the unselected list has items." ^self unselectedItems notEmpty! ! !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: 'unselectedList' stamp: 'BenjaminVanRyseghem 12/2/2010 17:52'! unselectedSelectionAt: index ^unselectedSelectionList at: index ifAbsent: [false]! ! !DialogItemsChooserUI methodsFor: 'unselectedList' stamp: 'BenjaminVanRyseghem 12/2/2010 17:52'! unselectedSelectionAt: index Put: anObject unselectedSelectionList at: index put: anObject! ! !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 methodsFor: 'unselectedList' stamp: 'BenjaminVanRyseghem 12/2/2010 17:52'! unselectedSelectionIndex unselectedSelectionIndex ifNil: [unselectedSelectionIndex := 0]. ^unselectedSelectionIndex! ! !DialogItemsChooserUI methodsFor: 'unselectedList' stamp: 'BenjaminVanRyseghem 12/2/2010 17:52'! unselectedSelectionIndex: anObject unselectedSelectionIndex := anObject. self changed: #unselectedSelectionIndex! ! !DialogItemsChooserUI methodsFor: 'private' stamp: 'BenjaminVanRyseghem 9/16/2010 20:51'! applyChanges self valid! ! !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: 'private' stamp: 'BenjaminVanRyseghem 9/18/2010 16:49'! roots: aTree aTree == unselectedItemsModel ifTrue: [ ^ self unselectedItemsProbablyRestricted]. aTree == selectedItemsModel ifTrue:[ ^ self selectedItemsProbablyRestricted].! ! !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: '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: 'private' stamp: 'BenjaminVanRyseghem 9/18/2010 17:17'! valid self dialogItemsChooser sendSelection! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DialogItemsChooserUI class instanceVariableNames: 'alreadySearchedSelectedItemsListMaxSize alreadySearchedUnselectedItemsListMaxSize'! !DialogItemsChooserUI class methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 16:25'! alreadySearchedSelectedItemsListMaxSize ^ alreadySearchedSelectedItemsListMaxSize! ! !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! ! !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: 'initialize-release' stamp: 'bvr 9/19/2010 19:23'! initialize super initialize. alreadySearchedUnselectedItemsListMaxSize := 15. alreadySearchedSelectedItemsListMaxSize := 15! ! !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: '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.]! ! StandardWindow subclass: #DialogWindow instanceVariableNames: 'cancelled isResizeable' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Windows'! !DialogWindow commentStamp: 'gvc 5/18/2007 13:26' prior: 0! 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: '*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: '*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: '*Polymorph-Widgets' stamp: 'gvc 9/22/2009 11:16'! wantsGrips "Answer whether the window wants edge and corner grips." ^self isResizeable! ! !DialogWindow methodsFor: 'accessing' stamp: 'gvc 8/14/2006 14:12'! cancelled "Answer the value of cancelled" ^ cancelled! ! !DialogWindow methodsFor: 'accessing' stamp: 'gvc 8/14/2006 14:12'! cancelled: anObject "Set the value of cancelled" cancelled := anObject! ! !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: 'actions' stamp: 'gvc 8/25/2006 10:25'! addInitialPanel "Add the panel." self addMainPanel! ! !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: 'actions' stamp: 'gvc 8/27/2006 11:11'! applyChanges "Apply the changes." self acceptTextMorphs! ! !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 8/25/2006 10:10'! cancel "Cancel and close." self close! ! !DialogWindow methodsFor: 'actions' stamp: 'gvc 8/25/2006 10:10'! close "Close the window." self delete! ! !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: 'actions' stamp: 'gvc 8/14/2006 12:40'! defaultLabel "Answer the default label for the receiver." ^'Dialog' translated! ! !DialogWindow methodsFor: 'actions' stamp: 'gvc 1/10/2007 13:42'! escapePressed "Default is to cancel." self cancel! ! !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: '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: '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/14/2006 11:58'! newContentMorph "Answer a new content morph." ^Morph new color: Color transparent; hResizing: #spaceFill; vResizing: #spaceFill! ! !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 8/14/2006 14:12'! ok "Apply the changes and close." self cancelled: false; applyChanges; delete! ! !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: 'controls' stamp: 'BenjaminVanRyseghem 5/23/2011 22:34'! beResizeable isResizeable := true. self addGripsIfWanted! ! !DialogWindow methodsFor: 'controls' stamp: 'BenjaminVanRyseghem 5/23/2011 22:36'! beUnresizeable isResizeable := false. self removeGrips! ! !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: '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: '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: '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: '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: '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: 'initialization' stamp: 'gvc 4/3/2008 11:52'! initialize "Initialize the receiver." super initialize. self cancelled: true; addInitialPanel! ! !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: 'initialization' stamp: 'gvc 6/1/2009 12:21'! setFramesForLabelArea "Delegate to theme." self theme configureDialogWindowLabelAreaFrameFor: self! ! !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: 'testing' stamp: 'BenjaminVanRyseghem 5/23/2011 22:22'! isResizeable "Answer whether we are not we can be resized." ^ isResizeable ifNil: [ isResizeable := false ]! ! !DialogWindow methodsFor: 'theme' stamp: 'gvc 5/24/2007 11:35'! activeFillStyle "Return the active fillStyle for the receiver." ^self theme dialogWindowActiveFillStyleFor: self! ! !DialogWindow methodsFor: 'theme' stamp: 'gvc 4/24/2007 16:19'! animateClose "Animate closing."! ! !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:26'! preferredCornerStyle "Answer the preferred corner style." ^self theme dialogWindowPreferredCornerStyleFor: self! ! !DialogWindow methodsFor: 'theme' stamp: 'gvc 6/2/2009 10:36'! wantsRoundedCorners "Answer whether rounded corners are wanted." ^(self theme dialogWindowPreferredCornerStyleFor: self) == #rounded! ! !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]]! ! WindowModel subclass: #DialogWindowModel instanceVariableNames: 'contentMorph' classVariableNames: '' poolDictionaries: '' category: 'Spec-Widgets'! !DialogWindowModel commentStamp: '' prior: 0! A DialogWindowModel is a model used to describe a DialogWindow! !DialogWindowModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/10/2012 16:14'! contentMorph ^ contentMorph! ! !DialogWindowModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/10/2012 16:25'! cancelAction: aBlock ^ self widget ifNotNil: [:w | w cancelAction: aBlock ]! ! !DialogWindowModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/10/2012 16:25'! cancelled ^ self widget ifNil: [ false ] ifNotNil: [:w | w cancelled ]! ! !DialogWindowModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/10/2012 16:25'! okAction: aBlock ^ self widget ifNotNil: [:w | w okAction: aBlock ]! ! !DialogWindowModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/10/2012 16:25'! toolbar ^ self widget ifNotNil: [:w | w toolbar ]! ! !DialogWindowModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 10/18/2012 15:21'! buildWithSpec: 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: [ contentMorph := self model ifNil: [ nil ] ifNotNil: [:m | m buildWithSpec: aSpec ]. widget := SpecInterpreter buildWidgetFor: self withSpec: self defaultSpecSelector. contentMorph := nil ]. self extent ifNotNil: [:ex | (widget respondsTo: #extent:) ifTrue: [ widget extent: ex ]]. ^ widget! ! !DialogWindowModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 10/18/2012 15:21'! 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: [ contentMorph := self model buildWithSpecLayout: aSpec. widget := SpecInterpreter buildWidgetFor: self withSpec: self defaultSpecSelector. contentMorph := nil ]. self extent ifNotNil: [:ex | (widget respondsTo: #extent:) ifTrue: [ widget extent: ex ]]. ^ widget! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DialogWindowModel class instanceVariableNames: ''! !DialogWindowModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 7/10/2012 16:22'! defaultSpec ^ #( DialogWindowSpec specWidget: #(model contentMorph) initialize model: model )! ! WindowSpec subclass: #DialogWindowSpec instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Spec-Core-Specs'! !DialogWindowSpec methodsFor: 'private' stamp: 'BenjaminVanRyseghem 7/10/2012 15:55'! classSymbol ^ #DialogWindow! ! !DialogWindowSpec methodsFor: 'private' stamp: 'BenjaminVanRyseghem 7/10/2012 16:07'! initializeInstance ^ self defaultReceiver basicNew.! ! HashedCollection subclass: #Dictionary instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Unordered'! !Dictionary commentStamp: '' prior: 0! 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: '*Compiler' stamp: 'ar 5/17/2003 14:07'! bindingOf: varName ^self associationAt: varName ifAbsent:[nil]! ! !Dictionary methodsFor: '*Compiler' stamp: 'ar 5/18/2003 20:33'! bindingsDo: aBlock ^self associationsDo: aBlock! ! !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: '*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: '*Spec-Core'! asValueHolder ^ DictionaryValueHolder contents: self! ! !Dictionary methodsFor: '*Tools-Explorer' stamp: 'yo 8/27/2008 23:16'! customizeExplorerContents ^ true. ! ! !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: '*Tools-Inspector' stamp: 'ar 9/27/2005 18:32'! 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." ^ DictionaryInspector! ! !Dictionary methodsFor: 'accessing' stamp: 'CamilloBruni 4/11/2011 13:30'! associationAt: key ^ self associationAt: key ifAbsent: [self errorKeyNotFound: key]! ! !Dictionary methodsFor: 'accessing'! 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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: 'adding'! 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: 'adding'! 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: '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: '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: '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: '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: '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: '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: 'enumerating' stamp: 'MarcusDenker 7/2/2010 13:02'! do: aBlock ^self valuesDo: aBlock! ! !Dictionary methodsFor: 'enumerating' stamp: 'MarianoMartinezPeck 8/24/2012 15:26'! keysAndValuesDo: aBlock ^self associationsDo:[:assoc| aBlock value: assoc key value: assoc value].! ! !Dictionary methodsFor: 'enumerating'! keysDo: aBlock "Evaluate aBlock for each of the receiver's keys." self associationsDo: [:association | aBlock value: association key]! ! !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: 'enumerating' stamp: 'dtl 2/17/2003 09:48'! valuesDo: aBlock "Evaluate aBlock for each of the receiver's values." self associationsDo: [:association | aBlock value: association value]! ! !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: 'printing'! 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: '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: '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: 'removing'! 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: 'removing'! removeUnreferencedKeys "Undeclared removeUnreferencedKeys" ^ self unreferencedKeys do: [:key | self removeKey: key].! ! !Dictionary methodsFor: 'removing'! remove: anObject self shouldNotImplement! ! !Dictionary methodsFor: 'removing'! remove: anObject ifAbsent: exceptionBlock self shouldNotImplement! ! !Dictionary methodsFor: 'removing' stamp: 'SeanDeNigris 6/21/2012 08:49'! 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 allSelect: [: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: '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: 'testing' stamp: 'ab 9/17/2004 00:39'! includesAssociation: anAssociation ^ (self associationAt: anAssociation key ifAbsent: [ ^ false ]) value = anAssociation value ! ! !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: 'testing' stamp: 'RAA 8/23/2001 12:56'! includesKey: key "Answer whether the receiver has a key equal to the argument, key." self at: key ifAbsent: [^false]. ^true! ! !Dictionary methodsFor: 'testing'! includes: anObject self do: [:each | anObject = each ifTrue: [^true]]. ^false! ! !Dictionary methodsFor: 'testing' stamp: 'md 8/11/2005 16:49'! isDictionary ^true! ! !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: '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: 'private' stamp: 'SvenVanCaekenberghe 4/19/2011 19:41'! errorKeyNotFound: aKey KeyNotFound signalFor: aKey! ! !Dictionary methodsFor: 'private' stamp: 'SvenVanCaekenberghe 4/19/2011 20:30'! errorValueNotFound: value ValueNotFound signalFor: value! ! !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: '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: '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 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: 'private'! rehash "Smalltalk rehash." | newSelf | newSelf := self species new: self size. self associationsDo: [:each | newSelf noCheckAdd: each]. array := newSelf array! ! !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: 'private'! 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 class instanceVariableNames: ''! !Dictionary class methodsFor: 'instance creation'! 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}. "! ! Inspector subclass: #DictionaryInspector instanceVariableNames: 'keyArray' classVariableNames: '' poolDictionaries: '' category: 'Tools-Inspector'! !DictionaryInspector commentStamp: 'LaurentLaffont 3/4/2011 22:44' prior: 0! I provide a custom inspector for classes of type Dictionary. These customizations are tools to interactively manipulate the Dictionary I'm inspecting and they are accessed in the context menu of the currently selected association. The customizations that I provide are as follows: inspect -> Create and schedule an Inspector on my currently selected association copy name -> copy the name of my currently selected association so that it can be pasted somewhere else references -> Create a browser on all references to the association of the current selection objects pointing to this value -> Open a list inspector on all the objects that point to the value of the selected instance variable, if any. senders of this key -> Create a browser on all senders of the selected key refresh view add key rename key remove basic inspect -> Bring up a non-special inspector ! !DictionaryInspector methodsFor: 'accessing' stamp: 'apb 8/20/2004 23:06'! fieldList ^ self baseFieldList , (keyArray collect: [:key | key printString])! ! !DictionaryInspector methodsFor: 'initialization' stamp: 'PHK 7/21/2004 18:00'! initialize super initialize. self calculateKeyArray! ! !DictionaryInspector methodsFor: 'menu' stamp: 'jb 7/1/2011 10:51'! addEntry | newKey aKey | newKey := UIManager default request: 'Enter new key, then type RETURN. (Expression will be evaluated for value.) Examples: #Fred ''a string'' 3+4'. aKey := self class evaluatorClass evaluate: newKey. object at: aKey put: nil. self calculateKeyArray. selectionIndex := self numberOfFixedFields + (keyArray indexOf: aKey). self changed: #inspectObject. self changed: #selectionIndex. self changed: #fieldList. self update! ! !DictionaryInspector methodsFor: 'menu' stamp: 'apb 8/20/2004 21:19'! copyName "Copy the name of the current variable, so the user can paste it into the window below and work with is. If collection, do (xxx at: 1)." | sel | self selectionIndex <= self numberOfFixedFields ifTrue: [super copyName] ifFalse: [sel := String streamContents: [:strm | strm nextPutAll: '(self at: '. (keyArray at: selectionIndex - self numberOfFixedFields) storeOn: strm. strm nextPutAll: ')']. Clipboard clipboardText: sel asText "no undo allowed"]! ! !DictionaryInspector methodsFor: 'menu' stamp: 'EstebanLorenzano 1/31/2013 19:25'! fieldListMenu: aMenu ^aMenu addAllFromPragma: 'dictionaryInspectorFieldListMenu' target: self.! ! !DictionaryInspector methodsFor: 'menu' stamp: 'sd 11/20/2005 21:27'! removeSelection selectionIndex = 0 ifTrue: [^ self changed: #flash]. object removeKey: (keyArray at: selectionIndex - self numberOfFixedFields). selectionIndex := 0. contents := ''. self calculateKeyArray. self changed: #inspectObject. self changed: #selectionIndex. self changed: #fieldList. self changed: #selection.! ! !DictionaryInspector methodsFor: 'menu' stamp: 'jb 7/1/2011 10:51'! renameEntry | newKey aKey value | value := object at: (keyArray at: selectionIndex - self numberOfFixedFields). newKey := UIManager default request: 'Enter new key, then type RETURN. (Expression will be evaluated for value.) Examples: #Fred ''a string'' 3+4' initialAnswer: (keyArray at: selectionIndex - self numberOfFixedFields) printString. newKey isNil ifFalse: [ aKey := self class evaluatorClass evaluate: newKey. object removeKey: (keyArray at: selectionIndex - self numberOfFixedFields). object at: aKey put: value. self calculateKeyArray. selectionIndex := self numberOfFixedFields + (keyArray indexOf: aKey). self changed: #selectionIndex. self changed: #inspectObject. self changed: #fieldList. self update ]! ! !DictionaryInspector methodsFor: 'menu' stamp: 'ar 10/31/2004 17:26'! selectionReferences "Create a browser on all references to the association of the current selection." self selectionIndex = 0 ifTrue: [^ self changed: #flash]. object class == MethodDictionary ifTrue: [^ self changed: #flash]. self systemNavigation browseAllCallsOn: (object associationAt: (keyArray at: selectionIndex - self numberOfFixedFields)). ! ! !DictionaryInspector methodsFor: 'menu' stamp: 'MarcusDenker 7/12/2012 18:00'! sendersOfSelectedKey "Create a browser on all senders of the selected key" | aKey | self selectionIndex = 0 ifTrue: [^ self changed: #flash]. ((aKey := keyArray at: selectionIndex - self numberOfFixedFields) isSymbol) ifFalse: [^ self changed: #flash]. SystemNavigation new browseAllCallsOn: aKey! ! !DictionaryInspector methodsFor: 'selecting' stamp: 'sd 11/20/2005 21:27'! addEntry: aKey object at: aKey put: nil. self calculateKeyArray. selectionIndex := self numberOfFixedFields + (keyArray indexOf: aKey). self changed: #inspectObject. self changed: #selectionIndex. self changed: #fieldList. self update! ! !DictionaryInspector methodsFor: 'selecting' stamp: 'CamilloBruni 2/28/2012 11:44'! calculateKeyArray "Recalculate the KeyArray from the object being inspected" keyArray := object keysSortedSafely asArray. selectionIndex := 1. ! ! !DictionaryInspector methodsFor: 'selecting' stamp: 'di 9/22/1998 21:25'! contentsIsString "Hacked so contents empty when deselected" ^ (selectionIndex = 0)! ! !DictionaryInspector methodsFor: 'selecting' stamp: 'sd 11/20/2005 21:27'! refreshView | i | i := selectionIndex. self calculateKeyArray. selectionIndex := i. self changed: #fieldList. self changed: #contents.! ! !DictionaryInspector methodsFor: 'selecting' stamp: 'apb 8/20/2004 22:37'! replaceSelectionValue: anObject selectionIndex <= self numberOfFixedFields ifTrue: [^ super replaceSelectionValue: anObject]. ^ object at: (keyArray at: selectionIndex - self numberOfFixedFields) put: anObject! ! !DictionaryInspector methodsFor: 'selecting' stamp: 'apb 8/20/2004 21:55'! selection selectionIndex <= (self numberOfFixedFields) ifTrue: [^ super selection]. ^ object at: (keyArray at: selectionIndex - self numberOfFixedFields) ifAbsent:[nil]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DictionaryInspector class instanceVariableNames: ''! !DictionaryInspector class methodsFor: 'menu' stamp: 'EstebanLorenzano 1/31/2013 18:32'! menuDictionaryFieldList: aBuilder (aBuilder item: #'Inspect') selector: #inspectSelection. (aBuilder item: #'Copy name') selector: #copyName. (aBuilder item: #'References') selector: #selectionReferences. (aBuilder item: #'Senders of this key') selector: #sendersOfSelectedKey. (aBuilder item: #'Refresh view') selector: #refreshView. (aBuilder item: #'Add key') selector: #addEntry; withSeparatorAfter. (aBuilder item: #'Rename key') selector: #renameEntry. (aBuilder item: #'Remove') selector: #removeSelection. (aBuilder item: #'Basic inspect') selector: #inspectBasic. ! ! !DictionaryInspector class methodsFor: 'tools registry' stamp: 'IgorStasenko 2/20/2011 15:12'! registerToolsOn: registry "Register ourselves as inspector for Dictionary (and its subclasses)" registry registerInspector: self for: Dictionary ! ! CollectionRootTest subclass: #DictionaryTest uses: TIncludesTest + TDictionaryAddingTest + TDictionaryComparingTest + TDictionaryCopyingTest + TDictionaryEnumeratingTest + TDictionaryPrintingTest - {#testPrintElementsOn. #testStoreOn} + TDictionaryRemovingTest + TPutBasicTest - {#testAtPutOutOfBounds} + TAsStringCommaAndDelimiterTest + TPrintTest + TConvertTest + TConvertAsSortedTest + TCopyTest - {#testCopyEmptyWithout. #testCopyNonEmptyWithout. #testCopyNonEmptyWithoutNotIncluded} + TSetArithmetic + TDictionaryIncludesWithIdentityCheckTest + TDictionaryValueAccessTest + TDictionaryKeysValuesAssociationsAccess + TDictionaryKeyAccessTest + TDictionaryAssociationAccessTest + TStructuralEqualityTest + TOccurrencesForMultiplinessTest instanceVariableNames: 'emptyDict nonEmptyDict nonEmpty5ElementsNoDuplicates indexArray valueArray nonEmpty1Element collectionNotIncluded collectionIncluded associationNotIn valueNotIn keyNotIn dictionaryNotIncluded nonEmptyWithFloat dictionaryWithDuplicateValues duplicateValue' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Unordered'! !DictionaryTest methodsFor: 'helpers' stamp: 'stephane.ducasse 1/12/2009 17:24'! aValue ^ 33! ! !DictionaryTest methodsFor: 'helpers' stamp: 'stephane.ducasse 1/12/2009 17:25'! anIndex ^ #GG! ! !DictionaryTest methodsFor: 'helpers' stamp: 'stephane.ducasse 1/12/2009 17:25'! anotherValue ^ 66! ! !DictionaryTest methodsFor: 'requirement' stamp: 'stephane.ducasse 11/21/2008 15:05'! anotherElementNotIn ^ 42! ! !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: 'requirement' stamp: 'delaunay 5/5/2009 14:15'! associationWithKeyNotInToAdd " return an association that will be used to add to nonEmptyDict" ^ associationNotIn ! ! !DictionaryTest methodsFor: 'requirement' stamp: 'damienpollet 1/13/2009 16:15'! collection ^ self nonEmptyDict! ! !DictionaryTest methodsFor: 'requirement' stamp: 'delaunay 4/2/2009 11:53'! elementNotInForOccurrences ^ 666! ! !DictionaryTest methodsFor: 'requirement' stamp: 'stephane.ducasse 11/21/2008 15:04'! empty ^ emptyDict! ! !DictionaryTest methodsFor: 'requirement' stamp: 'AlexandreBergel 1/6/2009 15:06'! emptyDict ^ emptyDict! ! !DictionaryTest methodsFor: 'requirement' stamp: 'damienpollet 1/21/2009 18:22'! expectedElementByDetect ^ 30! ! !DictionaryTest methodsFor: 'requirement' stamp: 'damienpollet 1/30/2009 17:44'! expectedSizeAfterReject self flag: 'what should this return?'! ! !DictionaryTest methodsFor: 'requirement' stamp: 'AlexandreBergel 1/6/2009 15:09'! newEmptyDict ^ self emptyDict copy! ! !DictionaryTest methodsFor: 'requirement' stamp: 'AlexandreBergel 1/6/2009 15:06'! nonEmptyDict ^ nonEmptyDict ! ! !DictionaryTest methodsFor: 'requirement' stamp: 'damienpollet 1/13/2009 16:35'! result ^ Dictionary newFromPairs: { #a . SmallInteger . #b . SmallInteger . #c . SmallInteger . #d . SmallInteger }! ! !DictionaryTest methodsFor: 'requirement' stamp: 'damienpollet 1/13/2009 16:55'! sizeCollection ^ nonEmptyDict! ! !DictionaryTest methodsFor: 'requirement' stamp: 'damienpollet 1/21/2009 18:04'! speciesClass ^ Dictionary! ! !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: '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 11:32'! collectionClass " return the class to be used to create instances of the class tested" ^ Dictionary! ! !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: '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: 'requirements' stamp: 'delaunay 4/29/2009 11:09'! collectionWithElementsToRemove " return a collection of elements included in 'nonEmpty' " ^ collectionIncluded ! ! !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: 'requirements' stamp: 'delaunay 4/28/2009 15:52'! collectionWithoutEqualElements " return a collection without equal elements" ^ nonEmpty5ElementsNoDuplicates ! ! !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 16:08'! element ^ 30! ! !DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 14:51'! elementNotIn "return an element not included in 'nonEmpty' " ^ valueNotIn! ! !DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 10:17'! elementToAdd " return an element of type 'nonEmpy' elements'type'" ^ #u->5.! ! !DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 15:54'! elementTwiceInForOccurrences " return an element included exactly two time in # collectionWithEqualElements" ^ duplicateValue ! ! !DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 10:12'! indexInNonEmpty " return an index between bounds of 'nonEmpty' " ^ #a! ! !DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 15:52'! integerCollectionWithoutEqualElements " return a collection of integer without equal elements" ^ nonEmpty5ElementsNoDuplicates ! ! !DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 5/4/2009 16:05'! keyNotIn " return a key not included in nonEmpty" ^ keyNotIn ! ! !DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 15:00'! keyNotInNonEmpty " return a key not included in nonEmpty" ^ keyNotIn ! ! !DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 5/5/2009 15:21'! keyNotInNonEmptyDict " return a key not included in nonEmptyDict" ^ keyNotIn ! ! !DictionaryTest methodsFor: 'requirements' stamp: 'stephane.ducasse 11/21/2008 15:04'! nonEmpty ^ nonEmptyDict! ! !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/6/2009 10:09'! nonEmptyDifferentFromNonEmptyDict " return a dictionary for which all keys are not included in nonEmptyDict" ^ dictionaryNotIncluded ! ! !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: 'requirements' stamp: 'delaunay 5/5/2009 10:41'! nonEmptyWithoutEqualsValues " return a dictionary that doesn't include equal values'" ^nonEmpty5ElementsNoDuplicates ! ! !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 5/5/2009 10:41'! valueNotIn " return a value not included in nonEmpty " ^valueNotIn ! ! !DictionaryTest methodsFor: 'requirements' stamp: 'delaunay 4/29/2009 15:00'! valueNotInNonEmpty " return a value not included in nonEmpty" ^ valueNotIn ! ! !DictionaryTest methodsFor: 'setup' stamp: 'AlexandreBergel 1/14/2009 15:14'! classToBeTested ^ Dictionary! ! !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: '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: 'test - adding'! testAddAll | collectionToAdd collection result oldSize | collection := self nonEmptyDict . oldSize := collection size. collectionToAdd := Dictionary 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: '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 - 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: 'test - adding'! testDeclareFrom | newDict v dictionary keyIn associationKeyNotIn | dictionary := self nonEmptyDict. keyIn := dictionary keys anyOne. associationKeyNotIn := self associationWithKeyNotInToAdd . newDict := Dictionary 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: 'test - comparing'! 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 - copying'! 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: 'test - copying'! 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: 'test - copying' stamp: 'delaunay 5/6/2009 10:12'! testDictionaryConcatenationWithoutCommonKeys "self run: #testDictionaryConcatenation" "| dict1 dict2 dict3 | dict1 := self emptyDict. dict1 at: #a put: 'Nicolas' ; at: #b put: 'Damien'. dict2 := self emptyDict. dict2 at: #a put: 'Christophe' ; at: #c put: 'Anthony'. dict3 := dict1, dict2. self assert: (dict3 at: #a) = 'Christophe'. self assert: (dict3 at: #b) = 'Damien'. self assert: (dict3 at: #c) = 'Anthony'. " | 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: 'test - equality'! testEqualSign "self debug: #testEqualSign" self deny: (self empty = self nonEmpty).! ! !DictionaryTest methodsFor: 'test - equality'! 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: 'test - equality'! testEqualSignOfIdenticalCollectionObjects "self debug: #testEqualSignOfIdenticalCollectionObjects" self assert: (self empty = self empty). self assert: (self nonEmpty = self nonEmpty). ! ! !DictionaryTest methodsFor: 'test - integrity' stamp: 'IgorStasenko 3/22/2011 16:19'! testAllDictionariesAreHealthy self assert: (Dictionary allSubInstances select: [:dict | dict isHealthy not ]) isEmpty.! ! !DictionaryTest methodsFor: 'test - integrity' stamp: 'IgorStasenko 3/22/2011 16:16'! testAllMethodDictionariesAreHealthy self assert: (MethodDictionary allInstances select: [:dict | dict isHealthy not ]) isEmpty.! ! !DictionaryTest methodsFor: 'test - integrity' stamp: 'MarcusDenker 6/3/2011 13:42'! testHealthyWorks "we use associations as keys on purpose, because they changing hash depending on the key" | a1 a2 dict | 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: '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: 'test - removing'! 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: 'test - removing'! testRemove self should: [self nonEmptyDict remove: nil] raise: Error. self should: [self nonEmptyDict remove: nil ifAbsent: ['What ever here']] raise: Error.! ! !DictionaryTest methodsFor: 'test - removing'! 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: 'test - removing'! 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: 'test - testing' stamp: 'AlexandreBergel 1/6/2009 11:56'! testHasBindingThatBeginsWith | newDict | newDict := Dictionary 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: '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 - testing' stamp: 'damienpollet 1/30/2009 17:57'! 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 := Dictionary new. newDict at: #a put: o1. self assert: (newDict includes: o2). ! ! !DictionaryTest methodsFor: 'test - testing' stamp: 'GabrielOmarCotelli 6/6/2009 19:07'! testIncludesAssociationNoValue | association dictionary | association := Association key: #key. self assert: association value isNil. dictionary := Dictionary new. dictionary add: association. self assert: (dictionary at: #key) isNil ! ! !DictionaryTest methodsFor: 'test - testing' stamp: 'GabrielOmarCotelli 6/6/2009 19:08'! testIncludesAssociationWithValue | association dictionary | association := Association key: #key value: 1. dictionary := Dictionary new. dictionary add: association. self assert: (dictionary at: #key) = 1 ! ! !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 - 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: 'test - testing' stamp: 'stephane.ducasse 5/20/2009 18:08'! testOccurrencesOf "self run:#testOccurrencesOf" | dict | dict := Dictionary 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 ) = 2. self assert: (dict occurrencesOf: nil ) = 2. ! ! !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' stamp: 'StephaneDucasse 5/13/2010 12:09'! testAtIfPresentIfAbsent "Test at:ifPresent:ifAbsent:" "to move to the corresponding trait" | dict present absent | dict := Dictionary 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' stamp: 'ar 11/12/2009 21:58'! testNilHashCollision "Ensures that fixCollisionsFrom: does the right thing in the presence of a nil key" | dict key | dict := Dictionary 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' stamp: 'nice 9/14/2009 21:07'! testRemoveAll "Allows one to remove all elements of a collection" | dict1 dict2 s2 | dict1 := Dictionary 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: 'tests' stamp: 'StephaneDucasse 10/24/2009 11:27'! testSelectIsNotShallowCopy "self debug: #testSelectIsNotShallowCopy" | original even | original := Dictionary 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'! 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 - Dictionary keys values associations access'! testKeys | collection result | collection := self nonEmpty. result := collection keys. result do: [ :key | self shouldnt: [collection at: key ] raise:Error ]. self assert: result size = collection size . self should: [result detect: [:each | (result occurrencesOf: each ) > 1] ] raise: Error. ! ! !DictionaryTest methodsFor: 'tests - Dictionary keys values associations access'! testKeysSortedSafely | collection result | collection := self nonEmpty. result := collection keysSortedSafely . result do: [ :key | self shouldnt: [collection at: key ] raise:Error ]. 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 - Dictionary keys values associations access'! 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'! testAt | collection association | collection := self nonEmpty . association := collection associations anyOne. self assert: (collection at: association key) = association value.! ! !DictionaryTest methodsFor: 'tests - DictionaryIndexAccessing'! testAtError "self run: #testAtError" | dict nonExistantKey keyIn | dict := self nonEmpty . nonExistantKey := self keyNotIn . keyIn := dict keys anyOne. self shouldnt: [ dict at: keyIn ] raise: Error. self should: [ dict at: nonExistantKey ] raise: Error. ! ! !DictionaryTest methodsFor: 'tests - DictionaryIndexAccessing'! 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: 'tests - DictionaryIndexAccessing'! 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: 'tests - DictionaryIndexAccessing'! 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: 'tests - DictionaryIndexAccessing'! 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 - DictionaryIndexAccessing'! 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: 'tests - as sorted collection' stamp: 'hfm 4/2/2010 13:37'! 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 - as sorted collection'! 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: 'tests - as sorted collection'! 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: 'tests - as string comma delimiter sequenceable'! testAsCommaStringEmpty self assert: self empty asCommaString = ''. self assert: self empty asCommaStringAnd = ''. ! ! !DictionaryTest methodsFor: 'tests - as string comma delimiter sequenceable'! 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: 'tests - as string comma delimiter sequenceable'! testAsCommaStringOne self nonEmpty1Element do: [:each | self assert: each asString =self nonEmpty1Element asCommaString. self assert: each asString=self nonEmpty1Element asCommaStringAnd.]. ! ! !DictionaryTest methodsFor: 'tests - as string comma delimiter sequenceable'! testAsStringOnDelimiterEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim. self assert: emptyStream contents = ''. ! ! !DictionaryTest methodsFor: 'tests - as string comma delimiter sequenceable'! testAsStringOnDelimiterLastEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim last:'and'. self assert: emptyStream contents = ''. ! ! !DictionaryTest methodsFor: 'tests - as string comma delimiter sequenceable'! 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: 'tests - as string comma delimiter sequenceable'! 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 - as string comma delimiter sequenceable'! 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: 'tests - as string comma delimiter sequenceable'! 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 - at put'! testAtPut "self debug: #testAtPut" self nonEmpty at: self anIndex put: self aValue. self assert: (self nonEmpty at: self anIndex) = self aValue. ! ! !DictionaryTest methodsFor: 'tests - at put'! 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 - converting'! 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 - converting'! 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 - converting'! assertSameContents: aCollection whenConvertedTo: aClass | result | result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass. self assert: result size = aCollection size! ! !DictionaryTest methodsFor: 'tests - converting'! testAsArray "self debug: #testAsArray3" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Array! ! !DictionaryTest methodsFor: 'tests - converting'! testAsBag self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! ! !DictionaryTest methodsFor: 'tests - converting'! testAsByteArray | res | self shouldnt: [self integerCollectionWithoutEqualElements ] raise: Error. 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 - converting'! testAsIdentitySet "test with a collection without equal elements :" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: IdentitySet. ! ! !DictionaryTest methodsFor: 'tests - converting'! testAsOrderedCollection self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! ! !DictionaryTest methodsFor: 'tests - copy'! 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 - copy'! 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: 'tests - copy'! 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 - copy'! 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 - copy'! 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 - copy'! 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 - copy'! 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 - copy'! 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 - copy - clone'! testCopyCreatesNewObject "self debug: #testCopyCreatesNewObject" | copy | copy := self nonEmpty copy. self deny: self nonEmpty == copy. ! ! !DictionaryTest methodsFor: 'tests - copy - clone'! testCopyEmpty "self debug: #testCopyEmpty" | copy | copy := self empty copy. self assert: copy isEmpty.! ! !DictionaryTest methodsFor: 'tests - copy - clone'! 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: 'tests - dictionary assocition access'! 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 - dictionary assocition access'! testAssociationAtError | collection nonExistantKey | collection := self nonEmpty. nonExistantKey := self keyNotIn . self should: [collection associationAt: nonExistantKey] raise: Error. ! ! !DictionaryTest methodsFor: 'tests - dictionary assocition access'! 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 - dictionary including'! 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: 'tests - dictionary including'! 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 - dictionary including'! testIncludesIdentityBasicComportement | valueIn collection | collection := self nonEmpty . valueIn := collection values anyOne. self assert: (collection includesIdentity: valueIn ) . self deny: (collection includesIdentity: self valueNotInNonEmpty ).! ! !DictionaryTest methodsFor: 'tests - dictionary including'! testIncludesIdentitySpecificComportement | valueIn collection | collection := self nonEmptyWithCopyNonIdentical . valueIn := collection values anyOne. self assert: (collection includesIdentity: valueIn ) . self deny: (collection includesIdentity: valueIn copy ) . ! ! !DictionaryTest methodsFor: 'tests - dictionary including'! 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 - dictionary key access'! 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 - 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: 'tests - dictionary key access'! 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: '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 - dictionnary enumerating'! 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 - dictionnary enumerating'! 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: 'tests - dictionnary enumerating'! 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 - dictionnary enumerating'! 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: 'tests - dictionnary enumerating'! 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 - dictionnary enumerating'! 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 - dictionnary enumerating'! 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 - dictionnary enumerating'! 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: 'tests - dictionnary enumerating'! 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 - fixture'! test0CopyTest self shouldnt: [ self empty ]raise: Error. self assert: self empty size = 0. self shouldnt: [ self nonEmpty ]raise: Error. self assert: (self nonEmpty size = 0) not. self shouldnt: [ self collectionWithElementsToRemove ]raise: Error. self assert: (self collectionWithElementsToRemove size = 0) not. self collectionWithElementsToRemove do: [:each | self assert: ( self nonEmpty includes: each)]. self shouldnt: [ self elementToAdd ]raise: Error. self deny: (self nonEmpty includes: self elementToAdd ). self shouldnt: [ self collectionNotIncluded ]raise: Error. self collectionNotIncluded do: [ :each | self deny: (self nonEmpty includes: each) ]! ! !DictionaryTest methodsFor: 'tests - fixture'! test0FixtureAsStringCommaAndDelimiterTest self shouldnt: [self nonEmpty] raise:Error . self deny: self nonEmpty isEmpty. self shouldnt: [self empty] raise:Error . self assert: self empty isEmpty. self shouldnt: [self nonEmpty1Element ] raise:Error . self assert: self nonEmpty1Element size=1.! ! !DictionaryTest methodsFor: 'tests - fixture'! test0FixtureCloneTest self shouldnt: [ self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self empty ] raise: Error. self assert: self empty isEmpty. ! ! !DictionaryTest methodsFor: 'tests - fixture'! test0FixtureConverAsSortedTest self shouldnt: [self collectionWithSortableElements ] raise: Error. self deny: self collectionWithSortableElements isEmpty .! ! !DictionaryTest methodsFor: 'tests - fixture'! test0FixtureDictionaryAddingTest self shouldnt: [ self nonEmptyDict ]raise: Error. self deny: self nonEmptyDict isEmpty. self shouldnt: [ self associationWithKeyNotInToAdd ]raise: Error. self deny: (self nonEmptyDict keys includes: self associationWithKeyNotInToAdd key ). self shouldnt: [ self associationWithKeyAlreadyInToAdd ]raise: Error. self assert: (self nonEmptyDict keys includes: self associationWithKeyAlreadyInToAdd key ). ! ! !DictionaryTest methodsFor: 'tests - fixture'! test0FixtureDictionaryAssocitionAccess self shouldnt: [self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [self keyNotIn ] raise: Error. self deny: ( self nonEmpty keys includes: self keyNotIn ).! ! !DictionaryTest methodsFor: 'tests - fixture'! test0FixtureDictionaryCopyingTest | duplicateKey | self shouldnt: [ self nonEmptyDict ] raise: Error. self deny: self nonEmptyDict isEmpty. self shouldnt: [ self nonEmptyDifferentFromNonEmptyDict ] raise: Error. 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'! test0FixtureDictionaryElementAccess | in | self shouldnt: [ self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self keyNotIn ] raise: Error. in := true. self nonEmpty keys detect: [ :key | key = self keyNotIn ] ifNone: [ in := false]. self assert: in = false.! ! !DictionaryTest methodsFor: 'tests - fixture'! test0FixtureDictionaryEnumeratingTest self shouldnt: [ self nonEmptyDict ] raise: Error. self deny: self nonEmptyDict isEmpty.! ! !DictionaryTest methodsFor: 'tests - fixture'! test0FixtureDictionaryIncludes | in | self shouldnt: [ self nonEmpty ]raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self valueNotInNonEmpty ] raise: Error. in := false. self nonEmpty valuesDo: [ :assoc | assoc = self valueNotInNonEmpty ifTrue: [ in := true ] ]. self assert: in = false. self shouldnt: [ self keyNotInNonEmpty ] raise: Error. in := false. self nonEmpty keysDo: [ :assoc | assoc = self keyNotInNonEmpty ifTrue: [ in := true ] ]. self assert: in = false! ! !DictionaryTest methodsFor: 'tests - fixture'! test0FixtureDictionaryIncludesIdentity | | self shouldnt: [ self nonEmptyWithCopyNonIdentical ]raise: Error. self deny: self nonEmptyWithCopyNonIdentical isEmpty. self nonEmptyWithCopyNonIdentical do: [ :each | self deny: each == each copy ]. ! ! !DictionaryTest methodsFor: 'tests - fixture'! test0FixtureDictionaryKeyAccess | collection equals | self shouldnt: [ self nonEmptyWithoutEqualsValues ] raise: Error. 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 shouldnt: [ self valueNotIn ] raise: Error. self deny: (self nonEmptyWithoutEqualsValues values includes: self valueNotIn )! ! !DictionaryTest methodsFor: 'tests - fixture'! test0FixtureDictionaryKeysValuesAssociationsAccess self shouldnt: [self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty .! ! !DictionaryTest methodsFor: 'tests - fixture'! test0FixtureDictionaryRemovingTest self shouldnt: [self nonEmptyDict ] raise: Error. self deny: self nonEmptyDict isEmpty. self shouldnt: [self keyNotInNonEmptyDict ] raise: Error. self deny: (self nonEmptyDict keys includes: self keyNotInNonEmptyDict ).! ! !DictionaryTest methodsFor: 'tests - fixture'! test0FixtureIncludeTest | anElementIn | self shouldnt: [ self nonEmpty ]raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self elementNotIn ]raise: Error. anElementIn := true. self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self shouldnt: [ self anotherElementNotIn ]raise: Error. anElementIn := true. self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self shouldnt: [ self empty ] raise: Error. self assert: self empty isEmpty. ! ! !DictionaryTest methodsFor: 'tests - fixture'! test0FixtureOccurrencesForMultiplinessTest | cpt anElement collection | self shouldnt: [ self collectionWithEqualElements ] raise: Error. self shouldnt: [ self collectionWithEqualElements ] raise: Error. self shouldnt: [ self elementTwiceInForOccurrences ] raise: Error. 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 - fixture'! test0FixtureOccurrencesTest | tmp | self shouldnt: [self empty ]raise: Error. self assert: self empty isEmpty. self shouldnt: [ self collectionWithoutEqualElements ] raise: Error. self deny: self collectionWithoutEqualElements isEmpty. tmp := OrderedCollection new. self collectionWithoutEqualElements do: [ :each | self deny: (tmp includes: each). tmp add: each. ]. self shouldnt: [ self elementNotInForOccurrences ] raise: Error. self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! ! !DictionaryTest methodsFor: 'tests - fixture'! test0FixturePrintTest self shouldnt: [self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty.! ! !DictionaryTest methodsFor: 'tests - fixture'! test0FixturePutTest self shouldnt: self aValue raise: Error. self shouldnt: self anotherValue raise: Error. self shouldnt: self anIndex raise: Error. self nonEmpty isDictionary ifFalse:[self assert: (self anIndex >=1 & self anIndex <= self nonEmpty size).]. self shouldnt: self empty raise: Error. self assert: self empty isEmpty . self shouldnt: self nonEmpty raise: Error. self deny: self nonEmpty isEmpty.! ! !DictionaryTest methodsFor: 'tests - fixture'! test0FixtureSetAritmeticTest self shouldnt: [ self collection ] raise: Error. self deny: self collection isEmpty. self shouldnt: [ self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self anotherElementOrAssociationNotIn ] raise: Error. self collection isDictionary ifTrue: [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ] ifFalse: [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ]. self shouldnt: [ self collectionClass ] raise: Error! ! !DictionaryTest methodsFor: 'tests - fixture'! test0FixtureTConvertTest "a collection of number without equal elements:" | res | self shouldnt: [ self collectionWithoutEqualElements ]raise: Error. res := true. self collectionWithoutEqualElements detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false. ! ! !DictionaryTest methodsFor: 'tests - fixture'! test0TStructuralEqualityTest self shouldnt: [self empty] raise: Error. self shouldnt: [self nonEmpty] raise: Error. self assert: self empty isEmpty. self deny: self nonEmpty isEmpty.! ! !DictionaryTest methodsFor: 'tests - includes'! 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 - includes'! testIncludesAllNoneThere "self debug: #testIncludesAllOfNoneThere'" self deny: (self empty includesAll: self nonEmpty ). self deny: (self nonEmpty includesAll: { self elementNotIn. self anotherElementNotIn })! ! !DictionaryTest methodsFor: 'tests - includes'! 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 - includes'! testIncludesAnyNoneThere "self debug: #testIncludesAnyOfNoneThere'" self deny: (self nonEmpty includesAny: self empty). self deny: (self nonEmpty includesAny: { self elementNotIn. self anotherElementNotIn })! ! !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 - includes'! testIncludesElementIsThere "self debug: #testIncludesElementIsThere" self assert: (self nonEmpty includes: self nonEmpty anyOne).! ! !DictionaryTest methodsFor: 'tests - occurrencesOf'! testOccurrencesOfEmpty | result | result := self empty occurrencesOf: (self collectionWithoutEqualElements anyOne). self assert: result = 0! ! !DictionaryTest methodsFor: 'tests - occurrencesOf'! testOccurrencesOfNotIn | result | result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences. self assert: result = 0! ! !DictionaryTest methodsFor: 'tests - occurrencesOf for multipliness'! testOccurrencesOfForMultipliness | collection elem | collection := self collectionWithEqualElements . elem := self elementTwiceInForOccurrences . self assert: (collection occurrencesOf: elem ) = 2. ! ! !DictionaryTest methodsFor: 'tests - printing'! 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 - printing'! 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 - printing'! 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'! 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 - printing'! 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 - printing'! 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) ]" ! ! !DictionaryTest methodsFor: 'tests - set arithmetic'! 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 - set arithmetic'! numberOfSimilarElementsInIntersection ^ self collection occurrencesOf: self anotherElementOrAssociationIn! ! !DictionaryTest methodsFor: 'tests - set arithmetic'! 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: 'tests - set arithmetic'! 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 - set arithmetic'! 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 = 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 = separateCol! ! !DictionaryTest methodsFor: 'tests - set arithmetic'! 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: 'tests - set arithmetic'! 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: 'tests - set arithmetic'! 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: 'tests - set arithmetic'! 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: 'tests - set arithmetic'! 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 - set arithmetic'! testUnionOfEmpties "self debug: #testUnionOfEmpties" self assert: (self empty union: self empty) isEmpty. ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DictionaryTest class uses: TIncludesTest classTrait + TDictionaryAddingTest classTrait + TDictionaryComparingTest classTrait + TDictionaryCopyingTest classTrait + TDictionaryEnumeratingTest classTrait + TDictionaryPrintingTest classTrait + TDictionaryRemovingTest classTrait + TPutBasicTest classTrait + TAsStringCommaAndDelimiterTest classTrait + TPrintTest classTrait + TConvertTest classTrait + TConvertAsSortedTest classTrait + TCopyTest classTrait + TSetArithmetic classTrait + TDictionaryValueAccessTest classTrait + TDictionaryKeysValuesAssociationsAccess classTrait + TDictionaryKeyAccessTest classTrait + TDictionaryAssociationAccessTest classTrait + TDictionaryIncludesWithIdentityCheckTest classTrait + TStructuralEqualityTest classTrait + TOccurrencesForMultiplinessTest classTrait instanceVariableNames: 'testToto pt1'! NewValueHolder subclass: #DictionaryValueHolder instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Spec-Core'! !DictionaryValueHolder commentStamp: '' prior: 0! A DictionaryValueHolder is a value holder designed for dictionaries! !DictionaryValueHolder methodsFor: 'initialization'! initialize "Initialization code for DictionaryValueHolder" super initialize. self contents: Dictionary new.! ! !DictionaryValueHolder methodsFor: 'override'! at: anObject ^ contents at: anObject! ! !DictionaryValueHolder methodsFor: 'override'! size ^ contents size! ! !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: 'protocol' stamp: 'BenjaminVanRyseghem 1/26/2013 01:47'! at: key put: value contents at: key put: value. self contentsChanged: value. ^ value! ! !DictionaryValueHolder methodsFor: 'protocol'! atNewIndex: index put: anObject contents atNewIndex: index put: anObject. self contentsChanged: anObject.! ! !DictionaryValueHolder methodsFor: 'protocol'! doesNotUnderstand: aMessage ^ (contents respondsTo: aMessage selector) ifTrue: [ contents perform: aMessage selector withEnoughArguments: aMessage arguments ] ifFalse: [ super doesNotUnderstand: aMessage ]! ! !DictionaryValueHolder methodsFor: 'protocol'! 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) ]! ! !DictionaryValueHolder methodsFor: 'protocol'! initialize: n contents initialize: n. self contentsChanged.! ! !DictionaryValueHolder methodsFor: 'protocol'! removeAll contents removeAll. self contentsChanged.! ! !DictionaryValueHolder methodsFor: 'protocol'! 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: 'protocol'! removeKey: key ifAbsent: aBlock | result | result := contents removeKey: key ifAbsent: aBlock. self contentsChanged. ^ result! ! !DictionaryValueHolder methodsFor: 'protocol'! valueAtNewKey: aKey put: anObject atIndex: index declareFrom: aDictionary contents valueAtNewKey: aKey put: anObject atIndex: index declareFrom: aDictionary. self contentsChanged.! ! ComposableMorph subclass: #DiffChangeMorph instanceVariableNames: 'diffMorph descriptionMorph' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Tools-Diff'! !DiffChangeMorph methodsFor: 'accessing' stamp: 'gvc 2/9/2010 13:12'! defaultTitle "Answer the default title label for the receiver." ^'Change Diff' translated! ! !DiffChangeMorph methodsFor: 'accessing' stamp: 'gvc 2/9/2010 13:07'! descriptionMorph "Answer the value of descriptionMorph" ^ descriptionMorph! ! !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'! diffMorph "Answer the value of diffMorph" ^ diffMorph! ! !DiffChangeMorph methodsFor: 'accessing' stamp: 'gvc 2/9/2010 13:07'! diffMorph: anObject "Set the value of diffMorph" diffMorph := anObject! ! !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: '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: '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:12'! fromDescriptionMorph "Answer the morph for the source description." ^self descriptionMorph firstSubmorph firstSubmorph! ! !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: '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'! 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: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: 'as yet unclassified' stamp: 'gvc 3/5/2010 12:43'! initialExtent "Answer the initial extent for the receiver." ^RealEstateAgent standardWindowExtent! ! !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: 'initialize-release' 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: 'initialize-release' 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 class instanceVariableNames: ''! !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! ! DiffMethodReferenceConverter subclass: #DiffChangeRecordConverter instanceVariableNames: 'list' classVariableNames: '' poolDictionaries: '' category: 'Spec-Tools-VersionBrowser'! !DiffChangeRecordConverter commentStamp: '' prior: 0! 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 ]! ! Object subclass: #DiffElement instanceVariableNames: 'string hash match' classVariableNames: '' poolDictionaries: '' category: 'System-FilePackage'! !DiffElement commentStamp: 'HenrikSperreJohansen 5/21/2010 01:41' prior: 0! 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: 'accessing' stamp: 'HenrikSperreJohansen 5/21/2010 01:51'! match ^match! ! !DiffElement methodsFor: 'accessing' stamp: 'HenrikSperreJohansen 5/21/2010 01:51'! match: aDiffMatch match := aDiffMatch ! ! !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'! string ^string! ! !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: 'comparing' stamp: 'HenrikSperreJohansen 5/21/2010 01:50'! = anObject ^anObject class == self class and: [ anObject hash = hash and: [ anObject string = string ] ]! ! !DiffElement methodsFor: 'comparing' stamp: 'HenrikSperreJohansen 5/21/2010 01:50'! hash ^hash! ! !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: 'testing' stamp: 'HenrikSperreJohansen 5/21/2010 01:51'! hasMatch ^match notNil! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DiffElement class instanceVariableNames: ''! !DiffElement class methodsFor: 'instance creation' stamp: 'HenrikSperreJohansen 5/21/2010 01:49'! string: aString ^self new string: aString; yourself! ! ProportionalSplitterMorph subclass: #DiffJoinMorph instanceVariableNames: 'srcOffset dstOffset mappings' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Tools-Diff'! !DiffJoinMorph methodsFor: 'accessing' stamp: 'gvc 10/24/2006 16:02'! dstOffset "Answer the value of dstOffset" ^ dstOffset! ! !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: '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: 'accessing' stamp: 'gvc 10/31/2006 11:33'! srcOffset: anInteger "Set the srcOffset." srcOffset := anInteger. self mappings do: [:j | j srcOffset: anInteger]! ! !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 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: '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: 'event handling' stamp: 'gvc 11/1/2006 12:00'! mouseDown: evt "Check for a click." |cj| cj := self mappings detect: [:j | j containsPoint: evt position - self topLeft] ifNone: []. cj ifNotNil: [ cj clicked. self triggerEvent: #joinClicked]. super mouseDown: evt! ! !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: 'initialize' stamp: 'gvc 10/20/2006 14:21'! defaultColor "Answer the default color for the receiver." ^Color transparent! ! !DiffJoinMorph methodsFor: 'initialize' 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 class instanceVariableNames: ''! !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! ! BorderedMorph subclass: #DiffMapMorph instanceVariableNames: 'mappings' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Tools-Diff'! !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! ! !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: '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: 'accessing' stamp: 'gvc 10/26/2006 14:08'! initialize "Initialize the receiver." super initialize. self mappings: #()! ! !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 2/10/2010 13:30'! handlesMouseDown: anEvent "Answer true to report mouse down activity." ^true! ! !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: '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]]! ! AbstractMethodReferenceConverter subclass: #DiffMethodReferenceConverter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'RecentSubmissions-MessageWrappers'! !DiffMethodReferenceConverter methodsFor: 'private'! internalGetText ^TextDiffBuilder buildDisplayPatchFrom: ((self priorVersionOfAMethod: method) sourceCode) to: (method sourceCode) inClass: (method className)! ! ComposableMorph subclass: #DiffMorph instanceVariableNames: 'srcText dstText prettyPrint contextClass srcMorph dstMorph scrollbarMorph mapMorph joinMorph difference joinMappings' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Tools-Diff'! !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: '*Shout-Styling' stamp: 'AlainPlantec 8/28/2011 13:44'! shoutAboutToStyle: aPluggableShoutMorphOrView aPluggableShoutMorphOrView classOrMetaClass: self contextClass. ^ self contextClass notNil ! ! !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: 'accessing' stamp: 'gvc 9/2/2008 15:38'! contextClass "Answer the value of contextClass" ^ contextClass! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2008 15:38'! contextClass: anObject "Set the value of contextClass" contextClass := anObject! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/20/2006 11:27'! difference "Answer the value of difference" ^ difference! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/20/2006 11:27'! difference: anObject "Set the value of difference" difference := anObject! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/20/2006 10:46'! dstMorph "Answer the value of dstMorph" ^ dstMorph! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/20/2006 10:46'! dstMorph: anObject "Set the value of dstMorph" dstMorph := anObject! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2008 15:21'! dstText "Answer the value of dstText" ^ dstText! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2008 15:21'! dstText: anObject "Set the value of dstText" dstText := anObject! ! !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: 'accessing' stamp: 'gvc 7/30/2009 13:42'! joinMappings: aCollection "Set the join parameters between src and dst." joinMappings := aCollection! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/20/2006 10:46'! joinMorph "Answer the value of joinMorph" ^ joinMorph! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/20/2006 10:46'! joinMorph: anObject "Set the value of joinMorph" joinMorph := anObject! ! !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'! mapMorph: anObject "Set the value of mapMorph" mapMorph := anObject! ! !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:22'! prettyPrint: aBoolean "Set the value of prettyPrint" prettyPrint == aBoolean ifTrue: [^self]. prettyPrint := aBoolean. self updateText ! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/23/2006 15:47'! scrollbarMorph "Answer the value of scrollbarMorph" ^ scrollbarMorph! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/23/2006 15:47'! scrollbarMorph: anObject "Set the value of scrollbarMorph" scrollbarMorph := anObject! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/20/2006 10:46'! srcMorph "Answer the value of srcMorph" ^ srcMorph! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 10/20/2006 10:46'! srcMorph: anObject "Set the value of srcMorph" srcMorph := anObject! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2008 15:21'! srcText "Answer the value of srcText" ^ srcText! ! !DiffMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2008 15:21'! srcText: anObject "Set the value of srcText" srcText := anObject! ! !DiffMorph methodsFor: 'as yet unclassified' 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 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: '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: '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: '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: '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: 'as yet unclassified' 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: '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 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: 'as yet unclassified' stamp: 'gvc 11/1/2006 11:04'! defaultTitle "Answer the default title label for the receiver." ^'Diff' translated! ! !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:35'! edgeColor "Answer the color used to show the border of the changes." ^Color gray alpha: 0.5! ! !DiffMorph methodsFor: 'as yet unclassified' 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 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: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'gvc 10/23/2006 16:12'! hideOrShowScrollBar "Do nothing" ! ! !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: 'as yet unclassified' stamp: 'gvc 10/24/2006 12:08'! joinColor "Answer the color used for the join bar." ^Color paleBlue duller! ! !DiffMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:12'! joinSectionClass "Answer the class to use for a new join section." ^JoinSection! ! !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/26/2006 14:29'! matchColor "Answer the color used to show matches." ^Color transparent! ! !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: 'as yet unclassified' stamp: 'gvc 10/26/2006 13:52'! newDstMorph "Answer a new dst text morph." ^self newSrcMorph! ! !DiffMorph methodsFor: 'as yet unclassified' 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: '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: 'as yet unclassified' 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 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: 'as yet unclassified' 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: 'as yet unclassified' 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 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: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'gvc 10/20/2006 11:26'! newText "Answer the new (dst) text." ^self dstMorph text! ! !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: 'gvc 10/24/2006 12:34'! removalColor "Answer the color used to show removals." ^Color paleRed alpha: 0.5! ! !DiffMorph methodsFor: 'as yet unclassified' stamp: 'alain.plantec 5/18/2009 15:54'! 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 prettyPrinterClass format: src in: ctx notifying: nil]. dst isEmpty ifFalse: [ dst := ctx prettyPrinterClass format: dst in: ctx notifying: nil]]. self srcMorph setText: src; font: self theme textFont. self dstMorph setText: dst; font: self theme textFont! ! !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: 'AlainPlantec 12/21/2009 23:12'! textSelectionColor "Answer the color used for thew text selection." ^self theme settings selectionColor alpha: 0.5! ! !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 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: '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: 'geometry' stamp: 'gvc 10/23/2006 16:27'! extent: newExtent "Update the scrollbar." super extent: newExtent. self calibrateScrollbar! ! !DiffMorph methodsFor: 'initialization' stamp: 'gvc 10/26/2006 14:10'! defaultColor "Answer the default color for the receiver." ^Color white! ! !DiffMorph methodsFor: 'initialization' stamp: 'IgorStasenko 12/19/2012 17:33'! initialize "Initialize the receiver." |exv exh opts ppCheckbox| super initialize. self prettyPrint: CodeHolder diffsWithPrettyPrint. ppCheckbox := self newPrettyPrintCheckboxMorph. opts := self newPanel addMorph: ((self newRow: {ppCheckbox}) listCentering: #bottomRight). opts vResizing: #shrinkWrap. opts extent: opts minExtent. self srcMorph: self newSrcMorph; joinMorph: self newJoinMorph; dstMorph: self newDstMorph; scrollbarMorph: self newScrollbarMorph; mapMorph: self newMapMorph; changeProportionalLayout; addMorph: self srcMorph fullFrame: ((0@0 corner: 0.5@1) asLayoutFrame bottomRightOffset: self joinMorph width negated@opts height negated); addMorph: self joinMorph fullFrame: ((0.5@0 corner: 0.5@1) asLayoutFrame leftOffset: self joinMorph width negated; bottomOffset: opts height negated); addMorph: self dstMorph fullFrame: ((0.5@0 corner: 1@1) asLayoutFrame rightOffset: self scrollbarMorph width negated - self mapMorph width; bottomOffset: opts height negated); addMorph: self scrollbarMorph fullFrame: ( (1@0 corner: 1@1) asLayoutFrame leftOffset: self scrollbarMorph width negated - self mapMorph width; bottomRightOffset: self mapMorph width negated@opts height negated); addMorph: self mapMorph fullFrame: ((1@0 corner: 1@1) asLayoutFrame leftOffset: self mapMorph width negated; bottomOffset: opts height negated); addMorph: opts fullFrame: ( (0@1 corner: 1@1) asLayoutFrame topOffset: opts height). 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: 'user interface' stamp: 'gvc 3/5/2010 12:43'! initialExtent "Answer the initial extent for the receiver." ^RealEstateAgent standardWindowExtent! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DiffMorph class instanceVariableNames: ''! !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! ! !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! ! Object subclass: #DifferatorSystemSettings instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Settings-Tools'! !DifferatorSystemSettings commentStamp: 'HenrikSperreJohansen 5/21/2010 02:43' prior: 0! 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 instanceVariableNames: ''! !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." ] ! ! Object subclass: #DigitalSignatureAlgorithm instanceVariableNames: 'randKey randSeed' classVariableNames: 'HighBitOfByte SmallPrimes' poolDictionaries: '' category: 'System-Hashing-DSA'! !DigitalSignatureAlgorithm commentStamp: '' prior: 0! 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: '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: '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: 'initialization' stamp: 'nice 4/1/2011 21:19'! 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 isNil ifTrue: [s := '']. ^self initRandomFromString: s! ! !DigitalSignatureAlgorithm methodsFor: 'initialization' stamp: 'simon.denier 6/11/2010 17:35'! initRandomNonInteractively [self initRandom: (SoundService default randomBitsFromSoundInput: 512)] ifError: [self initRandomFromString: Time millisecondClockValue printString, Date today printString, OSPlatform platformName printString].! ! !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: 'large integer arithmetic' stamp: 'nice 8/28/2010 21:21'! 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 factor 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]. factor := SmallPrimes detect: [:f | (p \\ f) = 0] ifNone: [nil]. factor ifNotNil: [^ 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: '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: '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: '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 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: '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: 'private' stamp: 'jm 12/13/1999 16:36'! 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 := SecureHashAlgorithm 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: 'private' stamp: 'raa 5/30/2000 15:46'! generateSandQ "Generate a 160-bit random seed s and an industrial grade prime q." | hasher s sPlusOne u q | hasher := SecureHashAlgorithm 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: 'jm 12/13/1999 14:39'! 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 := SecureHashAlgorithm new hashInteger: randKey seed: randSeed. randKey := randKey + result + 1]. ^ result ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DigitalSignatureAlgorithm class instanceVariableNames: ''! !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: 'jb 7/1/2011 10:51'! 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 evaluatorClass 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: '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: '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: '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: '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: '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: 'md 3/26/2011 19:16'! 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 := SecureHashAlgorithm 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: 'public' stamp: 'stephane.ducasse 5/25/2008 15:23'! 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 := SecureHashAlgorithm 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: 'public' stamp: 'md 3/26/2011 19:16'! 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 := SecureHashAlgorithm new. h := aStringOrStream class isBytes ifTrue: [ hasher hashMessage: aStringOrStream ] ifFalse: [ hasher hashStream: aStringOrStream ]. sig := dsa stringToSignature: signatureString. ^ dsa verifySignature: sig ofMessageHash: h publicKey: publicKey! ! !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: '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 ! ! FileSystemError subclass: #DirectoryDoesNotExist instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Core-Kernel'! !DirectoryDoesNotExist commentStamp: 'cwp 11/18/2009 12:33' prior: 0! I am raised when I an operation is attempted inside a directory that does not exist. ! TestCase subclass: #DirectoryEntryTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Tests-Core'! !DirectoryEntryTest methodsFor: 'accessing' stamp: 'EstebanLorenzano 4/12/2012 14:26'! entry ^ FileLocator image resolve entry! ! !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: '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'! testIsFile self assert: self entry isFile. self deny: self entry isDirectory! ! !DirectoryEntryTest methodsFor: 'tests' stamp: 'cwp 11/15/2009 22:10'! testIsNotDirectory 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: '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:05'! testSize self assert: self entry size isInteger! ! FileSystemError subclass: #DirectoryExists instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Core-Kernel'! !DirectoryExists commentStamp: 'cwp 11/18/2009 12:35' prior: 0! I am raised on an attempt to create a directory that already exists.! FileSystemTest subclass: #DiskFileSystemTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Tests-Disk'! !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)! ! !DiskFileSystemTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/3/2012 11:42'! testEqual | other | other := self createFileSystem. self assert: filesystem = other! ! !DiskFileSystemTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/12/2012 14:26'! testIsDirectory self assert: (filesystem isDirectory: FileLocator imageDirectory resolve path)! ! FileSystemStore subclass: #DiskStore instanceVariableNames: 'maxFileNameLength' classVariableNames: 'CurrentFS Primitives' poolDictionaries: '' category: 'FileSystem-Disk'! !DiskStore commentStamp: '' prior: 0! 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: 'accessing' stamp: 'cwp 2/27/2011 10:03'! defaultWorkingDirectory | pathString | pathString := Primitives decode: Primitives imageFile. ^ (self pathFromString: pathString) parent! ! !DiskStore methodsFor: 'accessing' stamp: 'EstebanLorenzano 4/2/2012 11:46'! handleClass ^ FileHandle! ! !DiskStore methodsFor: 'as yet unclassified' 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: 'comparing' stamp: 'cwp 2/27/2011 09:50'! = other ^ self species = other species! ! !DiskStore methodsFor: 'comparing' stamp: 'cwp 2/27/2011 09:51'! hash ^ self species hash! ! !DiskStore methodsFor: 'initialize-release' stamp: 'CamilloBruni 5/13/2012 19:18'! initialize super initialize. maxFileNameLength := Smalltalk vm maxFilenameLength ifNil: [ 255 ].! ! !DiskStore methodsFor: 'printing' stamp: 'SeanDeNigris 2/9/2013 09:12'! forReferencePrintOn: aStream aStream nextPutAll: 'File @ '! ! !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: '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: '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: '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: 'cwp 2/27/2011 10:03'! delete: path | pathString encodedPathString | 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: '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: '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: 'public' stamp: 'CamilloBruni 5/9/2012 00:56'! isReadable: aPath (self exists: aPath) ifFalse: [ ^ false ]. self flag: 'TODO: we need a decent primitive for this...'. (self basicOpen: aPath writable: false) ifNotNilDo: [ :id| Primitives close: id. ^ true]. ^ false! ! !DiskStore methodsFor: 'public' stamp: 'CamilloBruni 5/9/2012 01:01'! isWritable: aPath (self exists: aPath) ifFalse: [ ^ false ]. self flag: 'TODO: we need a decent primitive for this...'. (self basicOpen: aPath writable: true) ifNotNilDo: [ :id| Primitives close: id. ^ true]. ^ false! ! !DiskStore methodsFor: 'public' stamp: 'CamilloBruni 5/13/2012 19:17'! maxFileNameLength ^ maxFileNameLength! ! !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: '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: 'private' stamp: 'cwp 2/18/2011 13:27'! basenameFromEntry: entry ^ entry at: 1! ! !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: 'private' stamp: 'cwp 2/18/2011 11:32'! basicIsDirectory: anEntry ^ anEntry at: 4! ! !DiskStore methodsFor: 'private' stamp: 'cwp 2/18/2011 11:33'! basicIsFile: anEntry ^ (anEntry at: 4) not! ! !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: '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 methodsFor: 'private' stamp: 'EstebanLorenzano 8/2/2012 15:38'! basicPosixPermissions: anEntry ^ (anEntry size >= 6) ifTrue: [ anEntry at: 6 ] ifFalse: [ nil ].! ! !DiskStore methodsFor: 'private' stamp: 'CamilloBruni 7/10/2012 21:13'! basicSize: anEntry ^ (anEntry at: 5)! ! !DiskStore methodsFor: 'private' stamp: 'cwp 2/27/2011 10:03'! directoryAt: aPath ifAbsent: absentBlock 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: [ ^ absentBlock value ]. [ entry isNil ] whileFalse: [ entry at: 1 put: (Primitives decode: entry first). aBlock value: entry. index := index + 1. entry := Primitives lookupEntryIn: encodedPathString index: index ]. ^ self! ! !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: 'private' stamp: 'cwp 2/18/2011 11:37'! rootNode ^ #('' 0 0 true 0)! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DiskStore class instanceVariableNames: ''! !DiskStore class methodsFor: 'class initialization' stamp: 'CamilloBruni 7/18/2012 13:55'! 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.' ]. [(VirtualMachine interpreterSourceDate > '2012-07-08+2:00' asDate) ifFalse: displayError ] on: Error do: [ :e| displayError value ].! ! !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: 'class initialization' stamp: 'EstebanLorenzano 6/21/2012 12:52'! shutDown: quitting "Force to detect filesystem after image restart" self reset! ! !DiskStore class methodsFor: 'class initialization' stamp: 'CamilloBruni 7/18/2012 12:22'! startUp: resuming self checkVMVersion. resuming ifTrue: [ self reset ]! ! !DiskStore class methodsFor: 'class initialization' stamp: 'EstebanLorenzano 4/2/2012 11:46'! useFilePlugin Primitives := FilePluginPrims new! ! !DiskStore class methodsFor: 'current' stamp: 'CamilloBruni 5/10/2012 15:41'! activeClass self allSubclassesDo: [:ea | ea isActiveClass ifTrue: [^ ea]]. ^ self! ! !DiskStore class methodsFor: 'current' stamp: 'cwp 2/27/2011 10:02'! createDefault ^ self new! ! !DiskStore class methodsFor: 'current' stamp: 'EstebanLorenzano 4/3/2012 11:30'! current ^ self currentFileSystem store! ! !DiskStore class methodsFor: 'current' stamp: 'CamilloBruni 5/13/2012 19:17'! currentFileSystem ^ CurrentFS ifNil: [ CurrentFS := FileSystem store: self activeClass createDefault]! ! !DiskStore class methodsFor: 'current' stamp: 'EstebanLorenzano 4/3/2012 13:11'! currentFilesystem self deprecated: 'Use #currentFileSystem' on: '3 April 2012' in: 'Pharo 1.4'. ^ self currentFileSystem! ! !DiskStore class methodsFor: 'current' stamp: 'cwp 2/18/2011 17:20'! isActiveClass ^ self delimiter = Primitives delimiter! ! !DiskStore class methodsFor: 'current' stamp: 'cwp 4/4/2011 19:04'! reset CurrentFS := nil! ! !DiskStore class methodsFor: 'public' stamp: 'Cami 7/9/2012 11:12'! delimiter ^ self current delimiter! ! !DiskStore class methodsFor: 'public' stamp: 'CamilloBruni 5/10/2012 16:03'! maxFileNameLength self subclassResponsibility ! ! DisplayObject subclass: #DisplayMedium instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Display Objects'! !DisplayMedium commentStamp: '' prior: 0! 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: 'bordering'! 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: 'bordering'! 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: 'bordering'! 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! ! !DisplayMedium methodsFor: 'bordering'! 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'! 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'! 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'! fillBlack "Set all bits in the receiver to black (ones)." self fill: self boundingBox fillColor: Color black! ! !DisplayMedium methodsFor: 'coloring'! 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: 'coloring'! 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'! fillGray "Set all bits in the receiver to gray." self fill: self boundingBox fillColor: Color gray! ! !DisplayMedium methodsFor: 'coloring'! 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: 'coloring'! 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: 'ar 5/28/2000 12:06'! fillShape: aShapeForm fillColor: aColor at: location "Fill a region corresponding to 1 bits in aShapeForm with aColor" ((BitBlt current 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'! fillWhite "Set all bits in the form to white." self fill: self boundingBox fillColor: Color white. ! ! !DisplayMedium methodsFor: 'coloring'! 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: 'coloring'! fillWithColor: aColor "Fill the receiver's bounding box with the given color." self fill: self boundingBox fillColor: aColor. ! ! !DisplayMedium methodsFor: 'coloring' stamp: 'jm 6/18/1999 19:01'! reverse "Change all the bits in the receiver that are white to black, and the ones that are black to white." self fill: self boundingBox rule: Form reverse fillColor: (Color quickHighLight: self depth)! ! !DisplayMedium methodsFor: 'coloring' stamp: 'jm 6/18/1999 19:00'! 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: (Color quickHighLight: self depth)! ! !DisplayMedium methodsFor: 'coloring'! 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: 'displaying'! 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: 'displaying' stamp: 'hmm 9/16/2000 21:27'! deferUpdatesIn: aRectangle while: aBlock "DisplayScreen overrides with something more involved..." ^aBlock value! ! !DisplayMedium methodsFor: 'displaying'! 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! ! Object subclass: #DisplayObject instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Display Objects'! !DisplayObject commentStamp: '' prior: 0! The abstract protocol for most display primitives that are used by Views for presenting information on the screen.! !DisplayObject methodsFor: 'accessing'! extent "Answer the point that represents the width and height of the receiver's bounding box." ^self boundingBox extent! ! !DisplayObject methodsFor: 'accessing'! height "Answer the number that represents the height of the receiver's bounding box." ^self boundingBox height! ! !DisplayObject methodsFor: 'accessing'! offset "Answer the amount by which the receiver should be offset when it is displayed or its position is tested." self subclassResponsibility! ! !DisplayObject methodsFor: 'accessing'! offset: aPoint "Set the amount by which the receiver's position is offset." ^self! ! !DisplayObject methodsFor: 'accessing'! 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: 'accessing'! width "Answer the number that represents the width of the receiver's bounding box." ^self boundingBox width! ! !DisplayObject methodsFor: 'display box access'! boundingBox "Answer the rectangular area that represents the boundaries of the receiver's space of information." ^self computeBoundingBox! ! !DisplayObject methodsFor: 'display box access'! center ^ self boundingBox center! ! !DisplayObject methodsFor: 'display box access'! 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: 'display box access'! initialExtent "Included here for when a FormView is being opened as a window. (4@4) covers border widths." ^ self extent + (4@4) ! ! !DisplayObject methodsFor: 'displaying-display'! display "Display the receiver on the Display at location 0,0." self displayOn: Display! ! !DisplayObject methodsFor: 'displaying-display' stamp: 'CamilloBruni 8/1/2012 16:06'! 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 | bitsBehind := Form fromDisplay: ((loc := locationBlock value) extent: self extent). ^ self follow: locationBlock while: durationBlock bitsBehind: bitsBehind startingLoc: loc! ! !DisplayObject methodsFor: 'displaying-display' stamp: 'ar 5/28/2000 12:06'! 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 current toForm: save1. buffer := Form extent: self extent*2 depth: Display depth. "Holds overlapping region" bufferBlt := BitBlt current 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 ! ! !DisplayObject methodsFor: 'displaying-display' stamp: 'di 9/12/97 11:09'! isTransparent ^ false! ! !DisplayObject methodsFor: 'displaying-display' stamp: 'jm 10/22/97 07:43'! 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) truncated] while: [ (Delay forMilliseconds: milliSecs) wait. (i := i + 1) < nSteps] ! ! !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: 'displaying-generic'! 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: 'displaying-generic'! 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: 'displaying-generic'! 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: 'displaying-generic'! 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: 'displaying-generic'! 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-generic'! 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: 'displaying-generic' stamp: 'jm 10/21/97 16:56'! displayOnPort: port at: location rule: rule port copyForm: self to: location rule: rule. ! ! !DisplayObject methodsFor: 'transforming'! align: alignmentPoint with: relativePoint "Translate the receiver's offset such that alignmentPoint aligns with relativePoint." self offset: (self offset translateBy: relativePoint - alignmentPoint)! ! !DisplayObject methodsFor: 'transforming'! scaleBy: aPoint "Scale the receiver's offset by aPoint." self offset: (self offset scaleBy: aPoint)! ! !DisplayObject methodsFor: 'transforming'! translateBy: aPoint "Translate the receiver's offset." self offset: (self offset translateBy: aPoint)! ! !DisplayObject methodsFor: 'truncation and round off'! rounded "Convert the offset of the receiver to integer coordinates." self offset: self offset rounded! ! Form subclass: #DisplayScreen instanceVariableNames: 'clippingBox extraRegions' classVariableNames: 'DeferringUpdates DisplayChangeSignature LastScreenModeSelected ScreenSave' poolDictionaries: '' category: 'Graphics-Display Objects'! !DisplayScreen commentStamp: '' prior: 0! 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: 'deferring' stamp: 'GuillermoPolito 5/1/2012 14:31'! deferUpdates: aBoolean ^self class deferUpdates: aBoolean! ! !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: '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: 'displaying' stamp: 'IgorStasenko 12/22/2012 03:27'! copyBits: rect from: sf at: destOrigin clippingBox: clipRect rule: cr fillColor: hf (BitBlt current 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: 'displaying' stamp: 'IgorStasenko 12/22/2012 03:27'! copyBits: rect from: sf at: destOrigin clippingBox: clipRect rule: cr fillColor: hf map: map ((BitBlt current 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: '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: '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: '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: '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: 'initialization' stamp: 'ar 5/26/2000 00:07'! release "I am no longer Display. Release any resources if necessary"! ! !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'! boundingBox clippingBox == nil ifTrue: [clippingBox := super boundingBox]. ^ clippingBox! ! !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: 'other' stamp: 'RAA 11/27/1999 15:48'! displayChangeSignature ^DisplayChangeSignature! ! !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: 'other' stamp: 'ar 2/11/1999 18:14'! forceToScreen "Force the entire display area to the screen" ^self forceToScreen: self 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: 'other'! fullBoundingBox ^ super boundingBox! ! !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: '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'! height ^ self boundingBox height! ! !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: '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: 'other'! 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: 'other' stamp: 'pavel.krivanek 11/20/2007 09:28'! restore UIManager default restoreDisplay! ! !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: '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: '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 methodsFor: 'other' stamp: 'CamilloBruni 8/1/2012 16:18'! usableArea "Answer the usable area of the receiver." ^ self boundingBox deepCopy! ! !DisplayScreen methodsFor: 'other'! width ^ self boundingBox width! ! !DisplayScreen methodsFor: 'screen managing' stamp: 'PavelKrivanek 11/17/2012 23:14'! fullscreen: aBoolean Display fullscreenMode: (LastScreenModeSelected := aBoolean). DisplayScreen checkForNewScreenSize. ! ! !DisplayScreen methodsFor: 'screen managing' stamp: 'SeanDeNigris 11/28/2011 21:53'! fullscreenOff self fullscreen: false! ! !DisplayScreen methodsFor: 'screen managing' stamp: 'SeanDeNigris 11/28/2011 21:53'! fullscreenOn self fullscreen: true! ! !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: 'screen managing' stamp: 'SeanDeNigris 11/28/2011 21:53'! toggleFullscreen self fullscreen: self isFullscreen not! ! !DisplayScreen methodsFor: 'testing' stamp: 'ar 5/25/2000 23:34'! isDisplayScreen ^true! ! !DisplayScreen methodsFor: 'private'! 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: '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: '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: '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: 'private' stamp: 'pavel.krivanek 11/20/2007 09:28'! newDepthNoRestore: pixelSize UIManager default newDisplayDepthNoRestore: pixelSize! ! !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: '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: '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 class instanceVariableNames: ''! !DisplayScreen class methodsFor: 'class initialization' stamp: 'GuillermoPolito 5/1/2012 14:34'! initialize self deferUpdates: false.! ! !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: '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: 'display box access'! boundingBox "Answer the bounding box for the form representing the current display screen." ^Display boundingBox! ! !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: '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: 'host window access'! hostWindowIndex ^ 1! ! !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: 'host window access' stamp: 'EstebanLorenzano 1/10/2012 11:36'! hostWindowTitle: aString self primitiveWindowTitle: self hostWindowIndex string: (UTF8TextConverter default convertFromSystemString: aString)! ! !DisplayScreen class methodsFor: 'host window access' stamp: 'bf 8/22/2009 01:26'! primitiveWindowSize: id width: width heigth: height "ignore failure"! ! !DisplayScreen class methodsFor: 'host window access' stamp: 'bf 4/29/2009 21:50'! primitiveWindowTitle: id string: titleString "ignore failure"! ! !DisplayScreen class methodsFor: 'snapshots' stamp: 'CamilloBruni 5/24/2012 11:07'! actualScreenDepth ^ Display depth! ! !DisplayScreen class methodsFor: 'snapshots'! actualScreenSize ^ 640@480! ! !DisplayScreen class methodsFor: 'snapshots' stamp: 'ar 5/28/2000 11:26'! shutDown "Minimize Display memory saved in image" Display shutDown.! ! !DisplayScreen class methodsFor: 'snapshots' stamp: 'ar 5/17/2001 15:50'! startUp "DisplayScreen startUp" Display setExtent: self actualScreenSize depth: Display nativeDepth. Display beDisplay! ! Object subclass: #DisplaySettings instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Settings-Display'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DisplaySettings class instanceVariableNames: ''! !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] ! ! !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. ! ! Object subclass: #DisplayTransform instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Transformations'! !DisplayTransform commentStamp: '' prior: 0! 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: '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: '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: '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: 'converting' stamp: 'ar 11/2/1998 20:01'! asMatrixTransform2x3 "Represent the receiver as a 2x3 matrix transformation" ^self subclassResponsibility! ! !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: '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 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: 'testing' stamp: 'ar 11/2/1998 22:48'! isMatrixTransform2x3 "Return true if the receiver is 2x3 matrix transformation" ^false! ! !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: 'transforming points' stamp: 'ar 11/2/1998 16:17'! globalPointToLocal: aPoint "Transform aPoint from global coordinates into local coordinates" ^self subclassResponsibility! ! !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: 'transforming points' stamp: 'ar 11/2/1998 16:18'! localPointToGlobal: aPoint "Transform aPoint from local coordinates into global coordinates" ^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: '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 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: 'transforming rects' stamp: 'di 10/25/1999 12:49'! sourceQuadFor: aRectangle ^ aRectangle innerCorners collect: [:p | self globalPointToLocal: p]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DisplayTransform class instanceVariableNames: ''! !DisplayTransform class methodsFor: 'instance creation' stamp: 'ar 11/2/1998 20:55'! identity ^self new setIdentity! ! CodeDeclaration subclass: #DoItDeclaration instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CodeImport'! !DoItDeclaration commentStamp: '' prior: 0! 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: 'GuillermoPolito 5/5/2012 17:14'! import self flag: #fixme. "Ugly hack to parse preamble and postcript as a do it." ((contents beginsWith: '"Change Set:') and: [ChangeSet current preambleString == nil]) ifTrue: [ChangeSet current preambleString: contents]. ((contents beginsWith: '"Postscript:') and: [ChangeSet current postscriptString == nil]) ifTrue: [ChangeSet current postscriptString: contents]. ^Compiler evaluate: contents logged: false.! ! AlignmentMorph subclass: #DockingBarMorph instanceVariableNames: 'originalColor gradientRamp fillsOwner avoidVisibleBordersAtEdge autoGradient selectedItem activeSubMenu' classVariableNames: '' poolDictionaries: '' category: 'Morphic-DockingBar'! !DockingBarMorph commentStamp: 'LaurentLaffont 3/4/2011 22:42' prior: 0! 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: '*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: '*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: '*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: '*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! ! !DockingBarMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/26/2007 15:27'! originalColor "Answer the original color." ^originalColor! ! !DockingBarMorph methodsFor: '*Polymorph-Widgets' 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: '*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 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: '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'! adhereToRight "Instract the receiver to adhere to right" self adhereTo: #right! ! !DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 12:01'! adhereToTop "Instract the receiver to adhere to top" self adhereTo: #top! ! !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 14:28'! autoGradient: aBoolean "Instruct the receiver to fill the owner or not" autoGradient := aBoolean. self updateColor! ! !DockingBarMorph methodsFor: 'accessing' stamp: 'dgd 8/31/2004 13:38'! avoidVisibleBordersAtEdge "Answer if the receiver is in avoidVisibleBordersAtEdge mode" ^ avoidVisibleBordersAtEdge! ! !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: 'accessing' stamp: 'dgd 8/31/2004 12:02'! beFloating "Instract the receiver to be floating" self adhereTo: #none! ! !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: 'accessing' stamp: 'dgd 8/31/2004 13:35'! fillsOwner "Answer if the receiver is in fillOwner mode" ^ fillsOwner! ! !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 11:57'! isAdheringToBottom "Answer true if the receiver is adhering to bottom" ^ self edgeToAdhereTo == #bottom! ! !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: 'accessing' stamp: 'dgd 8/31/2004 11:57'! isAdheringToRight "Answer true if the receiver is adhering to right" ^ self edgeToAdhereTo == #right! ! !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: '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: '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: '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 9/9/2004 19:45'! rootMenu ^ self! ! !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: '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: '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: '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: '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: '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: '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: '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: 'control' stamp: 'dgd 9/1/2004 16:48'! deleteIfPopUp: evt evt ifNotNil: [evt hand releaseMouseFocus: self]! ! !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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: 'menu' stamp: 'dgd 9/29/2004 20:27'! toggleAutoGradient self autoGradient: self autoGradient not! ! !DockingBarMorph methodsFor: 'menu' stamp: 'dgd 9/29/2004 20:26'! toggleAvoidVisibleBordersAtEdge self avoidVisibleBordersAtEdge: self avoidVisibleBordersAtEdge not! ! !DockingBarMorph methodsFor: 'menu' stamp: 'dgd 9/29/2004 20:24'! toggleFillsOwner self fillsOwner: self fillsOwner not! ! !DockingBarMorph methodsFor: 'menus' stamp: 'dgd 9/1/2004 15:29'! snapToEdgeIfAppropriate (self owner isNil or: [self owner isHandMorph]) ifTrue: [^ self]. "" self updateBounds! ! !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: '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: 'submorphs-add/remove' stamp: 'dgd 9/1/2004 19:26'! delete activeSubMenu ifNotNil: [activeSubMenu delete]. ^ super delete! ! !DockingBarMorph methodsFor: 'testing' stamp: 'dgd 8/31/2004 15:00'! isDockingBar "Return true if the receiver is a docking bar" ^ true! ! !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: 'private' stamp: 'dgd 9/9/2004 21:24'! selectedItem selectedItem isNil ifTrue: [^ nil]. ^ selectedItem isSelected ifTrue: [ selectedItem] ifFalse: [ nil]! ! !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: 'dgd 8/31/2004 13:56'! edgeToAdhereTo "private - answer the edge where the receiver is adhering to" ^ self valueOfProperty: #edgeToAdhereTo ifAbsent: [#none]! ! !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 - accessing' stamp: 'dgd 9/1/2004 19:39'! usedHeightByPredominantDockingBarsOfChastes: predominantChastes "Private - convenience" | predominants | predominants := self predominantDockingBarsOfChastes: predominantChastes. ^ predominants isEmpty ifTrue: [0] ifFalse: [(predominants collect: [:each | each height]) sum]! ! !DockingBarMorph methodsFor: 'private - accessing' stamp: 'dgd 9/1/2004 19:38'! usedWidthByPredominantDockingBarsOfChastes: predominantChastes "Private - convenience" | predominants | predominants := self predominantDockingBarsOfChastes: predominantChastes. ^ predominants isEmpty ifTrue: [0] ifFalse: [(predominants collect: [:each | each width]) sum]! ! !DockingBarMorph methodsFor: 'private - layout' stamp: 'dgd 11/2/2004 11:59'! gradientRamp ^ gradientRamp ifNil:[{0.0 -> originalColor muchLighter. 1.0 -> originalColor twiceDarker}]! ! !DockingBarMorph methodsFor: 'private - layout' stamp: 'MarcusDenker 12/11/2009 23:58'! gradientRamp: colorRamp gradientRamp := colorRamp. 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: '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: 'private - layout' stamp: 'dgd 9/1/2004 15:20'! updateExtent "private - update the receiver's extent" | margin | 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 | usedHeight := self usedHeightByPredominantDockingBarsOfChastes: #(#top #bottom ). self height: self owner height + margin - usedHeight]! ! !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]]. ! ! ArithmeticError subclass: #DomainError instanceVariableNames: 'from to' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Exceptions'! !DomainError commentStamp: 'HenrikSperreJohansen 1/19/2012 13:53' prior: 0! 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'! from ^ from! ! !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 ^ to! ! !DomainError methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 4/15/2011 16:33'! to: end to := end! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DomainError class instanceVariableNames: ''! !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: '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: 'nice 7/15/2011 13:56'! signal: signallerText to: end ^ self signal: signallerText from: Float infinity negated to: end! ! !DomainError class methodsFor: 'signaling' stamp: 'SvenVanCaekenberghe 4/15/2011 16:35'! signalFrom: start ^ self signalFrom: 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! ! Object subclass: #DosTimestamp instanceVariableNames: 'value' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Chronology'! !DosTimestamp commentStamp: '' prior: 0! 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: '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: 'comparing' stamp: 'SeanDeNigris 5/21/2012 16:54'! hash ^ self value hash.! ! !DosTimestamp methodsFor: 'converting' stamp: 'SeanDeNigris 5/21/2012 16:42'! asDateAndTime ^ DateAndTime date: self date time: self time.! ! !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: 'private' stamp: 'SeanDeNigris 5/21/2012 17:16'! epoch ^ self class epoch.! ! !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 methodsFor: 'private' stamp: 'SeanDeNigris 5/21/2012 16:43'! low16Bits ^ value & 2r1111111111111111.! ! !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 class instanceVariableNames: ''! !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: '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'! epoch ^ DateAndTime dosEpoch.! ! !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.! ! TestCase subclass: #DosTimestampTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Chronology'! !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.! ! !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.! ! MorphicEvent subclass: #DropEvent instanceVariableNames: 'position contents wasHandled' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Events'! !DropEvent commentStamp: 'LaurentLaffont 3/15/2011 20:47' prior: 0! 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: 'accessing' stamp: 'ar 9/13/2000 18:33'! contents ^contents! ! !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'! position ^position! ! !DropEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 18:33'! type ^#dropEvent! ! !DropEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 18:44'! wasHandled ^wasHandled! ! !DropEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 18:44'! wasHandled: aBool wasHandled := aBool.! ! !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: '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.! ! !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: '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: 'testing' stamp: 'ar 9/13/2000 18:33'! isDropEvent ^true! ! !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: '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: 'private' stamp: 'ar 9/13/2000 19:23'! setPosition: pos contents: aMorph hand: aHand position := pos. contents := aMorph. source := aHand. wasHandled := false.! ! DropEvent subclass: #DropFilesEvent instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Events'! !DropFilesEvent methodsFor: 'accessing' stamp: 'ar 1/10/2001 21:35'! type ^#dropFilesEvent! ! !DropFilesEvent methodsFor: 'dispatching' stamp: 'ar 1/10/2001 21:35'! sentTo: anObject "Dispatch the receiver into anObject" self type == #dropFilesEvent ifTrue:[^anObject handleDropFiles: self].! ! ComposableModel subclass: #DropListExample instanceVariableNames: 'dropList container morph1 morph2 morph3' classVariableNames: '' poolDictionaries: '' category: 'Spec-Examples-Widgets'! !DropListExample commentStamp: '' prior: 0! A DropListExample is a simple example of how to use drop lists. DropListExample new openWithSpec! !DropListExample methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/2/2012 15:20'! container ^ container! ! !DropListExample methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/2/2012 15:36'! dropList ^ dropList! ! !DropListExample methodsFor: 'actions' stamp: 'BenjaminVanRyseghem 2/2/2012 15:38'! blueMorphBlock ^ [ container removeAllMorphs. container addMorph: morph2 ]! ! !DropListExample methodsFor: 'actions' stamp: 'BenjaminVanRyseghem 2/2/2012 15:38'! greenMorphBlock ^ [ container removeAllMorphs. container addMorph: morph3 ]! ! !DropListExample methodsFor: 'actions' stamp: 'BenjaminVanRyseghem 2/2/2012 15:38'! redMorphBlock ^ [ container removeAllMorphs. container addMorph: morph1 ]! ! !DropListExample methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/12/2012 19:25'! initialize "Initialization code for RadioButtonGroupExample" container := PanelMorph new. self instantiateMorphs. container changeTableLayout; listDirection: #bottomToLeft. super initialize.! ! !DropListExample methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/12/2012 19:25'! initializeWidgets | item1 item2 item3 | self instantiateModels: #(dropList #DropListModel). item1 := DropListItem named: 'Red morph' do: self redMorphBlock. item2 := DropListItem named: 'Blue morph' do: self blueMorphBlock. item3 := DropListItem named: 'Green morph' do: self greenMorphBlock. dropList items: {item1. item2. item3}. self setFocus.! ! !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 2/2/2012 15:26'! setFocus self focusOrder add: dropList; add: container. ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DropListExample class instanceVariableNames: ''! !DropListExample class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/15/2013 13:30'! defaultSpec ^ { #ComposableSpec. #add:. { self topSpec . #layout: . #(FrameLayout bottomFraction: 0 bottomOffset: 30) }. #add:. {{#model . #container } . #layout: . #(FrameLayout topOffset: 42). }}! ! !DropListExample class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 2/5/2012 17:17'! title ^ 'Drop list'! ! !DropListExample class methodsFor: 'specs' stamp: 'bvr 6/4/2012 17:19'! topSpec ^ { #Panel. #changeTableLayout. #listDirection:. #rightToLeft. #addMorph:. {#model. #dropList.}. #hResizing:. #spaceFill. #vResizing:. #shrinkWrap. }! ! Object subclass: #DropListItem instanceVariableNames: 'actionHolder label' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Utilities'! !DropListItem commentStamp: '' prior: 0! A DropListItem is an item (wrapper) designed to fit into a DropList! !DropListItem methodsFor: 'accessing'! = another self species = another species ifFalse: [ ^ false ]. ^ self label = another label and: [ self actionHolder = another actionHolder ]! ! !DropListItem methodsFor: 'accessing'! actionHolder ^ actionHolder! ! !DropListItem methodsFor: 'accessing'! label ^ label! ! !DropListItem methodsFor: 'accessing'! label: anObject label := anObject! ! !DropListItem methodsFor: 'execution' stamp: 'BenjaminVanRyseghem 7/11/2012 17:11'! value "This way, I am polymorphic with nil" actionHolder contents cull: self label cull: self! ! !DropListItem methodsFor: 'initialization'! initialize "Initialization code for DropListItem" super initialize. actionHolder := [] asValueHolder. label := ''.! ! !DropListItem methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/11/2012 17:11'! action: aBlock actionHolder contents: aBlock! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DropListItem class instanceVariableNames: ''! !DropListItem class methodsFor: 'instance creation'! named: label do: aBlock ^ self new action: aBlock; label: label; yourself! ! AbstractBasicWidget subclass: #DropListModel instanceVariableNames: 'listHolder selectionHolder' classVariableNames: '' poolDictionaries: '' category: 'Spec-Widgets'! !DropListModel commentStamp: '' prior: 0! 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: 'focus' stamp: 'BenjaminVanRyseghem 2/8/2013 13:20'! eventKeyStrokeForNextFocus "String describing the keystroke to perform to jump to the next widget" ^ Character arrowRight asShortcut! ! !DropListModel methodsFor: 'focus' stamp: 'BenjaminVanRyseghem 2/8/2013 13:21'! eventKeyStrokeForPreviousFocus "String describing the keystroke to perform to jump to the previous widget" ^ Character arrowLeft asShortcut! ! !DropListModel methodsFor: 'initialization' stamp: 'StephaneDucasse 5/17/2012 19:32'! initialize "Initialization code for DropListModel" super initialize. listHolder := {} asValueHolder. selectionHolder := SelectionValueHolder new. listHolder whenChangedDo: [ self changed: #getList. self internalResetSelection. ]. selectionHolder whenChangedDo: [ self changed: #getIndex ]. self whenSelectedItemChanged: [:item | item value ]! ! !DropListModel methodsFor: 'morphic' stamp: 'StephaneDucasse 5/17/2012 18:12'! getIndex ^ selectionHolder index contents! ! !DropListModel methodsFor: 'morphic' stamp: 'StephaneDucasse 5/17/2012 18:02'! getList ^ listHolder contents collect: #label! ! !DropListModel methodsFor: 'morphic' stamp: 'StephaneDucasse 5/17/2012 18:04'! setIndex: anIndex | item | selectionHolder index contents: anIndex. item := (listHolder contents at: anIndex ifAbsent: [ nil ]). item value. selectionHolder selection contents: item. self changed: #getIndex! ! !DropListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/12/2012 18:07'! items: aList "Populate the drop list with a list of DropItems" listHolder contents: aList! ! !DropListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/12/2012 18:08'! listItems "Return the list of DropItems used to populate the drop list" ^ listHolder contents! ! !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 7/12/2012 18:08'! resetSelection "Reset the current selection state" selectionHolder reset! ! !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 7/12/2012 18:08'! selectedItem "Return the selected item" ^ self selectedItemHolder contents! ! !DropListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/20/2012 16:21'! setSelectedIndex: anIndex "Force the selection of the item at index anIndex" | selection | selection := listHolder contents at: anIndex ifAbsent: [ ^ self ]. selection value. selectionHolder index contents: anIndex. selectionHolder selection contents: selection! ! !DropListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/12/2012 18:10'! setSelectedItem: anItem "Force the selection of the item anItem" | index realItem | index := self getList indexOf: anItem ifAbsent: [ ^ self ]. realItem := (self listItems at: index) value. selectionHolder index contents: index. selectionHolder selection contents: realItem.! ! !DropListModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/12/2012 18:10'! whenSelectedItemChanged: aBlock "Set a block to perform when the selected item is changed" selectionHolder selection whenChangedDo: aBlock! ! !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: '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:05'! internalResetSelection selectionHolder reset. self getList isEmpty not ifTrue: [ self setSelectedIndex: 1 ]! ! !DropListModel methodsFor: 'private' stamp: 'StephaneDucasse 5/17/2012 18:04'! selectedIndexHolder ^ selectionHolder index! ! !DropListModel methodsFor: 'private' stamp: 'StephaneDucasse 5/17/2012 18:04'! selectedItemHolder ^ selectionHolder selection! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DropListModel class instanceVariableNames: ''! !DropListModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 2/8/2013 14:24'! defaultSpec ^ {#DropListSpec. #on:list:selected:changeSelected:. #model. #getList. #getIndex. #setIndex:. #hResizing:. #spaceFill. #vResizing:. #spaceFill. #borderWidth:. #(model borderWidth). #borderColor:. #(model borderColor). #setBalloonText:. { #model . #help}}! ! !DropListModel class methodsFor: 'specs'! title ^ 'Drop List'! ! MorphicModel subclass: #DropListMorph uses: TEnableOnHaloMenu instanceVariableNames: 'contentMorph listMorph buttonMorph list listSelectionIndex getListSelector getIndexSelector setIndexSelector getEnabledSelector enabled useSelectionIndex wrapSelector defaultContents' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !DropListMorph commentStamp: 'gvc 5/23/2007 14:12' prior: 0! Displays a selected item and a drop button. When pressed will popup a list to enable changing of the selection. Supports enablement.! !DropListMorph methodsFor: '*Keymapping-Core' stamp: 'ThierryGoubier 9/15/2012 22:28'! initializeShortcuts: aKMDispatcher super initializeShortcuts: aKMDispatcher. aKMDispatcher attachCategory: #MorphFocusNavigation! ! !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: '*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: '*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: '*Polymorph-Widgets' stamp: 'gvc 1/11/2007 12:30'! takesKeyboardFocus "Answer whether the receiver can normally take keyboard focus." ^true! ! !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 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: '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: '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: 'accessing' stamp: 'gvc 8/22/2006 13:25'! buttonMorph "Answer the value of buttonMorph" ^ buttonMorph! ! !DropListMorph methodsFor: 'accessing' stamp: 'gvc 8/22/2006 13:25'! buttonMorph: anObject "Set the value of buttonMorph" buttonMorph := anObject! ! !DropListMorph methodsFor: 'accessing' stamp: 'gvc 6/17/2006 11:45'! contentMorph "Answer the value of contentMorph" ^ contentMorph! ! !DropListMorph methodsFor: 'accessing' stamp: 'gvc 6/17/2006 11:45'! contentMorph: anObject "Set the value of contentMorph" contentMorph := anObject! ! !DropListMorph methodsFor: 'accessing'! defaultContents: anObject "Set the value of defaultContents" defaultContents := anObject! ! !DropListMorph methodsFor: 'accessing' stamp: 'gvc 8/14/2006 13:18'! enabled "Answer the value of enabled" ^ enabled! ! !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: 'accessing' stamp: 'GaryChambers 4/24/2012 15:04'! font "Answer the content font" ^self contentMorph font! ! !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 8/14/2006 13:16'! getEnabledSelector "Answer the value of getEnabledSelector" ^ getEnabledSelector! ! !DropListMorph methodsFor: 'accessing' stamp: 'gvc 8/14/2006 13:30'! getEnabledSelector: anObject "Set the value of getEnabledSelector" getEnabledSelector := anObject. self updateEnabled! ! !DropListMorph methodsFor: 'accessing' stamp: 'gvc 7/17/2006 12:26'! getIndexSelector "Answer the value of getIndexSelector" ^ getIndexSelector! ! !DropListMorph methodsFor: 'accessing' stamp: 'gvc 7/17/2006 12:26'! getIndexSelector: anObject "Set the value of getIndexSelector" getIndexSelector := anObject! ! !DropListMorph methodsFor: 'accessing' stamp: 'gvc 7/17/2006 12:26'! getListSelector "Answer the value of getListSelector" ^ getListSelector! ! !DropListMorph methodsFor: 'accessing' stamp: 'gvc 7/17/2006 12:26'! getListSelector: anObject "Set the value of getListSelector" getListSelector := anObject! ! !DropListMorph methodsFor: 'accessing' stamp: 'CamilloBruni 8/4/2011 12:27'! list "Answer the list contents." ^list! ! !DropListMorph methodsFor: 'accessing' stamp: 'CamilloBruni 8/4/2011 12:28'! list: aCollection "Set the list contents." list := aCollection. self changed: #list! ! !DropListMorph methodsFor: 'accessing' stamp: 'gvc 6/17/2006 11:07'! listMorph "Answer the value of listMorph" ^ listMorph! ! !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: 'accessing' stamp: 'gvc 6/17/2006 11:28'! listSelectionIndex "Answer the list selection." ^listSelectionIndex! ! !DropListMorph methodsFor: 'accessing' stamp: 'CamilloBruni 8/3/2011 17:30'! 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: 'accessing' stamp: 'gvc 10/12/2006 13:58'! selectionColor "Answer the selection color for the receiver." ^self listMorph selectionColor! ! !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: 'accessing' stamp: 'gvc 7/17/2006 12:26'! setIndexSelector "Answer the value of setIndexSelector" ^ setIndexSelector! ! !DropListMorph methodsFor: 'accessing' stamp: 'gvc 7/17/2006 12:26'! setIndexSelector: anObject "Set the value of setIndexSelector" setIndexSelector := anObject! ! !DropListMorph methodsFor: 'accessing' stamp: 'gvc 8/8/2007 15:53'! useSelectionIndex "Answer the value of useSelectionIndex" ^ useSelectionIndex! ! !DropListMorph methodsFor: 'accessing' stamp: 'gvc 8/8/2007 15:53'! useSelectionIndex: anObject "Set the value of useSelectionIndex" useSelectionIndex := anObject! ! !DropListMorph methodsFor: 'as yet unclassified'! addToggleItemsToHaloMenu: aCustomMenu "Add toggle-items to the halo menu" super addToggleItemsToHaloMenu: aCustomMenu. aCustomMenu addUpdating: #enabledString target: self action: #toggleEnabled! ! !DropListMorph methodsFor: 'as yet unclassified'! enabledString "Answer the string to be shown in a menu to represent the 'enabled' status" ^ (self enabled) -> 'enabled' translated! ! !DropListMorph methodsFor: 'as yet unclassified' stamp: 'GaryChambers 11/17/2011 13:44'! listFont "Answer the list font" ^self listMorph font! ! !DropListMorph methodsFor: 'as yet unclassified' stamp: 'GaryChambers 11/16/2011 13:41'! listFont: aFont "Set the list font" self listMorph font: aFont! ! !DropListMorph methodsFor: 'as yet unclassified'! toggleEnabled "Toggle the enabled state." self enabled: self enabled not! ! !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: '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: '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: '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: '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: 'drawing' stamp: 'BenjaminVanRyseghem 3/14/2012 08:28'! newListMorph "Answer a new list morph" |m| m := (self listMorphClass on: self list: #list selected: #listSelectionIndex changeSelected: #listSelectionIndex: menu: nil keystroke: nil) 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: '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: 'event handling' stamp: 'BenjaminVanRyseghem 3/14/2012 09:02'! keyStroke: event "Pass on to the list." event keyCharacter = Character escape ifTrue: [ self hideList ]. (self navigationKey: event) ifTrue: [^self]. self listMorph keyStroke: event ! ! !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: 'event handling' stamp: 'gvc 8/22/2006 15:44'! listMouseDown: evt "Click outside the list." (self listMorph fullContainsPoint: evt position) ifTrue: [self listMorph selectionIndex: (self listMorph rowAtLocation: evt position)] ifFalse: [self hideList]! ! !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: 'initialization' stamp: 'gvc 6/17/2006 11:17'! defaultColor "Answer the default color of the receiver." ^Color white! ! !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: 'initialize' stamp: 'gvc 7/8/2006 10:13'! outOfWorld: aWorld "Get rid of the list if visible." self hideList. ^super outOfWorld: aWorld! ! !DropListMorph methodsFor: 'protocol' stamp: 'gvc 8/2/2007 12:18'! disable "Disable the receiver." self enabled: false! ! !DropListMorph methodsFor: 'protocol' stamp: 'gvc 8/2/2007 12:18'! enable "Enable the receiver." self enabled: true! ! !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: '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: 'protocol'! 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: 'protocol' stamp: 'GaryChambers 11/25/2010 16:00'! hideList "Hide the list." self listMorph ifNil: [^self]. self listVisible ifFalse: [^self]. self listMorph delete. self listMorph selectionIndex = self listSelectionIndex ifFalse: [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: '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 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: '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: '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: '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: '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: '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: '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: 'testing' stamp: 'gvc 9/6/2006 12:48'! stepTime "Answer the desired time between steps in milliseconds." ^100! ! !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 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: '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: '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: '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: '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: 'wiw support' stamp: 'gvc 6/17/2006 12:27'! morphicLayerNumber "Answer the layer number." ^self listVisible ifTrue: [10] ifFalse: [super morphicLayerNumber]! ! !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: 'wrapping' stamp: 'BenjaminVanRyseghem 3/13/2012 04:17'! wrapSelector ^ wrapSelector! ! !DropListMorph methodsFor: 'wrapping' stamp: 'BenjaminVanRyseghem 4/25/2012 12:56'! wrapSelector: aSymbol wrapSelector := aSymbol. self updateList. self updateContents! ! !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 methodsFor: 'private' stamp: 'gvc 1/23/2009 13:12'! buttonExtent "Answer based on theme and preferences." ^self buttonWidth @ self buttonHeight! ! !DropListMorph methodsFor: 'private' stamp: 'gvc 1/23/2009 13:12'! buttonHeight "Answer based on theme." ^self theme buttonMinHeight! ! !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: 'AlainPlantec 12/17/2009 14:34'! buttonWidth "Answer based on scrollbar size." ^ (self theme scrollbarThickness + 3) max: self theme dropListControlButtonWidth! ! !DropListMorph methodsFor: 'private'! defaultContents ^ defaultContents! ! !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: 'private' stamp: 'GaryChambers 8/18/2010 17:33'! layoutInsetToUse "Answer the layout inset that should be used." ^self theme dropListInsetFor: self! ! !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: 'gvc 6/17/2006 11:42'! listMorphClass "Answer the class for a new list morph" ^PluggableListMorph! ! !DropListMorph methodsFor: 'private' stamp: 'gvc 6/17/2006 12:26'! listVisible "Answer whether the list is visible." ^self listMorph owner notNil! ! !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: 'private'! updateContentMorphWith: aString self contentMorph contents: aString! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DropListMorph class uses: TEnableOnHaloMenu classTrait instanceVariableNames: ''! !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! ! !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! ! AbstractSpec subclass: #DropListSpec instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Spec-Core-Specs'! !DropListSpec commentStamp: '' prior: 0! A DropListSpec is a spec to describe a drop list! !DropListSpec methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/24/2012 03:14'! classSymbol ^ #DropList! ! ComposableModel subclass: #DualChangeSorterApplication instanceVariableNames: 'model changeSorterLeft changeSorterRight isRefreshing' classVariableNames: '' poolDictionaries: '' category: 'Spec-Tools-ChangeSorter'! !DualChangeSorterApplication commentStamp: '' prior: 0! 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'! changeSorterLeft ^ changeSorterLeft! ! !DualChangeSorterApplication methodsFor: 'accessing'! changeSorterRight ^ changeSorterRight! ! !DualChangeSorterApplication methodsFor: 'accessing'! model ^ model! ! !DualChangeSorterApplication methodsFor: 'event' stamp: 'StephaneDucasse 11/2/2012 14:42'! refeshedChangeSet: changeSet isRefreshing ifFalse: [ isRefreshing := true. changeSet updateChangesList. isRefreshing := false ]! ! !DualChangeSorterApplication methodsFor: 'event' stamp: 'StephaneDucasse 11/2/2012 14:40'! title ^ super title, ' on: ', self model currentChangeSet name. ! ! !DualChangeSorterApplication methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 7/31/2012 16:17'! initialExtent ^ 900@530! ! !DualChangeSorterApplication methodsFor: 'initialization' stamp: 'StephaneDucasse 12/18/2012 17:14'! initialize "Initialization code for DualChangeSorterApplication" super initialize. model := ChangeSorterModel new. isRefreshing := false. SystemAnnouncer uniqueInstance weak on: CurrentChangeSetChanged do: [:each | self updateTitle]! ! !DualChangeSorterApplication methodsFor: 'initialization' stamp: 'StephaneDucasse 11/2/2012 14:02'! initializePresenter changeSorterLeft whenChangesListChanges: [ self refeshedChangeSet: changeSorterRight ]. changeSorterRight whenChangesListChanges: [ self refeshedChangeSet: changeSorterLeft ]. ! ! !DualChangeSorterApplication methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/12/2012 18:22'! initializeWidgets "Initialization code for DualChangeSorterApplication" self instantiateModels: #( changeSorterLeft ChangeSorterApplication changeSorterRight ChangeSorterApplication ). self menusRegistration. self shortcutsRegistration. self setFocusOrder! ! !DualChangeSorterApplication methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/13/2012 12:30'! menusRegistration self menusRegistrationFrom: changeSorterLeft to: changeSorterRight. self menusRegistrationFrom: changeSorterRight to: changeSorterLeft! ! !DualChangeSorterApplication methodsFor: 'initialization'! setFocusOrder self focusOrder add: changeSorterLeft; add: changeSorterRight.! ! !DualChangeSorterApplication methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/13/2012 12:05'! shortcutsRegistration self shortcutsRegistrationFrom: changeSorterLeft to: changeSorterRight. self shortcutsRegistrationFrom: changeSorterRight to: changeSorterLeft.! ! !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: 'menu' stamp: 'EstebanLorenzano 1/31/2013 19:24'! changesMenu: menu shifted: shifted from: src to: dest | menuSrc1 menuSrc2 menuDest | menuSrc1 := menu copy. src changeSetMenu1: menuSrc1 shifted: shifted. menuSrc2 := menu copy. src changeSetMenu1: menuSrc2 shifted: shifted. menuDest := (PragmaMenuBuilder pragmaKeyword: 'dualChangeSorteChangesListMenu' model: {self. src. dest}) menu. menu addAllFrom: (MenuMorph new addAllMorphs: menuSrc1 submorphs; addAllMorphs: menuDest submorphs; addAllMorphs: menuSrc2 submorphs; yourself). ^menu! ! !DualChangeSorterApplication methodsFor: 'menu' stamp: 'EstebanLorenzano 1/31/2013 19:24'! classMenu: menu shifted: shifted from: src to: dest "Fill aMenu with items appropriate for the class list" | menuSrc menuDual | src selectedClass ifNil: [ ^nil ]. menuSrc := menu copy. src classMenu: menuSrc shifted: shifted. menuDual := (PragmaMenuBuilder pragmaKeyword: 'dualChangeSorterClassListMenu' model: {self. src. dest}) menu. menu addAllFrom: (MenuMorph new addAllMorphs: menuDual submorphs; addAllMorphs: menuSrc submorphs; yourself). ^menu ! ! !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' stamp: 'EstebanLorenzano 1/31/2013 19:24'! messageMenu: menu shifted: shifted from: src to: dest "Fill aMenu with items appropriate for the message list; could be for a single or double changeSorter" | menuSrc menuDual | src selectedSelector ifNil: [ ^ nil ]. menu target: self. menuSrc := menu copy. src messageMenu: menuSrc shifted: shifted. menuDual := (PragmaMenuBuilder pragmaKeyword: 'dualChangeSorterMessageListMenu' model: {self. src. dest}) menu. menu addAllFrom: (MenuMorph new addAllMorphs: menuDual submorphs; addAllMorphs: menuSrc submorphs; yourself). ^menu ! ! !DualChangeSorterApplication methodsFor: 'menu - change set'! 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: '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: 'menu - change set' stamp: 'BenjaminVanRyseghem 6/13/2012 12:01'! 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 substractFrom: source to: destination. changeSorterRight setSelectedChangeSet: source.! ! !DualChangeSorterApplication methodsFor: 'menu - class' stamp: 'BenjaminVanRyseghem 6/13/2012 12:13'! copyClassFrom: src to: dest "Place these changes in the other changeSet also" | otherChangeSet | self checkThatSidesDiffer: [ ^ self ]. self okToChange ifFalse: [ ^ Beeper beep ]. src selectedClass ifNil: [ ^ Beeper beep ]. otherChangeSet := dest selectedChangeSet. self model copyClass: src selectedClass from: src selectedChangeSet to: otherChangeSet. dest setSelectedChangeSet: otherChangeSet.! ! !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: '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 - method' stamp: 'BenjaminVanRyseghem 6/13/2012 12:19'! moveMethodFrom: src to: dest self copyMethodFrom: src to: dest. src forgetMessage. src updateClassesListAndMessagesList.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DualChangeSorterApplication class instanceVariableNames: ''! !DualChangeSorterApplication class methodsFor: 'menu' stamp: 'EstebanLorenzano 1/31/2013 18:33'! 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.! ! !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: 'menu' stamp: 'MarcusDenker 10/13/2012 14:37'! menuCommandOn: aBuilder (aBuilder group: #SystemChanges) parent: #Tools; with: [ (aBuilder item: #'Change Sorter') action:[self new openWithSpec]; icon: self taskbarIcon. (aBuilder item: #'Recover lost changes...') action: [Smalltalk tools changeList browseRecentLog]]! ! !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: 'specs' stamp: 'BenjaminVanRyseghem 7/31/2012 16:16'! defaultSpec ^ SpecLayout composed newRow: [:r | r add: #changeSorterLeft; addSplitter; add: #changeSorterRight ]! ! !DualChangeSorterApplication class methodsFor: 'specs' stamp: 'StephaneDucasse 11/2/2012 13:59'! title ^'Dual Change Sorter'! ! !DualChangeSorterApplication class methodsFor: 'tools-registry' stamp: 'StephaneDucasse 7/4/2012 19:48'! registerToolsOn: registry "Add ourselves to registry. See [Smalltalk tools]" registry register: self as: #dualChangeSorter! ! ComposableModel subclass: #DummyComposableModel instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Spec-Core-Specs'! !DummyComposableModel commentStamp: '' prior: 0! A DummyComposableModel is a stupid ComposableSpec subclass used to uglyly retrieve the bindings The bindings should be a class side inst var of SpecInterpreter! !DummyComposableModel methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/12/2012 18:14'! initializeWidgets "Absorb"! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DummyComposableModel class instanceVariableNames: ''! !DummyComposableModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 6/13/2012 16:35'! defaultSpec ^ SpecLayout composed! ! AbstractEcryptor subclass: #DummyEcryptor instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KeyChain'! !DummyEcryptor commentStamp: '' prior: 0! 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! ! AbstractEcryptorDecryptor subclass: #DummyEcryptorDecryptor instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KeyChain'! !DummyEcryptorDecryptor commentStamp: '' prior: 0! 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! ! AbstractKeyPressedPlugin subclass: #DummyKeyPressedPlugin instanceVariableNames: 'stringMorph counter' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Plugin'! !DummyKeyPressedPlugin commentStamp: '' prior: 0! A DummyKeyPressedPlugin is a dummy plugin which display the counter of keystrokes! !DummyKeyPressedPlugin methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/10/2011 17:55'! initialize super initialize. counter := 0. self stringMorph contents: 'Keys pressed: ', counter printString; openInWorld. ! ! !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: 'accessing' stamp: 'BenjaminVanRyseghem 5/4/2011 14:56'! stringMorph: anObject stringMorph := anObject! ! !DummyKeyPressedPlugin methodsFor: 'announcement' stamp: 'BenjaminVanRyseghem 5/10/2011 17:55'! keyPressed: anAnnouncement | key | key := anAnnouncement key. counter := counter +1. self stringMorph contents: 'Keys pressed: ', counter printString! ! !DummyKeyPressedPlugin methodsFor: 'display' stamp: 'BenjaminVanRyseghem 5/10/2011 16:43'! display ^ stringMorph! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DummyKeyPressedPlugin class instanceVariableNames: ''! !DummyKeyPressedPlugin class methodsFor: 'information' stamp: 'BenjaminVanRyseghem 2/17/2012 16:50'! description ^ 'Display the number of key pressed'! ! !DummyKeyPressedPlugin class methodsFor: 'position' stamp: 'BenjaminVanRyseghem 8/25/2011 10:01'! defaultPosition ^ #bottom! ! AbstractPackageSelectedPlugin subclass: #DummyPackageSelectedPlugin instanceVariableNames: 'morph' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Plugin'! !DummyPackageSelectedPlugin commentStamp: '' prior: 0! 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 instanceVariableNames: ''! !DummyPackageSelectedPlugin class methodsFor: 'position' stamp: 'BenjaminVanRyseghem 8/25/2011 10:01'! defaultPosition ^ #middle! ! AbstractSoundSystem subclass: #DummySoundSystem instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Sound'! !DummySoundSystem commentStamp: 'gk 2/24/2004 23:14' prior: 0! This is a dummy sound system registered in SoundService to absorb all sound playing and to use the primitive beep instead of sampled sounds when playing a beep.! !DummySoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 20:48'! randomBitsFromSoundInput: bitCount "I'm not sure what the right thing to do here is." self error: 'Can not provide random data.'! ! !DummySoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:54'! sampledSoundChoices "No choices other than this." ^ #('silence')! ! !DummySoundSystem methodsFor: 'misc' stamp: 'gk 2/23/2004 19:55'! soundNamed: soundName "There are no sounds to look up." ^ nil! ! !DummySoundSystem methodsFor: 'playing' stamp: 'gk 2/24/2004 23:53'! beep "Make a primitive beep." Beeper beepPrimitive! ! !DummySoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:53'! playSampledSound: samples rate: rate "Do nothing." ! ! !DummySoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:54'! playSoundNamed: soundName "Do nothing."! ! !DummySoundSystem methodsFor: 'playing' stamp: 'gk 2/23/2004 19:54'! playSoundNamed: soundName ifAbsentReadFrom: aifFileName "Do nothing."! ! !DummySoundSystem methodsFor: 'playing' stamp: 'gk 4/8/2005 14:15'! playSoundNamedOrBeep: soundName "There is no sound support, so we make the beep." self beep! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DummySoundSystem class instanceVariableNames: ''! !DummySoundSystem class methodsFor: 'initialization' stamp: 'StephaneDucasse 1/30/2011 21:32'! initialize SoundService register: self.! ! !DummySoundSystem class methodsFor: 'initialization' stamp: 'gk 2/23/2004 21:08'! unload SoundService registeredClasses do: [:ss | (ss isKindOf: self) ifTrue: [SoundService unregister: ss]].! ! Object subclass: #DummySystemProgressItem instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'UIManager-Support'! !DummySystemProgressItem methodsFor: 'as yet unclassified' stamp: 'SeanDeNigris 6/11/2012 11:17'! doesNotUnderstand: aMessage! ! UIManager subclass: #DummyUIManager instanceVariableNames: '' classVariableNames: 'ProgressBarEnabled' poolDictionaries: '' category: 'UIManager'! !DummyUIManager commentStamp: 'LaurentLaffont 2/23/2011 20:16' prior: 0! 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: 'accessing' stamp: 'PavelKrivanek 11/1/2010 20:18'! progressBarEnabled ^ ProgressBarEnabled ifNil: [ ProgressBarEnabled := true ].! ! !DummyUIManager methodsFor: 'accessing' stamp: 'PavelKrivanek 11/1/2010 20:15'! progressBarEnabled: aBoolean ProgressBarEnabled := aBoolean! ! !DummyUIManager methodsFor: 'as yet unclassified' 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'! fileDoesNotExistsDefaultAction: anException ! ! !DummyUIManager methodsFor: 'default actions' stamp: 'pavel.krivanek 5/31/2007 08:20'! fileExistsDefaultAction: anException ! ! !DummyUIManager methodsFor: 'default actions' stamp: 'pavel.krivanek 5/31/2007 08:20'! lowSpaceWatcherDefaultAction Transcript show: '*** LOW SPACE ***'; cr. ! ! !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: 'default actions' stamp: 'pavel.krivanek 5/11/2008 17:44'! warningDefaultAction: anException ^ self unhandledErrorDefaultAction: anException! ! !DummyUIManager methodsFor: 'display' stamp: 'pavel.krivanek 5/31/2007 08:20'! checkForNewDisplaySize Display extent = DisplayScreen actualScreenSize ifTrue: [^ self]. DisplayScreen startUp. ! ! !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: '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.! ! !DummyUIManager methodsFor: 'ui requests' stamp: 'pavel.krivanek 5/31/2007 08:20'! chooseDirectory: label from: dir ^ nil! ! !DummyUIManager methodsFor: 'ui requests' stamp: 'pavel.krivanek 5/31/2007 08:20'! chooseFrom: aList lines: linesArray title: aString ^ aList first! ! !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: 'MarcusDenker 4/29/2011 00:33'! confirm: queryString (ProvideAnswerNotification signal: queryString) ifNotNil: [:answer | ^answer]. self error: 'No user response possible'! ! !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:20'! edit: aText label: labelString accept: anAction ^ nil! ! !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: 'CamilloBruni 9/22/2012 20:17'! inform: aString "Nothing to be done here"! ! !DummyUIManager methodsFor: 'ui requests' stamp: 'SeanDeNigris 6/20/2012 23:32'! informUserDuring: aBlock aBlock value: DummySystemProgressItem new.! ! !DummyUIManager methodsFor: 'ui requests' stamp: 'SeanDeNigris 6/22/2012 09:35'! progressInitiationExceptionDefaultAction: anException | result | result := anException workBlock value: DummySystemProgressItem new. anException resume: result.! ! !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: '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: '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: 'ui requests' stamp: 'pavel.krivanek 5/31/2007 08:20'! requestPassword: queryString ^ self request: queryString initialAnswer: ''! ! Error subclass: #DuplicatedVariableError instanceVariableNames: 'superclass variable' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Exceptions'! !DuplicatedVariableError methodsFor: 'accessing' stamp: 'Janniklaval 10/23/2010 13:06'! superclass "The superclass in which the variable is defined" ^superclass! ! !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:07'! variable: aVariable "Name of the duplicate variable" variable := aVariable! ! !DuplicatedVariableError methodsFor: 'testing' stamp: 'Janniklaval 10/23/2010 13:06'! isResumable ^true! ! Magnitude subclass: #Duration instanceVariableNames: 'nanos seconds' classVariableNames: '' poolDictionaries: 'ChronologyConstants' category: 'Kernel-Chronology'! !Duration commentStamp: 'marcus.denker 6/5/2009 11:27' prior: 0! I represent a duration of time. I have nanosecond precision! !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: '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:22'! days "Answer a number that represents the number of complete days in the receiver" ^ seconds quo: SecondsInDay ! ! !Duration methodsFor: 'accessing' stamp: 'GuillermoPolito 8/24/2010 11:14'! hash ^seconds bitXor: nanos ! ! !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: '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: '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: '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: 'arithmetic' stamp: 'GuillermoPolito 8/24/2010 11:15'! * operand "operand is a Number" ^ self class nanoSeconds: ( (self asNanoSeconds * operand) asInteger) ! ! !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: '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: 'arithmetic' stamp: 'brp 5/13/2003 08:00'! < comparand ^ self asNanoSeconds < comparand asNanoSeconds ! ! !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: 'CamilloBruni 12/13/2011 17:30'! asDays "Answer the number of days in the receiver." ^ self asHours / 24! ! !Duration methodsFor: 'converting' stamp: 'brp 9/25/2003 13:42'! asDelay ^ Delay forDuration: self! ! !Duration methodsFor: 'converting' stamp: 'brp 5/13/2003 08:01'! asDuration ^ self ! ! !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:03'! asMilliSeconds ^ ((seconds * NanosInSecond) + nanos) // (10 raisedToInteger: 6) ! ! !Duration methodsFor: 'converting' stamp: 'CamilloBruni 12/13/2011 17:30'! asMinutes "Answer the number of minutes in the receiver." ^ seconds / 60.0! ! !Duration methodsFor: 'converting' stamp: 'brp 5/13/2003 08:03'! asNanoSeconds ^ (seconds * NanosInSecond) + nanos ! ! !Duration methodsFor: 'converting' stamp: 'GuillermoPolito 8/24/2010 11:14'! asSeconds "Answer the number of seconds in the receiver." ^ seconds ! ! !Duration methodsFor: 'converting' stamp: 'brp 5/13/2003 08:03'! nanoSeconds ^ nanos ! ! !Duration methodsFor: 'initialize-release' stamp: 'alain.plantec 5/28/2009 09:51'! initialize super initialize. self seconds: 0 nanoSeconds: 0. ! ! !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: '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: 'operations' 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 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: 'testing' stamp: 'brp 4/13/2006 10:20'! isZero ^ seconds = 0 and: [ nanos = 0 ] ! ! !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: '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: '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 class instanceVariableNames: ''! !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: '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' stamp: 'gk 8/30/2006 23:18'! days: days seconds: seconds ^ self basicNew seconds: days * SecondsInDay + seconds 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' 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' 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: 'simple instance creation' stamp: 'gk 8/31/2006 01:25'! days: aNumber ^ self seconds: aNumber * SecondsInDay nanoSeconds: 0! ! !Duration class methodsFor: 'simple instance creation' stamp: 'gk 8/31/2006 01:26'! hours: aNumber ^ self seconds: aNumber * SecondsInHour nanoSeconds: 0! ! !Duration class methodsFor: 'simple instance creation' stamp: 'StephaneDucasse 5/5/2010 22:01'! milliSeconds: milliCount ^ self seconds: (milliCount quo: 1000) nanoSeconds: (milliCount rem: 1000) * NanosInMillisecond! ! !Duration class methodsFor: 'simple instance creation' stamp: 'gk 8/31/2006 01:27'! minutes: aNumber ^ self seconds: aNumber * SecondsInMinute nanoSeconds: 0! ! !Duration class methodsFor: 'simple instance creation' stamp: 'brp 1/9/2004 17:20'! month: aMonth "aMonth is an Integer or a String" ^ (Month month: aMonth year: Year current year) duration ! ! !Duration class methodsFor: 'simple instance creation' 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: 'simple instance creation' stamp: 'gk 8/31/2006 01:34'! seconds: seconds ^ self seconds: seconds nanoSeconds: 0 ! ! !Duration class methodsFor: 'simple instance creation' stamp: 'gk 8/30/2006 23:20'! weeks: aNumber ^ self days: (aNumber * 7) seconds: 0 ! ! !Duration class methodsFor: 'simple instance creation' stamp: 'CamilloBruni 9/22/2012 10:49'! years: aNumber ^ self days: (aNumber * 365) seconds: 0 ! ! !Duration class methodsFor: 'simple instance creation' stamp: 'gk 8/31/2006 00:09'! zero ^ self basicNew seconds: 0 nanoSeconds: 0 ! ! ClassTestCase subclass: #DurationTest instanceVariableNames: 'aDuration' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Chronology'! !DurationTest methodsFor: 'coverage' stamp: 'brp 9/25/2003 14:30'! classToBeTested ^ Duration ! ! !DurationTest methodsFor: 'coverage' stamp: 'brp 9/25/2003 14:30'! selectorsToBeIgnored | private | private := #( #printOn: ). ^ super selectorsToBeIgnored, private ! ! !DurationTest methodsFor: 'setup' stamp: 'brp 1/21/2004 18:36'! setUp aDuration := Duration days: 1 hours: 2 minutes: 3 seconds: 4 nanoSeconds: 5 ! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testAbs self assert: aDuration abs = aDuration. self assert: (Duration nanoSeconds: -5) abs = (Duration nanoSeconds: 5). ! ! !DurationTest methodsFor: 'testing' 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: 'testing' 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: 'testing' stamp: 'brp 1/21/2004 18:38'! testAsDelay self deny: aDuration asDelay = aDuration. "want to come up with a more meaningful test" ! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testAsDuration self assert: aDuration asDuration = aDuration ! ! !DurationTest methodsFor: 'testing' 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: 'testing' 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: 'testing' 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: 'testing' 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: 'testing' 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: 'testing' 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: 'testing' 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: 'testing' 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: 'testing' 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: 'testing' 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: 'testing' 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: 'testing' 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: 'testing' 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: 'testing' stamp: 'brp 1/21/2004 18:38'! testDays self assert: aDuration days = 1. self assert: (Duration days: 1) days= 1. ! ! !DurationTest methodsFor: 'testing' 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: 'testing' stamp: 'brp 1/21/2004 18:38'! testFromString self assert: aDuration = (Duration fromString: '1:02:03:04.000000005'). ! ! !DurationTest methodsFor: 'testing' 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: 'testing' stamp: 'brp 1/21/2004 18:38'! testHours self assert: aDuration hours = 2. self assert: (Duration hours: 2) hours = 2. ! ! !DurationTest methodsFor: 'testing' 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: 'testing' stamp: 'brp 1/21/2004 18:38'! testLessThan self assert: aDuration < (aDuration + 1 day ). self deny: aDuration < aDuration. ! ! !DurationTest methodsFor: 'testing' 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: 'testing' 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: 'testing' stamp: 'brp 1/21/2004 18:38'! testMinutes self assert: aDuration minutes = 3. self assert: (Duration minutes: 3) minutes = 3. ! ! !DurationTest methodsFor: 'testing' 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: 'testing' 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: 'testing' stamp: 'brp 1/21/2004 18:38'! testNanoSeconds self assert: aDuration nanoSeconds = 5. self assert: (Duration nanoSeconds: 5) nanoSeconds = 5. ! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testNegated self assert: aDuration + aDuration negated = (Duration seconds: 0). ! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testNegative self deny: aDuration negative. self assert: aDuration negated negative ! ! !DurationTest methodsFor: 'testing' 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: 'testing' 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: 'testing' 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: 'testing' 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: 'testing' stamp: 'damiencassou 5/30/2008 11:09'! testReadFrom self assert: aDuration = (Duration readFrom: '1:02:03:04.000000005' readStream)! ! !DurationTest methodsFor: 'testing' 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: 'testing' stamp: 'StephaneDucasse 4/23/2010 21:55'! testReadFromMillisecond self assert: (Duration readFrom: '0:00:00:00.001 ' readStream) nanoSeconds = 1000000! ! !DurationTest methodsFor: 'testing' 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: 'testing' 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: 'testing' 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: 'testing' 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)'. ! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testTicks self assert: aDuration ticks = #(1 7384 5)! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testWeeks self assert: (Duration weeks: 1) days= 7. ! ! !DurationTest methodsFor: 'testing' stamp: 'brp 1/21/2004 18:38'! testZero self assert: (Duration zero) = (Duration seconds: 0). ! ! !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: '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: '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: '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/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 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: '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: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).! ! DynamicGroup subclass: #DynamicClassGroup instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'GroupManager'! !DynamicClassGroup commentStamp: '' prior: 0! A DynamicClassGroup is a group automatically updated whose default granularity is class.! !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: 'announcements' stamp: 'BenjaminVanRyseghem 4/14/2012 13:31'! methodModified: anAnnouncement "Do not care"! ! !DynamicClassGroup methodsFor: 'announcements' stamp: 'BenjaminVanRyseghem 4/14/2012 13:31'! methodRemoved: anAnnouncement "Do not care"! ! !DynamicClassGroup methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/2/2012 17:31'! addClasses: aCollection self addBlock: [ aCollection ]! ! !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: 'queries' stamp: 'BenjaminVanRyseghem 2/25/2012 16:17'! methods ^ self classes gather: [:e | e methodDict values ]! ! !DynamicClassGroup methodsFor: 'queries' stamp: 'BenjaminVanRyseghem 2/25/2012 15:41'! methodsFor: aClass ^ aClass methodDict values sort: [:a :b | a selector < b selector ]! ! !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: 'queries' stamp: 'BenjaminVanRyseghem 2/25/2012 15:41'! protocolsFor: aClass ^ aClass protocols sort! ! ComposableModel subclass: #DynamicComposableModel instanceVariableNames: 'widgets' classVariableNames: '' poolDictionaries: '' category: 'Spec-Core'! !DynamicComposableModel commentStamp: '' prior: 0! 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: 'error handling' stamp: 'BenjaminVanRyseghem 7/9/2012 16:01'! doesNotUnderstand: aMessage ^ widgets at: aMessage selector ifAbsent: [ super doesNotUnderstand: aMessage ]! ! !DynamicComposableModel methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 7/10/2012 23:21'! initializeWidgets! ! !DynamicComposableModel methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 7/11/2012 03:29'! initialize "Initialization code for DynamicComposableModel" widgets := OrderedIdentityDictionary new asValueHolder. super initialize. ! ! !DynamicComposableModel methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 7/9/2012 16:24'! instantiateModels: aCollectionOfPairs aCollectionOfPairs pairsDo: [ :k :v | widgets at: k asSymbol put: (self createInstanceFor: v) ]! ! !DynamicComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/10/2012 21:51'! needFullRebuild: aBoolean self needRebuild: aBoolean. self widgetsDo: [:e | e needRebuild: aBoolean ]! ! AbstractGroup subclass: #DynamicGroup instanceVariableNames: 'blocks' classVariableNames: '' poolDictionaries: '' category: 'GroupManager'! !DynamicGroup commentStamp: '' prior: 0! A DynamicGroup is a group automatically updated whose default granularity is method.! !DynamicGroup methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/2/2012 16:59'! addBlock: aBlock blocks add: aBlock! ! !DynamicGroup methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/14/2012 13:06'! block: aBlock blocks := OrderedCollection with: aBlock! ! !DynamicGroup methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/28/2011 13:14'! blocks ^ blocks! ! !DynamicGroup methodsFor: 'accessing' stamp: 'DamienPollet 3/6/2012 19:20'! blocks: aCollection blocks := aCollection! ! !DynamicGroup methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/14/2012 12:41'! initialize super initialize. readOnly := false. blocks ifNil: [ blocks := OrderedCollection with: [{}] ]! ! !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: 'accessing' stamp: 'BenjaminVanRyseghem 3/24/2011 13:14'! sortBlock: aBlock sortBlock := aBlock! ! !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: '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: '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: 'protocol' stamp: 'BenjaminVanRyseghem 4/14/2012 12:25'! addAll: aCollection aCollection do: [:e | self addBlock: [{ e }]]! ! !DynamicGroup methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/2/2012 17:35'! addClasses: aCollection aCollection do: [:e | self addBlock: [ e theNonMetaClass methodDict values ]. self addBlock: [ e theMetaClass methodDict values ]]! ! !DynamicGroup methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/9/2011 16:05'! elements ^ (self blocks gather: [:block | block value]) copy asOrderedCollection removeDuplicates! ! !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 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 class instanceVariableNames: ''! !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! ! Object subclass: #DynamicMessageImplementor instanceVariableNames: 'message class argumentNames stream' classVariableNames: '' poolDictionaries: '' category: 'Tools-Debugger'! !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: 'HernanWilkinson 10/13/2010 10:53'! argumentClassNameOf: argument ^ (argument isKindOf: Class) ifTrue: [ argument name, 'Class' ] ifFalse: [ argument class name ]! ! !DynamicMessageImplementor methodsFor: 'evaluating-private' stamp: 'HernanWilkinson 10/12/2010 17:19'! argumentNameAt: anIndex | argumentName argument argumentClassName | argument := message arguments at: anIndex. argumentClassName := self argumentClassNameOf: argument. argumentName := (self argumentNamePrefixOf: argumentClassName), argumentClassName. [ argumentNames includes: argumentName ] whileTrue: [ argumentName := argumentName , anIndex asString ]. argumentNames add: argumentName. ^ argumentName! ! !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: '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:16'! writeArgumentNameAt: anIndex | argumentName | argumentName := self argumentNameAt: anIndex. stream nextPutAll: ' '; nextPutAll: argumentName; space! ! !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'! writeGetterSourceCode stream cr; tab; nextPutAll: '^ '; nextPutAll: message selector ! ! !DynamicMessageImplementor methodsFor: 'evaluating-private' stamp: 'HernanWilkinson 10/12/2010 17:08'! writeGetterSourceCodeIfNecessary self isMessageAGetter ifTrue: [ self writeGetterSourceCode ]! ! !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:08'! writeSetterSourceCode stream cr; tab; nextPutAll: message selector allButLast; nextPutAll: ' := '; nextPutAll: argumentNames anyOne ! ! !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:04'! writeShouldBeImplemented stream cr; tab; nextPutAll: 'self '; nextPutAll: #shouldBeImplemented; nextPut: $.! ! !DynamicMessageImplementor methodsFor: 'evaluating-private' stamp: 'HernanWilkinson 10/12/2010 17:07'! writeSourceCode self writeMethodName. self writeShouldBeImplemented. self writeGetterSourceCodeIfNecessary. self writeSetterSourceCodeIfNecessary! ! !DynamicMessageImplementor methodsFor: 'initialization' stamp: 'HernanWilkinson 10/12/2010 16:32'! initializeFor: aMessage in: aClass message := aMessage. class := aClass! ! !DynamicMessageImplementor methodsFor: 'testing' stamp: 'HernanWilkinson 10/12/2010 17:11'! hasParameter: aKeyword ^ aKeyword last = $: or: [ message selector isInfix ]! ! !DynamicMessageImplementor methodsFor: 'testing' stamp: 'HernanWilkinson 10/12/2010 16:38'! isMessageAGetter ^ message numArgs = 0 and: [ class instVarNames includes: message selector ]! ! !DynamicMessageImplementor methodsFor: 'testing' stamp: 'HernanWilkinson 10/12/2010 16:52'! isMessageASetter ^ message numArgs = 1 and: [ class instVarNames includes: message selector allButLast ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! DynamicMessageImplementor class instanceVariableNames: ''! !DynamicMessageImplementor class methodsFor: 'instance creation' stamp: 'HernanWilkinson 10/12/2010 16:31'! for: aMessage in: aClass ^ self new initializeFor: aMessage in: aClass! ! TestCase subclass: #DynamicMessageImplementorTest instanceVariableNames: 'instVar' classVariableNames: '' poolDictionaries: '' category: 'ToolsTest-Debugger'! !DynamicMessageImplementorTest methodsFor: 'testing' stamp: 'HernanWilkinson 10/12/2010 17:24'! testAnShouldBeUsedAsPrefixWhenArgumentNameStartsWithVowel | messageImplementor sourceCode | messageImplementor := DynamicMessageImplementor for: (Message selector: #m1: argument: #()) in: self class. sourceCode := messageImplementor value. self assert: sourceCode withSeparatorsCompacted = 'm1: anArray self shouldBeImplemented.' withSeparatorsCompacted! ! !DynamicMessageImplementorTest methodsFor: 'testing' stamp: 'HernanWilkinson 10/12/2010 17:20'! testBinaryMessage | messageImplementor sourceCode | messageImplementor := DynamicMessageImplementor for: (Message selector: #+ argument: 1) in: self class. sourceCode := messageImplementor value. self assert: sourceCode withSeparatorsCompacted = '+ aSmallInteger self shouldBeImplemented.' withSeparatorsCompacted! ! !DynamicMessageImplementorTest methodsFor: 'testing' stamp: 'HernanWilkinson 10/12/2010 16:48'! testImplementingAMessageNamedAsVariableShouldGenerateGetter | messageImplementor sourceCode | messageImplementor := DynamicMessageImplementor for: (Message selector: #instVar) in: self class. sourceCode := messageImplementor value. self assert: sourceCode withSeparatorsCompacted = 'instVar self shouldBeImplemented. ^ instVar' withSeparatorsCompacted! ! !DynamicMessageImplementorTest methodsFor: 'testing' stamp: 'HernanWilkinson 10/12/2010 16:54'! testImplementingAMessageNamedAsVariableWithOneParameterShouldGenerateSetter | messageImplementor sourceCode | messageImplementor := DynamicMessageImplementor for: (Message selector: #instVar: argument: 1) in: self class. sourceCode := messageImplementor value. self assert: sourceCode withSeparatorsCompacted = 'instVar: aSmallInteger self shouldBeImplemented. instVar := aSmallInteger' withSeparatorsCompacted! ! !DynamicMessageImplementorTest methodsFor: 'testing' stamp: 'HernanWilkinson 10/12/2010 16:57'! testImplementingKeywordMessageWithOneArgumentNamedDifferentToAllInstanceVariablesShouldNotGenerateSetter | messageImplementor sourceCode | messageImplementor := DynamicMessageImplementor for: (Message selector: #m1: argument: 1) in: self class. sourceCode := messageImplementor value. self assert: sourceCode withSeparatorsCompacted = 'm1: aSmallInteger self shouldBeImplemented.' withSeparatorsCompacted! ! !DynamicMessageImplementorTest methodsFor: 'testing' stamp: 'HernanWilkinson 10/12/2010 16:55'! testImplementingUnaryMessageNamedDifferentToAllInstanceVariablesShouldNotGenerateGetter | messageImplementor sourceCode | messageImplementor := DynamicMessageImplementor for: (Message selector: #m1) in: self class. sourceCode := messageImplementor value. self assert: sourceCode withSeparatorsCompacted = 'm1 self shouldBeImplemented.' withSeparatorsCompacted! ! !DynamicMessageImplementorTest methodsFor: 'testing' stamp: 'HernanWilkinson 10/12/2010 17:23'! testKeywordMessageWithDiferentArgumentClass | messageImplementor sourceCode | messageImplementor := DynamicMessageImplementor for: (Message selector: #m1:m2:m3: arguments: #(1 $a 'string')) in: self class. sourceCode := messageImplementor value. self assert: sourceCode withSeparatorsCompacted = 'm1: aSmallInteger m2: aCharacter m3: aByteString self shouldBeImplemented.' withSeparatorsCompacted! ! !DynamicMessageImplementorTest methodsFor: 'testing' stamp: 'HernanWilkinson 10/12/2010 17:22'! testKeywordMessageWithSameArgumentClassShouldGenerateDifferentArgumentNames | messageImplementor sourceCode | messageImplementor := DynamicMessageImplementor for: (Message selector: #m1:m2:m3: arguments: #(1 2 3)) in: self class. sourceCode := messageImplementor value. self assert: sourceCode withSeparatorsCompacted = 'm1: aSmallInteger m2: aSmallInteger2 m3: aSmallInteger3 self shouldBeImplemented.' withSeparatorsCompacted! ! !DynamicMessageImplementorTest methodsFor: 'testing' stamp: 'HernanWilkinson 10/13/2010 10:54'! testMetaclassNameShouldBeUsedWhenArgumentIsAClass | messageImplementor sourceCode | messageImplementor := DynamicMessageImplementor for: (Message selector: #m1: argument: Array) in: self class. sourceCode := messageImplementor value. self assert: sourceCode withSeparatorsCompacted = 'm1: anArrayClass self shouldBeImplemented.' withSeparatorsCompacted! ! ProcessSpecificVariable subclass: #DynamicVariable instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Processes'! !DynamicVariable commentStamp: 'mvl 3/13/2007 13:55' prior: 0! 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 instanceVariableNames: ''! !DynamicVariable class methodsFor: 'accessing' stamp: 'IgorStasenko 11/2/2011 18:40'! value: anObject during: aBlock ^ self soleInstance value: anObject during: aBlock! ! EUCTextConverter subclass: #EUCJPTextConverter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Multilingual-TextConversion'! !EUCJPTextConverter commentStamp: '' prior: 0! Text converter for Japanese variation of EUC.! !EUCJPTextConverter methodsFor: 'private' stamp: 'yo 3/17/2004 00:41'! languageEnvironment ^ JapaneseEnvironment. ! ! !EUCJPTextConverter methodsFor: 'private' stamp: 'yo 10/23/2002 10:09'! leadingChar ^ JISX0208 leadingChar ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! EUCJPTextConverter class instanceVariableNames: ''! !EUCJPTextConverter class methodsFor: 'utilities' stamp: 'yo 12/19/2003 22:00'! encodingNames ^ #('euc-jp' 'eucjp') copy ! ! EUCTextConverter subclass: #EUCKRTextConverter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Multilingual-TextConversion'! !EUCKRTextConverter commentStamp: '' prior: 0! Text converter for Korean variation of EUC.! !EUCKRTextConverter methodsFor: 'private' stamp: 'yo 3/17/2004 00:41'! languageEnvironment ^ KoreanEnvironment. ! ! !EUCKRTextConverter methodsFor: 'private' stamp: 'yo 10/23/2002 15:19'! leadingChar ^ KSX1001 leadingChar ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! EUCKRTextConverter class instanceVariableNames: ''! !EUCKRTextConverter class methodsFor: 'utilities' stamp: 'yo 2/17/2004 18:45'! encodingNames ^ #('euc-kr' 'ks-c-5601-1987' 'euckr') copy ! ! TextConverter subclass: #EUCTextConverter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Multilingual-TextConversion'! !EUCTextConverter commentStamp: '' prior: 0! Text converter for Extended Unix Character. This is an abstract class. The CJK variations are implemented as subclasses.! !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. ! ! !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: '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: 'private' stamp: 'yo 10/4/2003 15:48'! nonUnicodeClass ^ (EncodedCharSet charsetAt: self leadingChar). ! ! TestCase subclass: #EUCTextConverterTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Multilingual-Tests-TextConversion'! !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.! ! AbstractResizerMorph subclass: #EdgeGripMorph instanceVariableNames: 'target edgeName fitTargetOwner' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !EdgeGripMorph commentStamp: 'gvc 9/23/2008 11:58' prior: 0! Similar to a ProportionalSplitterMorph but designed to attach to an edge of a single morph only.! !EdgeGripMorph methodsFor: 'accessing' stamp: 'gvc 10/1/2007 13:03'! edgeName "Answer the value of edgeName" ^ edgeName! ! !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: 'accessing' stamp: 'GaryChambers 1/25/2011 13:05'! fitTargetOwner ^ fitTargetOwner! ! !EdgeGripMorph methodsFor: 'accessing' stamp: 'GaryChambers 1/25/2011 13:05'! fitTargetOwner: anObject fitTargetOwner := anObject! ! !EdgeGripMorph methodsFor: 'accessing' stamp: 'gvc 2/12/2007 16:43'! target "Answer the value of target" ^ target! ! !EdgeGripMorph methodsFor: 'accessing' stamp: 'gvc 7/30/2009 13:58'! target: aMorph "Set the value of target" target := aMorph! ! !EdgeGripMorph methodsFor: 'actions' stamp: 'gvc 10/1/2007 13:05'! resizeCursor ^ Cursor resizeForEdge: self edgeName! ! !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: '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: 'GaryChambers 1/25/2011 13:10'! defaultHeight "Answer the default height for the receiver." ^ProportionalSplitterMorph splitterWidth! ! !EdgeGripMorph methodsFor: 'as yet unclassified' stamp: 'GaryChambers 1/25/2011 13:10'! defaultWidth "Answer the default width for the receiver." ^ProportionalSplitterMorph splitterWidth! ! !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: '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: '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: '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: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: 'as yet unclassified' stamp: 'gvc 10/1/2007 14:23'! normalFillStyle "Return the normal fillStyle of the receiver." ^self theme splitterNormalFillStyleFor: self! ! !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: 'gvc 10/1/2007 14:23'! pressedFillStyle "Return the pressed fillStyle of the receiver." ^self theme splitterPressedFillStyleFor: self! ! !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: '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: '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 12/3/2007 15:11'! splitsTopAndBottom "Answer true if the receiver has a horizontal layout." ^self isHorizontal! ! !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: '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/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: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: '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: '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: '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: 'initialize' 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! ! DropListMorph subclass: #EditableDropListMorph instanceVariableNames: 'addToListSel content' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !EditableDropListMorph commentStamp: 'LaurentLaffont 3/31/2011 21:04' prior: 0! 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: '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: 'alain.plantec 3/13/2009 15:26'! content ^ content ! ! !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 methodsFor: 'accessing' stamp: 'alain.plantec 4/9/2009 10:11'! converter ^ self contentMorph converter! ! !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: '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: '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: 'layout' stamp: 'FernandoOlivero 4/12/2011 09:45'! minHeight "Answer the minimum height for the drop list." ^self theme textFont height + 7! ! !EditableDropListMorph methodsFor: 'protocol' stamp: 'alain.plantec 4/8/2009 10:41'! ghostText: aText self contentMorph ghostText: aText ! ! !EditableDropListMorph methodsFor: 'protocol' stamp: 'AlainPlantec 12/3/2009 09:10'! wantsFrameAdornments: aBoolean self contentMorph wantsFrameAdornments: aBoolean! ! !EditableDropListMorph methodsFor: 'private' stamp: 'alain.plantec 10/20/2009 12:41'! addToListSel: aSelector addToListSel := aSelector! ! !EditableDropListMorph methodsFor: 'private' stamp: 'alain.plantec 3/13/2009 16:30'! convertTo: aClass self contentMorph convertTo: aClass ! ! !EditableDropListMorph methodsFor: 'private' stamp: 'alain.plantec 4/9/2009 11:03'! default: anObject self contentMorph default: anObject! ! !EditableDropListMorph methodsFor: 'private'! defaultContents "needs nothing to activate the ghostText" ^ ''! ! !EditableDropListMorph methodsFor: 'private' stamp: 'CamilloBruni 8/11/2011 03:54'! layoutInsetToUse "Answer the layout inset that should be used." "^self theme editableDropListInsetFor: self" ^ 0 @ 0 corner: 0 @ 0! ! !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: 'alain.plantec 4/9/2009 10:12'! objectAsString: anObject ^ self converter objectAsString: anObject! ! !EditableDropListMorph methodsFor: 'private'! updateContentMorphWith: aString self contentMorph setText: aString! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! EditableDropListMorph class instanceVariableNames: ''! !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! ! Object subclass: #EditingState instanceVariableNames: 'emphasisHere pointBlock markBlock startOfTyping previousInterval previousSelection undoManager lastParenLocation mouseDownInterval secondarySelectionToken' classVariableNames: '' poolDictionaries: '' category: 'Text-Edition'! !EditingState commentStamp: 'StephaneDucasse 2/6/2011 09:56' prior: 0! 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 11/9/2010 15:04'! emphasisHere ^ emphasisHere! ! !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'! lastParenLocation: anIntegerIndex lastParenLocation := anIntegerIndex! ! !EditingState methodsFor: 'accessing' stamp: 'AlainPlantec 11/9/2010 15:04'! markBlock ^ markBlock! ! !EditingState methodsFor: 'accessing' stamp: 'AlainPlantec 11/9/2010 15:04'! markBlock: aCharacterBlock markBlock := aCharacterBlock! ! !EditingState methodsFor: 'accessing' stamp: 'AlainPlantec 11/9/2010 15:04'! mouseDownInterval ^ mouseDownInterval! ! !EditingState methodsFor: 'accessing' stamp: 'AlainPlantec 11/9/2010 15:04'! mouseDownInterval: anInterval mouseDownInterval := anInterval! ! !EditingState methodsFor: 'accessing' stamp: 'AlainPlantec 11/9/2010 15:04'! pointBlock ^ pointBlock! ! !EditingState methodsFor: 'accessing' stamp: 'AlainPlantec 11/9/2010 15:04'! pointBlock: aCharacterBlock pointBlock := aCharacterBlock. ! ! !EditingState methodsFor: 'accessing' stamp: 'AlainPlantec 11/9/2010 15:04'! previousInterval ^ previousInterval ifNil: [previousInterval := 1 to: 0]! ! !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'! previousSelection ^ previousSelection ifNil: [previousSelection := '' asText]! ! !EditingState methodsFor: 'accessing' stamp: 'AlainPlantec 11/8/2010 15:03'! secondarySelectionToken ^ secondarySelectionToken ! ! !EditingState methodsFor: 'accessing' stamp: 'AlainPlantec 11/9/2010 14:45'! secondarySelectionToken: aTextOrStringOrRegex secondarySelectionToken := (aTextOrStringOrRegex isText ifTrue: [aTextOrStringOrRegex asString] ifFalse: [aTextOrStringOrRegex])! ! !EditingState methodsFor: 'accessing' stamp: 'AlainPlantec 11/9/2010 15:04'! startOfTyping ^ startOfTyping! ! !EditingState methodsFor: 'accessing' stamp: 'AlainPlantec 11/9/2010 15:04'! startOfTyping: anIntegerIndex startOfTyping := anIntegerIndex! ! !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'! unselect self markBlock: self pointBlock copy! ! !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: 'events' stamp: 'AlainPlantec 11/15/2010 09:54'! handlesKeyboard: evt from: aTextMorph ^ false! ! !EditingState methodsFor: 'events' stamp: 'AlainPlantec 11/22/2010 12:03'! keystroke: aKeyboardEvent from: aTextMorph ! ! !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 11/9/2010 15:04'! addUndoRecord: anUndoRecord self undoManager isPlugged ifTrue: [self undoManager clearRedoHistory. self undoManager addRecord: anUndoRecord] ! ! !EditingState methodsFor: 'undo-redo' stamp: 'AlainPlantec 12/13/2010 22:48'! clearUndoManager: aKeyboardEvent self undoManager reset. ^ true! ! !EditingState methodsFor: 'undo-redo' stamp: 'AlainPlantec 11/9/2010 15:04'! redo ^ self undoManager redo ! ! !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]! ! !EditingState methodsFor: 'undo-redo' stamp: 'AlainPlantec 11/9/2010 15:04'! undo ^ self undoManager undo ! ! !EditingState methodsFor: 'private-debugging' stamp: 'AlainPlantec 11/9/2010 15:04'! exploreUndoManager: aKeyboardEvent self undoManager explore. ^ true! ! Object subclass: #Editor instanceVariableNames: 'morph selectionShowing' classVariableNames: 'BlinkingCursor CmdKeysInText DumbbellCursor' poolDictionaries: '' category: 'Text-Edition'! !Editor commentStamp: 'AlainPlantec 11/2/2010 18:23' prior: 0! 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: 'accessing' stamp: 'AlainPlantec 11/8/2010 22:08'! currentAttributes "Redefined by subclasses that handle TextAttributes" ^nil! ! !Editor methodsFor: 'accessing' stamp: 'FernandoOlivero 6/9/2011 16:07'! markBlock: aCharacterBlock self editingState markBlock: aCharacterBlock! ! !Editor methodsFor: 'accessing' stamp: 'AlainPlantec 11/8/2010 22:08'! morph ^ morph! ! !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: 'accessing' stamp: 'FernandoOlivero 4/12/2011 10:43'! theme ^ UITheme current! ! !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: 'accessing-selection' stamp: 'AlainPlantec 11/8/2010 22:08'! hasSelection ^self hasCaret not! ! !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: 'accessing-selection' stamp: 'jmv 11/4/2008 14:02'! unselect self markIndex: self pointIndex! ! !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: '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: 'editing keys' stamp: 'AlainPlantec 11/8/2010 22:08'! copySelection: aKeyboardEvent "Copy the current text selection." self copySelection. ^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: 'editing keys' stamp: 'AlainPlantec 11/8/2010 22:08'! noop: aKeyboardEvent "Unimplemented keyboard command; just ignore it." ^ true! ! !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: 'menu messages' stamp: 'AlainPlantec 11/8/2010 22:08'! clipboardText ^ Clipboard clipboardText! ! !Editor methodsFor: 'menu messages' stamp: 'AlainPlantec 11/8/2010 22:08'! clipboardTextPut: text ^ Clipboard clipboardText: text! ! !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: '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: '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: '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: '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: '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: '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: '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: '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: '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: 'nonediting/nontyping keys' stamp: 'AlainPlantec 11/8/2010 22:08'! 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 | position - 1 max: 1] forward: false specialBlock:[:position | self previousWord: position] event: aKeyboardEvent. ^ 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: '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: 'nonediting/nontyping keys' stamp: 'AlainPlantec 11/8/2010 22:08'! 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 | position + 1] forward: true specialBlock:[:position | self nextWord: position] event: aKeyboardEvent. ^ true! ! !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: 'nonediting/nontyping keys' stamp: 'AlainPlantec 11/8/2010 22:08'! escape self morph escapePressed . ! ! !Editor methodsFor: 'nonediting/nontyping keys' stamp: 'AlainPlantec 11/8/2010 22:08'! escape: aKeyboardEvent self morph escapePressed. ^ false ! ! !Editor methodsFor: 'nonediting/nontyping keys' stamp: 'AlainPlantec 11/8/2010 22:08'! selectWord: aKeyboardEvent self closeTypeIn. self selectWord. ^ 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'! hasError ^ false ! ! !Editor methodsFor: 'testing' stamp: 'AlainPlantec 11/8/2010 22:08'! isSimpleEditor ^ false ! ! !Editor methodsFor: 'testing' stamp: 'AlainPlantec 11/8/2010 22:08'! isSmalltalkEditor ^ false ! ! !Editor methodsFor: 'testing' stamp: 'AlainPlantec 11/8/2010 22:08'! isTextEditor ^ false ! ! !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: '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: '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: '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: '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: '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: 'typing/selecting keys' stamp: 'AlainPlantec 11/8/2010 22:08'! selectAll self selectFrom: 1 to: self string size! ! !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: '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: '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: '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: '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: '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 class instanceVariableNames: ''! !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: 'settings' stamp: 'AlainPlantec 11/8/2010 22:08'! cmdKeysInText ^ CmdKeysInText ifNil: [CmdKeysInText := true]! ! !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'! dumbbellCursor ^ DumbbellCursor ifNil: [ DumbbellCursor := false ]! ! !Editor class methodsFor: 'settings' stamp: 'AlainPlantec 11/8/2010 22:08'! dumbbellCursor: aBoolean DumbbellCursor := 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" )! ! DialogWindow subclass: #EditorFindReplaceDialogWindow instanceVariableNames: 'state' classVariableNames: 'Finds Replacements Singleton' poolDictionaries: '' category: 'Text-Edition'! !EditorFindReplaceDialogWindow methodsFor: '*Polymorph-TaskbarIcons' stamp: 'FernandoOlivero 4/12/2011 09:45'! taskbarIcon ^self theme smallFindIcon! ! !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: '*Polymorph-Widgets' stamp: 'AlainPlantec 12/3/2010 09:05'! aboutTitle ^ 'Find & replace dialog'! ! !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: '*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: 'accessing' stamp: 'AlainPlantec 11/10/2010 16:20'! caseSensitive ^ self state caseSensitive! ! !EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 11/12/2010 21:25'! caseSensitive: aBoolean self state caseSensitive: aBoolean. ! ! !EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 11/10/2010 16:21'! entireWordsOnly ^ self state entireWordsOnly! ! !EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 11/12/2010 21:25'! entireWordsOnly: aBoolean self state entireWordsOnly: aBoolean. ! ! !EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 11/17/2010 15:57'! findString ^ self state findString! ! !EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 11/10/2010 16:18'! findText ^ self state findText! ! !EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 12/3/2010 09:38'! findText: aStringOrText self state findText: aStringOrText. ^ true ! ! !EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 11/10/2010 16:21'! isRegex ^ self state isRegex! ! !EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 11/12/2010 21:25'! isRegex: aBoolean self state isRegex: aBoolean. ! ! !EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 11/27/2010 23:35'! maxPreviousListSize ^ self class maxPreviousListSize! ! !EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 11/27/2010 23:36'! prevFinds ^ self class finds! ! !EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 11/27/2010 23:36'! prevReplacements ^ self class replacements! ! !EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 11/10/2010 16:19'! replaceText ^ self state replaceText! ! !EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 11/23/2010 15:20'! replaceText: aStringOrText self state replaceText: aStringOrText asString. ^ true ! ! !EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 11/10/2010 16:22'! searchBackwards ^ self state searchBackwards! ! !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: 'accessing' stamp: 'AlainPlantec 11/12/2010 21:16'! state ^ state ifNil: [self state: FindReplaceService new]! ! !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: 'accessing' stamp: 'AlainPlantec 11/10/2010 17:28'! wrapAround ^ self state wrapAround ! ! !EditorFindReplaceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 11/10/2010 22:19'! wrapAround: aBoolean self state wrapAround: aBoolean. ! ! !EditorFindReplaceDialogWindow methodsFor: 'action' stamp: 'AlainPlantec 12/3/2010 09:42'! cancel self state findText: ''. super cancel! ! !EditorFindReplaceDialogWindow methodsFor: 'action' stamp: 'AlainPlantec 11/28/2010 09:41'! find self newFinding. ^ self state findInTextMorph: self model! ! !EditorFindReplaceDialogWindow methodsFor: 'action' stamp: 'AlainPlantec 12/3/2010 09:49'! open self openAsIsIn: World. self extent: self extent. self activate ! ! !EditorFindReplaceDialogWindow methodsFor: 'action' stamp: 'AlainPlantec 4/27/2011 13:35'! replace self newReplacement. self state replaceInTextMorph: self model. self find! ! !EditorFindReplaceDialogWindow methodsFor: 'action' stamp: 'AlainPlantec 11/21/2010 22:00'! replaceAll self model takeKeyboardFocus. self state replaceAllInTextMorph: self model! ! !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: '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: '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: '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: '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 12/3/2010 09:34'! 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: self theme smallHelpIcon. ^aMenu! ! !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: 'user-interface' stamp: 'AlainPlantec 11/27/2010 16:46'! defaultFocusMorph ^ self findTextFieldMorph textMorph! ! !EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: 'AlainPlantec 11/8/2010 22:33'! extent: anExtent ^ super extent: anExtent x @ self initialExtent y! ! !EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: 'AlainPlantec 11/17/2010 15:57'! findEnabled ^ self findString isEmptyOrNil not ! ! !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: 'user-interface' stamp: 'AlainPlantec 11/27/2010 13:42'! initialExtent ^ 400 @ super initialExtent y! ! !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: 'AlainPlantec 11/9/2010 17:24'! newButtons "Answer new buttons as appropriate." ^{self newFindButton isDefault: true. self newReplaceButton. self newReplaceAllButton. self newCancelButton}! ! !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 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: '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: '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: '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: '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: 'user-interface' stamp: 'AlainPlantec 11/10/2010 23:56'! replaceAllEnabled ^ self model notNil and: [self findText notEmpty]! ! !EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: 'AlainPlantec 4/27/2011 15:19'! replaceEnabled ^ self model notNil and: [self findText notEmpty]! ! !EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: 'AlainPlantec 11/16/2010 09:51'! taskbarButtonFor: aTaskBar "No taskbar button because always on top" ^nil! ! !EditorFindReplaceDialogWindow methodsFor: 'user-interface' stamp: 'AlainPlantec 11/11/2010 22:58'! title ^ 'Find & Replace' translated. ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! EditorFindReplaceDialogWindow class instanceVariableNames: ''! !EditorFindReplaceDialogWindow class methodsFor: 'accessing' stamp: 'AlainPlantec 11/27/2010 23:35'! finds ^ Finds ifNil: [Finds := OrderedCollection new]! ! !EditorFindReplaceDialogWindow class methodsFor: 'accessing' stamp: 'AlainPlantec 11/27/2010 23:35'! maxPreviousListSize ^ 15! ! !EditorFindReplaceDialogWindow class methodsFor: 'accessing' stamp: 'AlainPlantec 11/27/2010 23:35'! replacements ^ Replacements ifNil: [Replacements := OrderedCollection new]! ! !EditorFindReplaceDialogWindow class methodsFor: 'initializing' stamp: 'AlainPlantec 11/27/2010 22:58'! initialize "EditorFindReplaceDialogWindow initialize" Singleton := nil. Smalltalk addToStartUpList: self! ! !EditorFindReplaceDialogWindow class methodsFor: 'initializing' stamp: 'AlainPlantec 11/27/2010 22:57'! startUp "This message is sent to registered classes when the system is coming up." Singleton ifNotNil: [Singleton close. Singleton := nil]! ! !EditorFindReplaceDialogWindow class methodsFor: 'instance creation' stamp: 'AlainPlantec 11/11/2010 21:46'! on: aTextView ^ self singleton on: aTextView! ! !EditorFindReplaceDialogWindow class methodsFor: 'instance creation' stamp: 'AlainPlantec 11/11/2010 19:26'! singleton ^ Singleton ifNil: [Singleton := self new]. ! ! Object subclass: #EllipseMidpointTracer instanceVariableNames: 'rect x y a b aSquared bSquared d1 d2 inFirstRegion' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Support'! !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.! ! BorderedMorph subclass: #EllipseMorph uses: TAbleToRotate instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Basic'! !EllipseMorph commentStamp: 'kfr 10/27/2003 10:32' prior: 0! 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: 'accessing' stamp: 'sw 11/24/1999 14:59'! couldHaveRoundedCorners ^ false! ! !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: 'drawing' stamp: 'IgorStasenko 8/8/2011 17:21'! drawDropShadowOn: aCanvas aCanvas fillOval: bounds fillStyle: self shadowColor borderWidth: 0 borderColor: nil! ! !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 8/31/2004 14:25'! bottomLeftCorner ^self intersectionWithLineSegmentFromCenterTo: bounds bottomLeft ! ! !EllipseMorph methodsFor: 'geometry' stamp: 'nk 8/31/2004 14:23'! bottomRightCorner ^self intersectionWithLineSegmentFromCenterTo: bounds bottomRight ! ! !EllipseMorph methodsFor: 'geometry' stamp: 'nk 2/15/2001 16:08'! closestPointTo: aPoint ^self intersectionWithLineSegmentFromCenterTo: aPoint! ! !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: 'geometry' stamp: 'nk 8/31/2004 14:23'! topLeftCorner ^self intersectionWithLineSegmentFromCenterTo: bounds topLeft ! ! !EllipseMorph methodsFor: 'geometry' stamp: 'nk 8/31/2004 14:26'! topRightCorner ^self intersectionWithLineSegmentFromCenterTo: bounds topRight ! ! !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:37'! defaultBorderWidth "answer the default border width for the receiver" ^ 1! ! !EllipseMorph methodsFor: 'initialization' stamp: 'dgd 2/14/2003 22:26'! defaultColor "answer the default color/fill style for the receiver" ^ Color yellow! ! !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: 't-rotating'! forwardDirection "Return the receiver's forward direction (in eToy terms)" ^self valueOfProperty: #forwardDirection ifAbsent:[0.0]! ! !EllipseMorph methodsFor: 't-rotating'! forwardDirection: newDirection "Set the receiver's forward direction (in eToy terms)" self setProperty: #forwardDirection toValue: newDirection.! ! !EllipseMorph methodsFor: 't-rotating'! heading "Return the receiver's heading" ^ self owner ifNil: [self forwardDirection] ifNotNil: [self forwardDirection + self owner degreesOfFlex]! ! !EllipseMorph methodsFor: 't-rotating'! 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'! rotationDegrees "Default implementation." ^ 0.0 ! ! !EllipseMorph methodsFor: 't-rotating'! rotationDegrees: degrees "redefined in all morphs which are using myself"! ! !EllipseMorph methodsFor: 't-rotating'! setDirectionFrom: aPoint | delta degrees | delta := (self transformFromWorld globalPointToLocal: aPoint) - self referencePosition. degrees := delta degrees + 90.0. self forwardDirection: (degrees \\ 360) rounded. ! ! !EllipseMorph methodsFor: 'testing' stamp: 'ar 8/25/2001 19:08'! canDrawBorder: aBorderStyle ^aBorderStyle style == #simple! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! EllipseMorph class uses: TAbleToRotate classTrait instanceVariableNames: ''! MenuMorph subclass: #EmbeddedMenuMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !EmbeddedMenuMorph commentStamp: 'gvc 5/18/2007 13:18' prior: 0! Menu designed to be embedded in another morph rather than popped up directly.! !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: '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: '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 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 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: '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: '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: '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: '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! ! !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! ! StringMorph subclass: #EmbossedStringMorph instanceVariableNames: 'style trackPaneColor' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !EmbossedStringMorph commentStamp: 'gvc 5/18/2007 13:15' prior: 0! 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: 'accessing' stamp: 'gvc 5/10/2006 15:26'! style: anObject "Set the value of style" style := anObject. self changed! ! !EmbossedStringMorph methodsFor: 'accessing' stamp: 'gvc 8/9/2007 11:52'! trackPaneColor "Answer the value of trackPaneColor" ^ trackPaneColor! ! !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 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: '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 11:52'! initialize "Initialize the receiver." super initialize. self style: #inset; trackPaneColor: true! ! !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: 'as yet unclassified' stamp: 'gvc 8/9/2007 11:35'! styleSymbols "Answer the valid styles." ^#(plain inset insetNoHighlight raised raisedNoHighlight)! ! Object subclass: #EncodedCharSet instanceVariableNames: '' classVariableNames: 'EncodedCharSets' poolDictionaries: '' category: 'Multilingual-Encodings'! !EncodedCharSet commentStamp: 'yo 10/19/2004 19:08' prior: 0! 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 instanceVariableNames: 'compoundTextSequence'! !EncodedCharSet class methodsFor: 'accessing - displaying' stamp: 'yo 12/18/2002 12:34'! isBreakableAt: index in: text self subclassResponsibility. ! ! !EncodedCharSet class methodsFor: 'accessing - displaying' stamp: 'yo 9/4/2002 22:51'! printingDirection self subclassResponsibility. ! ! !EncodedCharSet class methodsFor: 'accessing - displaying' stamp: 'sn 7/31/2009 15:01'! scanSelector ^ #scanMultiCharactersFrom:to:in:rightX:stopConditions:kern:! ! !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: 'character classification' stamp: 'yo 8/5/2003 17:18'! canBeNonGlobalVarInitial: char | leadingChar | leadingChar := char leadingChar. leadingChar = 0 ifTrue: [^ self isLowercase: char]. ^ self isLetter: char. ! ! !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: '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 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: '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: '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: '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: '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: 'class methods' stamp: 'MarcusDenker 5/10/2012 15:44'! initialize " self initialize " self allSubclassesDo: [:each | each initialize]. EncodedCharSets := Array new: 256. EncodedCharSets at: 0+1 put: Unicode "Latin1Environment". 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: 9+1 put: UnicodeTraditionalChinese." "EncodedCharSets at: 10+1 put: UnicodeVietnamese." 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 12/2/2004 16:13'! isCharset ^ true. ! ! !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: 'class methods' stamp: 'yo 10/14/2003 10:19'! ucsTable ^ UCSTable latin1Table. ! ! ParseNode subclass: #Encoder instanceVariableNames: 'scopeTable nTemps supered requestor class selector literalStream selectorSet litIndSet litSet sourceRanges globalSourceRanges addedSelectorAndMethodClassLiterals optimizedSelectors' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Kernel'! !Encoder commentStamp: '' prior: 0! 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: 'accessing' stamp: 'eem 5/29/2008 09:36'! methodNodeClass ^MethodNode! ! !Encoder methodsFor: 'accessing' stamp: 'ar 9/9/2006 12:06'! selector ^selector! ! !Encoder methodsFor: 'accessing' stamp: 'ar 9/9/2006 12:06'! selector: aSymbol selector := aSymbol! ! !Encoder methodsFor: 'encoding'! cantStoreInto: varName ^StdVariables includesKey: varName! ! !Encoder methodsFor: 'encoding' stamp: 'eem 9/5/2009 20:04'! doItInContextName ^'ThisContext'! ! !Encoder methodsFor: 'encoding'! encodeLiteral: object ^self name: object key: (class literalScannedAs: object notifying: self) class: LiteralNode type: LdLitType set: litSet! ! !Encoder methodsFor: 'encoding'! encodeSelector: selector ^self name: selector key: selector class: SelectorNode type: SendType set: selectorSet! ! !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: 'ls 1/19/2001 12:59'! encodeVariable: name ifUnknown: action ^self encodeVariable: name sourceRange: nil ifUnknown: action! ! !Encoder methodsFor: 'encoding' stamp: 'StephaneDucasse 11/14/2010 22:36'! 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: [ OutOfScopeNotification signal ifTrue: [action value] ifFalse: [ ^self notify: 'out of scope']. ]. ^ varNode! ! !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: 'encoding'! 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: '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: '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: '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: 'error handling'! notify: string at: location | req | requestor == nil ifFalse: [req := requestor. self release. req notify: string at: location]. ^false! ! !Encoder methodsFor: 'error handling'! requestor: req "Often the requestor is a BrowserCodeController" requestor := req! ! !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: '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: '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: 'nice 11/20/2011 22:31'! nTemps: n literals: lits class: cl "Decompile." supered := false. class := cl. nTemps := n. literalStream := (Array new: lits size) writeStream. literalStream nextPutAll: lits. sourceRanges := Dictionary new: 32. globalSourceRanges := OrderedCollection new: 32. ! ! !Encoder methodsFor: 'initialize-release'! noteSuper supered := true! ! !Encoder methodsFor: 'initialize-release'! release requestor := nil! ! !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: '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: '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: 'results'! literals "Should only be used for decompiling primitives" ^ literalStream contents! ! !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: '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: 'results' stamp: 'eem 9/8/2008 18:27'! tempsAndBlockArgs | tempNodes | tempNodes := OrderedCollection new. scopeTable associationsDo: [:assn | | var | var := assn value. (var isTemp and: [var isMethodArg not and: [var scope = 0 or: [var scope = -1]]]) ifTrue: [tempNodes add: var]]. ^tempNodes! ! !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: 'source mapping' stamp: 'di 12/4/1999 22:27'! globalSourceRanges ^ globalSourceRanges! ! !Encoder methodsFor: 'source mapping'! noteSourceRange: range forNode: node sourceRanges at: node put: range! ! !Encoder methodsFor: 'source mapping' stamp: 'RAA 8/21/1999 06:52'! rawSourceRanges ^ sourceRanges ! ! !Encoder methodsFor: 'source mapping'! sourceMap "Answer with a sorted set of associations (pc range)." ^ (sourceRanges keys collect: [:key | Association key: key pc value: (sourceRanges at: key)]) asSortedCollection! ! !Encoder methodsFor: 'source mapping' stamp: 'ar 11/19/2002 14:41'! sourceRangeFor: node ^sourceRanges at: node! ! !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: '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: '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: '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: '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: '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: '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: '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! ! !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: '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: '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: '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: 'temps' stamp: 'JorgeRessia 6/5/2010 11:32'! isAnalyzedMethodDefinedByATrait ^( class traitOrClassOfSelector: #testReplaceFromToWithStartingAt ) isTrait! ! !Encoder methodsFor: 'temps'! maxTemp ^nTemps! ! !Encoder methodsFor: 'temps'! newTemp: name nTemps := nTemps + 1. ^ TempVariableNode new name: name index: nTemps - 1 type: LdTempType scope: 0! ! !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: 'private'! 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: '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: 'private' stamp: 'ar 3/26/2004 15:44'! interactive ^requestor interactive! ! !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: '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: 'private' stamp: 'ar 1/2/2002 14:53'! possibleNamesFor: proposedName | results | results := class possibleVariablesFor: proposedName continuedFrom: nil. ^ proposedName correctAgainst: nil continuedFrom: results. ! ! !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: 'private'! reallyBind: name | node | node := self newTemp: name. scopeTable at: name put: node. ^node! ! !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)']! ! BytecodeEncoder subclass: #EncoderForLongFormV3 instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Kernel'! !EncoderForLongFormV3 commentStamp: '' prior: 0! 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 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'! genDup "See BlueBook page 596" "136 10001000 Duplicate Stack Top" stream nextPut: 136! ! !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: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! ! !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 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: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/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'! 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/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: '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 5/15/2008 14:12'! genPushThisContext "See BlueBook page 596" "137 10001001 Push Active Context" stream nextPut: 137! ! !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/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: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/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/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: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: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 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: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: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'! 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: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: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/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: '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 subclass: #EncoderForLongFormV3PlusClosures instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Kernel'! !EncoderForLongFormV3PlusClosures commentStamp: '' prior: 0! 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 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]! ! !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! ! BytecodeEncoder subclass: #EncoderForV3 instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Kernel'! !EncoderForV3 commentStamp: '' prior: 0! 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 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/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: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 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! ! !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 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'! 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/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 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/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: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 5/14/2008 17:36'! genPushThisContext "See BlueBook page 596" "137 10001001 Push Active Context" stream nextPut: 137! ! !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/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: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/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/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: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: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 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: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: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: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 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 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/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 subclass: #EncoderForV3PlusClosures instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Kernel'! !EncoderForV3PlusClosures commentStamp: '' prior: 0! 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 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]! ! !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! ! MultiDisplayScanner subclass: #EncryptedMultiDisplayScanner instanceVariableNames: '' classVariableNames: '' poolDictionaries: 'TextConstants' category: 'Text-Scanning'! !EncryptedMultiDisplayScanner commentStamp: '' prior: 0! An EncryptedMultiDisplayScanner is a MultiDisplayScanner displaying stars instead of characters (for password by example)! !EncryptedMultiDisplayScanner methodsFor: 'scanning' stamp: 'BenjaminVanRyseghem 5/3/2012 16:57'! 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 | 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 := runX := leftMargin. fillBlt == nil ifFalse: ["Not right" fillBlt destX: line left destY: lineY width: line width left height: lineHeight; copyBits]. lastIndex := line first. leftInRun <= 0 ifTrue: [nowLeftInRun := text runLengthFor: lastIndex] ifFalse: [nowLeftInRun := leftInRun]. baselineY := lineY + line baseline. destY := baselineY - font ascent. runStopIndex := lastIndex + (nowLeftInRun - 1) min: line last. spaceCount := 0. string := String streamContents: [:s | 1 to: text string size do: [:i | s << '*']]. [ startIndex := lastIndex. lastPos := destX@destY. stopCondition := self scanCharactersFrom: lastIndex to: runStopIndex in: string rightX: rightMargin stopConditions: stopConditions kern: kern. lastIndex >= startIndex ifTrue:[ bitBlt displayString: string from: startIndex "XXXX: The following is an interesting bug. All stopConditions exept #endOfRun have lastIndex past the last character displayed. #endOfRun sets it *on* the character. If we display up until lastIndex then we will also display invisible characters like CR and tab. This problem should be fixed in the scanner (i.e., position lastIndex consistently) but I don't want to deal with the fallout right now so we keep the fix minimally invasive." to: (stopCondition == #endOfRun ifTrue:[lastIndex] ifFalse:[lastIndex-1]) at: lastPos kern: kern baselineY: baselineY font: font]. "see setStopConditions for stopping conditions for displaying." self perform: stopCondition. "or: [lastIndex > runStopIndex]." ] whileFalse. ^ runStopIndex - lastIndex "Number of characters remaining in the current run"! ! TextMorphForFieldView subclass: #EncryptedTextMorphForFieldView instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !EncryptedTextMorphForFieldView commentStamp: '' prior: 0! An EncryptedTextMorphForFieldView is a view displaying stars instead of character (for password by example)! !EncryptedTextMorphForFieldView methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 5/3/2012 16:47'! drawOn: aCanvas | fauxBounds | self setDefaultContentsIfNil. self perform: #drawOn: withArguments: {aCanvas} inSuperclass: Morph. (self startingIndex > text size) ifTrue: [self drawNullTextOn: aCanvas]. "Hack here: The canvas expects bounds to carry the location of the text, but we also need to communicate clipping." fauxBounds := self bounds topLeft corner: self innerBounds bottomRight. aCanvas encryptedParagraph: self paragraph bounds: fauxBounds color: color.! ! Object subclass: #EntryCompletion instanceVariableNames: 'dataSourceBlock filterBlock chooseBlock chooser previousToken' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !EntryCompletion commentStamp: 'AlainPlantec 11/29/2010 10:58' prior: 0! 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: '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: 'AlainPlantec 11/22/2010 16:04'! chooseBlock: aBlock chooseBlock := aBlock! ! !EntryCompletion methodsFor: 'accessing' stamp: 'AlainPlantec 11/25/2010 20:12'! chooser ^ chooser! ! !EntryCompletion methodsFor: 'accessing' stamp: 'AlainPlantec 11/29/2010 08:55'! chooserWith: aToken | applicants | applicants := self filteredValuesWith: aToken. aToken isNil ifTrue: [applicants isEmpty ifFalse: [self setChooserWith: nil labels: applicants]] ifFalse: [ | 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/24/2010 21:30'! closeChooser chooser ifNotNil: [chooser close. chooser := nil]. ! ! !EntryCompletion methodsFor: 'accessing' stamp: 'AlainPlantec 11/25/2010 10:20'! dataSourceBlock ^ dataSourceBlock ifNil: [dataSourceBlock := [:token | #()]]! ! !EntryCompletion methodsFor: 'accessing' stamp: 'AlainPlantec 11/25/2010 09:06'! dataSourceBlock: aBlock dataSourceBlock := aBlock! ! !EntryCompletion methodsFor: 'accessing' stamp: 'AlainPlantec 11/24/2010 17:02'! filterBlock ^ filterBlock ifNil: [filterBlock := [:currApplicant :currText | true]]! ! !EntryCompletion methodsFor: 'accessing' stamp: 'AlainPlantec 11/23/2010 18:18'! filterBlock: aBlock filterBlock := aBlock! ! !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 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: '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/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 13:34'! setChooserWith: aToken labels: labels chooser ifNil: [chooser := IdentifierChooserMorph labels: labels chooseBlock: [:token | self choose: token]]. ^ chooser! ! !EntryCompletion methodsFor: 'event-handling' stamp: 'AlainPlantec 11/27/2010 13:13'! closeIfNotOver: aMorph | mw | (chooser notNil and: [(mw := aMorph world) notNil]) ifTrue: [ | subs | subs := mw submorphs. (subs indexOf: chooser) > (subs indexOf: aMorph window) ifTrue: [self closeChooser]] ! ! !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: '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! ! PrototypeTester subclass: #EqualityTester instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Core-Utilities'! !EqualityTester commentStamp: 'mjr 8/20/2003 13:04' prior: 0! 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! ! Exception subclass: #Error instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Exceptions'! !Error commentStamp: '' prior: 0! >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: '*SUnit-Core' stamp: 'NiallRoss 7/18/2010 11:59'! sunitAnnounce: aTestCase toResult: aTestResult aTestResult addError: aTestCase. self sunitExitWith: false.! ! !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! ! MessageDialogWindow subclass: #ErrorDialogWindow instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Windows'! !ErrorDialogWindow commentStamp: 'gvc 5/18/2007 14:51' prior: 0! A message dialog with an error icon.! !ErrorDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 5/18/2007 14:52'! icon "Answer an icon for the receiver." ^self theme errorIcon! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ErrorDialogWindow class instanceVariableNames: ''! !ErrorDialogWindow class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'gvc 5/22/2007 11:54'! taskbarIcon "Answer the icon for the receiver in a task bar." ^self theme smallErrorIcon! ! Error subclass: #ErrorNonInteractive instanceVariableNames: 'exception' classVariableNames: '' poolDictionaries: '' category: 'UIManager'! !ErrorNonInteractive commentStamp: 'IgorStasenko 1/25/2011 13:29' prior: 0! 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: 'CamilloBruni 7/24/2012 16:27'! 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 ifNotNilDo: [ :ex | s cr; tab; print: ex ]].! ! !ErrorNonInteractive methodsFor: 'accessing' stamp: 'IgorStasenko 1/24/2011 10:36'! exception ^ exception! ! !ErrorNonInteractive methodsFor: 'accessing' stamp: 'IgorStasenko 1/24/2011 10:36'! exception: anError exception := anError! ! !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 instanceVariableNames: ''! !ErrorNonInteractive class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 1/24/2011 10:34'! signalForException: anError ^ self new exception: anError; signal! ! Exception subclass: #ErrorWhileCreationException instanceVariableNames: 'response' classVariableNames: '' poolDictionaries: '' category: 'CI-Core'! !ErrorWhileCreationException commentStamp: '' prior: 0! An ErrorWhileCreationException is an exception raised when the creation of a new issue fails! !ErrorWhileCreationException methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/4/2012 14:11'! response ^ response! ! !ErrorWhileCreationException methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/4/2012 14:11'! response: anObject response := anObject! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ErrorWhileCreationException class instanceVariableNames: ''! !ErrorWhileCreationException class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 7/4/2012 14:12'! response: response ^ self new response: response; yourself! ! Cookie subclass: #EternalCookie instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KeyChain'! !EternalCookie commentStamp: '' prior: 0! 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! ! BasicCodeLoader subclass: #EvaluateCommandLineHandler instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-CommandLine'! !EvaluateCommandLineHandler commentStamp: '' prior: 0! Usage: eval [--help] --help list this help message 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_VM my.image eval 1 + 2 or it can read directly from stdin: echo "1+2" | $PHARO_VM my.image eval ! !EvaluateCommandLineHandler methodsFor: 'activation' stamp: 'CamilloBruni 10/13/2012 15:49'! activate self activateHelp. self arguments ifEmpty: [ ^ self evaluateStdIn ]. self evaluateArguments. self quit.! ! !EvaluateCommandLineHandler methodsFor: 'activation' stamp: 'CamilloBruni 6/23/2012 22:46'! evaluateArguments | args | args := self arguments joinUsing: Character space. args ifEmpty: [ ^ self ]. self evaluate: args! ! !EvaluateCommandLineHandler methodsFor: 'activation' stamp: 'CamilloBruni 6/23/2012 22:45'! 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 ifNotNilDo: [ :char| s nextPut: char ]]])! ! !EvaluateCommandLineHandler methodsFor: 'commands' stamp: 'CamilloBruni 2/10/2013 19:37'! evaluate: aStream [ self stdout print: (Compiler evaluate: aStream); lf ] on: Error, ParserNotification do: [ :e| self handleError: e ].! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! EvaluateCommandLineHandler class instanceVariableNames: ''! !EvaluateCommandLineHandler class methodsFor: 'accessing' stamp: 'CamilloBruni 4/28/2012 22:48'! commandName ^ 'eval'! ! !EvaluateCommandLineHandler class methodsFor: 'accessing' stamp: 'CamilloBruni 2/6/2013 18:16'! description ^ 'Directly evaluates passed in one line scripts'! ! !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! ! Object subclass: #EventHandler instanceVariableNames: 'mouseDownRecipient mouseDownSelector mouseMoveRecipient mouseMoveSelector mouseStillDownRecipient mouseStillDownSelector mouseUpRecipient mouseUpSelector mouseEnterRecipient mouseEnterSelector mouseLeaveRecipient mouseLeaveSelector mouseEnterDraggingRecipient mouseEnterDraggingSelector mouseLeaveDraggingRecipient mouseLeaveDraggingSelector keyStrokeRecipient keyStrokeSelector valueParameter startDragRecipient startDragSelector doubleClickSelector doubleClickRecipient doubleClickTimeoutSelector doubleClickTimeoutRecipient clickSelector clickRecipient' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !EventHandler commentStamp: '' prior: 0! 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: '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: '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: 'access'! 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: '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: 'access' stamp: 'di 9/14/1998 08:32'! mouseDownSelector ^ mouseDownSelector! ! !EventHandler methodsFor: 'access' stamp: 'ar 10/25/2000 18:27'! mouseStillDownRecipient ^mouseStillDownRecipient! ! !EventHandler methodsFor: 'access' stamp: 'ar 10/25/2000 18:27'! mouseStillDownSelector ^mouseStillDownSelector! ! !EventHandler methodsFor: 'access' stamp: 'di 9/14/1998 08:32'! mouseUpSelector ^ mouseUpSelector! ! !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: '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: '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: 'jcg 9/21/2001 13:06'! doubleClickTimeout: event fromMorph: sourceMorph ^ self send: doubleClickTimeoutSelector to: doubleClickTimeoutRecipient withEvent: event fromMorph: sourceMorph! ! !EventHandler methodsFor: 'events'! keyStroke: event fromMorph: sourceMorph ^ self send: keyStrokeSelector to: keyStrokeRecipient withEvent: event fromMorph: sourceMorph! ! !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'! mouseEnter: event fromMorph: sourceMorph ^ self send: mouseEnterSelector to: mouseEnterRecipient withEvent: event fromMorph: sourceMorph! ! !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'! mouseLeave: event fromMorph: sourceMorph ^ self send: mouseLeaveSelector to: mouseLeaveRecipient withEvent: event fromMorph: sourceMorph! ! !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: 'events' stamp: 'ar 10/25/2000 17:32'! mouseMove: event fromMorph: sourceMorph ^ self send: mouseMoveSelector to: mouseMoveRecipient withEvent: event fromMorph: sourceMorph! ! !EventHandler methodsFor: 'events'! mouseStillDown: event fromMorph: sourceMorph ^ self send: mouseStillDownSelector to: mouseStillDownRecipient withEvent: event fromMorph: sourceMorph! ! !EventHandler methodsFor: 'events'! mouseUp: event fromMorph: sourceMorph ^ self send: mouseUpSelector to: mouseUpRecipient 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: 'mir 5/23/2000 17:43'! startDrag: event fromMorph: sourceMorph ^ self send: startDragSelector to: startDragRecipient 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: 'initialization' stamp: 'StephaneDucasse 10/20/2011 15:45'! on: eventName send: selector to: recipient withValue: value selector numArgs = 3 ifFalse: [Halt halt: 'Warning: value parameters are passed as first of 3 arguments']. self on: eventName send: selector to: recipient. valueParameter := value ! ! !EventHandler methodsFor: 'initialization' stamp: 'nk 2/15/2004 08:59'! onGestureSend: selector to: recipient! ! !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: 'testing' stamp: 'ar 10/7/2000 22:56'! handlesClickOrDrag: evt clickRecipient ifNotNil:[^true]. doubleClickRecipient ifNotNil:[^true]. startDragRecipient 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: 'testing' stamp: 'ar 10/28/2000 22:17'! handlesKeyboard: evt keyStrokeRecipient ifNotNil: [^ true]. ^ false! ! !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: 'testing' stamp: 'ar 10/25/2000 17:33'! handlesMouseMove: evt ^mouseMoveRecipient notNil and:[mouseMoveSelector notNil]! ! !EventHandler methodsFor: 'testing'! handlesMouseOver: evt mouseEnterRecipient ifNotNil: [^ true]. mouseLeaveRecipient ifNotNil: [^ true]. ^ false! ! !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/22/2000 17:05'! handlesMouseStillDown: evt ^mouseStillDownRecipient notNil and:[mouseStillDownSelector notNil]! ! EventHandler subclass: #EventHandlerPlus instanceVariableNames: 'mouseOverRecipient mouseOverSelector' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !EventHandlerPlus commentStamp: 'gvc 5/18/2007 13:13' prior: 0! Support for handling mouseOver events (no button down).! !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: '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:20'! mouseOver: event fromMorph: sourceMorph "Relay the event." ^ self send: mouseOverSelector to: mouseOverRecipient withEvent: event fromMorph: sourceMorph! ! !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! ! Object subclass: #EventManager instanceVariableNames: 'actionMap' classVariableNames: 'ActionMaps' poolDictionaries: '' category: 'System-Object Events'! !EventManager commentStamp: 'tlk 5/7/2006 20:01' prior: 0! 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:37'! actionMap ^actionMap == nil ifTrue: [self createActionMap] ifFalse: [actionMap]! ! !EventManager methodsFor: 'accessing' stamp: 'reThink 3/3/2001 10:07'! changedEventSelector ^#changed:! ! !EventManager methodsFor: 'accessing' stamp: 'reThink 2/18/2001 15:39'! releaseActionMap actionMap := nil! ! !EventManager methodsFor: 'accessing' stamp: 'reThink 3/3/2001 10:07'! updateEventSelector ^#update:! ! !EventManager methodsFor: 'accessing' stamp: 'reThink 2/18/2001 15:38'! updateableActionMap actionMap == nil ifTrue: [actionMap := self createActionMap]. ^actionMap! ! !EventManager methodsFor: 'copying' stamp: 'StephaneDucasse 10/2/2010 17:00'! postCopy super postCopy. self release! ! !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:07'! breakDependents "Remove all of the receiver's dependents." self removeActionsForEvent: self changedEventSelector! ! !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'! removeDependent: anObject "Remove the given object as one of the receiver's dependents." self removeActionsWithReceiver: anObject forEvent: self changedEventSelector. ^ anObject! ! !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 class instanceVariableNames: ''! !EventManager class methodsFor: 'accessing' stamp: 'reThink 2/18/2001 14:42'! actionMapFor: anObject ^self actionMaps at: anObject ifAbsent: [self createActionMap]! ! !EventManager class methodsFor: 'accessing' stamp: 'nice 4/19/2011 00:02'! actionMaps ^ActionMaps ifNil: [ActionMaps := WeakIdentityKeyDictionary new]! ! !EventManager class methodsFor: 'accessing' stamp: 'reThink 2/25/2001 08:52'! updateableActionMapFor: anObject ^self actionMaps at: anObject ifAbsentPut: [self createActionMap]! ! !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].! ! !EventManager class methodsFor: 'initialization' stamp: 'nice 1/5/2010 15:59'! flushEvents "Object flushEvents" self actionMaps keysAndValuesDo:[:rcvr :evtDict| rcvr ifNotNil:[ "make sure we don't modify evtDict while enumerating" evtDict keys do:[:evtName| | msgSet | msgSet := evtDict at: evtName ifAbsent:[nil]. (msgSet == nil) ifTrue:[rcvr removeActionsForEvent: evtName]]]]. EventManager actionMaps finalizeValues. ! ! !EventManager class methodsFor: 'releasing' stamp: 'reThink 2/18/2001 15:34'! releaseActionMapFor: anObject self actionMaps removeKey: anObject ifAbsent: []! ! ClassTestCase subclass: #EventManagerTest instanceVariableNames: 'eventSource eventListener succeeded' classVariableNames: '' poolDictionaries: '' category: 'Tests-Object Events'! !EventManagerTest methodsFor: 'running' stamp: 'JWS 9/7/2000 17:19'! setUp super setUp. eventSource := EventManager new. eventListener := Bag new. succeeded := false! ! !EventManagerTest methodsFor: 'running' stamp: 'jws 11/28/2000 16:25'! tearDown eventSource releaseActionMap. eventSource := nil. eventListener := nil. super tearDown. ! ! !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-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]! ! !EventManagerTest methodsFor: 'running-broadcast query' stamp: 'JWS 9/7/2000 17:22'! testNoValueSupplier succeeded := eventSource triggerEvent: #needsValue ifNotHandled: [true]. self should: [succeeded]! ! !EventManagerTest methodsFor: 'running-broadcast query' stamp: 'JWS 9/7/2000 17:22'! testNoValueSupplierHasArguments succeeded := eventSource triggerEvent: #needsValue: with: 'nelja' ifNotHandled: [true]. self should: [succeeded]! ! !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-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-dependent action' stamp: 'ar 8/26/2009 21:37'! testBlockReceiverNoArgs eventSource when: #anEvent evaluate:[self heardEvent]. eventSource triggerEvent: #anEvent. self should: [succeeded]! ! !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-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 action' stamp: 'jws 9/7/2000 16:39'! testNoArgumentEvent eventSource when: #anEvent send: #heardEvent to: self. eventSource triggerEvent: #anEvent. self should: [succeeded]! ! !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-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 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: '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-dependent value' stamp: 'JWS 9/7/2000 17:21'! testReturnValueWithNoListeners | value | value := eventSource triggerEvent: #needsValue. self should: [value == nil]! ! !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-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: '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-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: '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:19'! getFalse ^false! ! !EventManagerTest methodsFor: 'private' stamp: 'JWS 9/7/2000 17:19'! getFalse: anArg ^false! ! !EventManagerTest methodsFor: 'private' stamp: 'JWS 9/7/2000 17:19'! getTrue ^true! ! !EventManagerTest methodsFor: 'private' stamp: 'JWS 9/7/2000 17:19'! getTrue: anArg ^true! ! !EventManagerTest methodsFor: 'private' stamp: 'JWS 9/7/2000 17:20'! heardEvent succeeded := true! ! SharedPool subclass: #EventSensorConstants instanceVariableNames: '' classVariableNames: 'BlueButtonBit CommandKeyBit CtrlKeyBit EventKeyChar EventKeyDown EventKeyUp EventTypeDragDropFiles EventTypeKeyboard EventTypeMenu EventTypeMouse EventTypeNone EventTypeWindow OptionKeyBit RedButtonBit ShiftKeyBit WindowEventActivated WindowEventClose WindowEventIconise WindowEventMetricChange WindowEventPaint YellowButtonBit' poolDictionaries: '' category: 'Kernel-Processes'! !EventSensorConstants commentStamp: 'LaurentLaffont 3/15/2011 20:48' prior: 0! 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 instanceVariableNames: ''! !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 " ! ! Object subclass: #ExactFloatPrintPolicy instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Numbers'! !ExactFloatPrintPolicy commentStamp: '' prior: 0! 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 ! ! MorphicModel subclass: #ExampleBuilderMorph uses: TEasilyThemed instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !ExampleBuilderMorph commentStamp: 'gvc 7/19/2007 16:49' prior: 0! Morph with an inset border by default and theme access. Overrides openModal: to allow multiple free example dialogs to be presented.! !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'! newAlphaImage: aForm help: helpText "Answer an alpha image morph." ^self theme newAlphaImageIn: self image: aForm help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls'! 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'! 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'! 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'! 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: 'controls'! 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'! 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'! 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: 'controls'! 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'! 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'! 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'! 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'! 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: 'controls'! 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'! 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'! 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'! 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'! 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'! 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'! 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'! 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: 'controls'! 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'! 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'! newButtonLabel: aString "Answer a new button text label." ^self newButtonLabelFor: nil label: aString getEnabled: nil! ! !ExampleBuilderMorph methodsFor: 'controls'! 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'! newCancelButton "Answer a new cancel button." ^self newCancelButtonFor: self! ! !ExampleBuilderMorph methodsFor: 'controls'! newCancelButtonFor: aModel "Answer a new cancel button." ^self theme newCancelButtonIn: self for: aModel! ! !ExampleBuilderMorph methodsFor: 'controls'! 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'! 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'! 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'! newCloseButton "Answer a new close button." ^self newCloseButtonFor: self ! ! !ExampleBuilderMorph methodsFor: 'controls'! newCloseButtonFor: aModel "Answer a new close button." ^self theme newCloseButtonIn: self for: aModel! ! !ExampleBuilderMorph methodsFor: 'controls'! newCloseControlFor: aModel action: aValuable help: helpText "Answer a new cancel button." ^self theme newCloseControlIn: self for: aModel action: aValuable help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls'! 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'! 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'! 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'! newColumn: controls "Answer a morph laid out with a column of controls." ^self theme newColumnIn: self for: controls! ! !ExampleBuilderMorph methodsFor: 'controls'! newDialogPanel "Answer a new main dialog panel." ^self theme newDialogPanelIn: self! ! !ExampleBuilderMorph methodsFor: 'controls'! 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'! 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'! 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: 'controls'! 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: 'controls'! 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'! newEmbeddedMenu "Answer a new menu." ^self theme newEmbeddedMenuIn: self for: self! ! !ExampleBuilderMorph methodsFor: 'controls'! newExpander: aString "Answer an expander with the given label." ^self theme newExpanderIn: self label: aString forAll: #()! ! !ExampleBuilderMorph methodsFor: 'controls'! newExpander: aString for: aControl "Answer an expander with the given label and control." ^self theme newExpanderIn: self label: aString forAll: {aControl}! ! !ExampleBuilderMorph methodsFor: 'controls'! newExpander: aString forAll: controls "Answer an expander with the given label and controls." ^self theme newExpanderIn: self label: aString forAll: controls! ! !ExampleBuilderMorph methodsFor: 'controls'! 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'! 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'! 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: 'controls'! newGroupbox "Answer a plain groupbox." ^self theme newGroupboxIn: self! ! !ExampleBuilderMorph methodsFor: 'controls'! newGroupbox: aString "Answer a groupbox with the given label." ^self theme newGroupboxIn: self label: aString! ! !ExampleBuilderMorph methodsFor: 'controls'! newGroupbox: aString for: control "Answer a groupbox with the given label and control." ^self theme newGroupboxIn: self label: aString for: control! ! !ExampleBuilderMorph methodsFor: 'controls'! newGroupbox: aString forAll: controls "Answer a groupbox with the given label and controls." ^self theme newGroupboxIn: self label: aString forAll: controls! ! !ExampleBuilderMorph methodsFor: 'controls'! newGroupboxFor: control "Answer a plain groupbox with the given control." ^self theme newGroupboxIn: self for: control! ! !ExampleBuilderMorph methodsFor: 'controls'! newGroupboxForAll: controls "Answer a plain groupbox with the given controls." ^self theme newGroupboxIn: self forAll: controls! ! !ExampleBuilderMorph methodsFor: 'controls'! newHSVASelector: aColor help: helpText "Answer a hue-saturation-volume selector with the given color." ^self theme newHSVASelectorIn: self color: aColor help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls'! 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'! 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'! newImage: aForm "Answer a new image." ^self theme newImageIn: self form: aForm! ! !ExampleBuilderMorph methodsFor: 'controls'! newImage: aForm size: aPoint "Answer a new image." ^self theme newImageIn: self form: aForm size: aPoint! ! !ExampleBuilderMorph methodsFor: 'controls'! 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: 'controls'! 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'! newLabel: aString "Answer a new text label." ^self newLabelFor: nil label: aString getEnabled: nil! ! !ExampleBuilderMorph methodsFor: 'controls'! newLabelFor: aModel getLabel: labelSel getEnabled: enabledSel "Answer a new text label." ^self theme newLabelIn: self for: aModel getLabel: labelSel getEnabled: enabledSel! ! !ExampleBuilderMorph methodsFor: 'controls'! newLabelFor: aModel label: aString getEnabled: enabledSel "Answer a new text label." ^self theme newLabelIn: self for: aModel label: aString getEnabled: enabledSel! ! !ExampleBuilderMorph methodsFor: 'controls'! 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'! 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'! 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'! 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'! 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'! newMenu "Answer a new menu." ^self theme newMenuIn: self for: self! ! !ExampleBuilderMorph methodsFor: 'controls'! newMenuFor: aModel "Answer a new menu." ^self theme newMenuIn: self for: aModel! ! !ExampleBuilderMorph methodsFor: 'controls'! 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'! 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'! 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'! 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: 'controls'! 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'! 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'! newNoButton "Answer a new No button." ^self newNoButtonFor: self! ! !ExampleBuilderMorph methodsFor: 'controls'! newNoButtonFor: aModel "Answer a new No button." ^self theme newNoButtonIn: self for: aModel! ! !ExampleBuilderMorph methodsFor: 'controls'! newOKButton "Answer a new OK button." ^self newOKButtonFor: self! ! !ExampleBuilderMorph methodsFor: 'controls'! newOKButtonFor: aModel "Answer a new OK button." ^self newOKButtonFor: aModel getEnabled: nil! ! !ExampleBuilderMorph methodsFor: 'controls'! newOKButtonFor: aModel getEnabled: enabledSel "Answer a new OK button." ^self theme newOKButtonIn: self for: aModel getEnabled: enabledSel! ! !ExampleBuilderMorph methodsFor: 'controls'! 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'! newPanel "Answer a new panel." ^self theme newPanelIn: self! ! !ExampleBuilderMorph methodsFor: 'controls'! newPluggableDialogWindow "Answer a new pluggable dialog." ^self newPluggableDialogWindow: 'Dialog'! ! !ExampleBuilderMorph methodsFor: 'controls'! newPluggableDialogWindow: title "Answer a new pluggable dialog with the given content." ^self newPluggableDialogWindow: title for: nil! ! !ExampleBuilderMorph methodsFor: 'controls'! newPluggableDialogWindow: title for: contentMorph "Answer a new pluggable dialog with the given content." ^self theme newPluggableDialogWindowIn: self title: title for: contentMorph! ! !ExampleBuilderMorph methodsFor: 'controls'! 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'! 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'! newRow "Answer a morph laid out as a row." ^self theme newRowIn: self for: #()! ! !ExampleBuilderMorph methodsFor: 'controls'! newRow: controls "Answer a morph laid out with a row of controls." ^self theme newRowIn: self for: controls! ! !ExampleBuilderMorph methodsFor: 'controls'! newSVSelector: aColor help: helpText "Answer a saturation-volume selector with the given color." ^self theme newSVSelectorIn: self color: aColor help: helpText! ! !ExampleBuilderMorph methodsFor: 'controls'! newScrollPaneFor: aMorph "Answer a new scroll pane morph to scroll the given morph." ^self theme newScrollPaneIn: self for: aMorph! ! !ExampleBuilderMorph methodsFor: 'controls'! newSeparator "Answer an horizontal separator." ^self theme newSeparatorIn: self! ! !ExampleBuilderMorph methodsFor: 'controls'! 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: 'controls'! 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'! 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: 'controls'! newStack "Answer a morph laid out as a stack." ^self theme newStackIn: self for: #()! ! !ExampleBuilderMorph methodsFor: 'controls'! newStack: controls "Answer a morph laid out with a stack of controls." ^self theme newStackIn: self for: controls! ! !ExampleBuilderMorph methodsFor: 'controls'! newString: aStringOrText "Answer a new embossed string." ^self theme newStringIn: self label: aStringOrText font: self theme labelFont style: #plain! ! !ExampleBuilderMorph methodsFor: 'controls'! newString: aStringOrText font: aFont style: aStyle "Answer a new embossed string." ^self theme newStringIn: self label: aStringOrText font: aFont style: aStyle! ! !ExampleBuilderMorph methodsFor: 'controls'! newString: aStringOrText style: aStyle "Answer a new embossed string." ^self theme newStringIn: self label: aStringOrText font: self theme labelFont style: aStyle! ! !ExampleBuilderMorph methodsFor: 'controls'! newTabGroup: labelsAndPages "Answer a tab group with the given tab labels associated with pages." ^self theme newTabGroupIn: self for: labelsAndPages! ! !ExampleBuilderMorph methodsFor: 'controls'! newText: aStringOrText "Answer a new text." ^self theme newTextIn: self text: aStringOrText! ! !ExampleBuilderMorph methodsFor: 'controls'! 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'! 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: 'controls'! 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: 'controls'! 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'! 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'! 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'! 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: 'controls'! 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'! newToolDockingBar "Answer a tool docking bar." ^self theme newToolDockingBarIn: self! ! !ExampleBuilderMorph methodsFor: 'controls'! newToolSpacer "Answer a tool spacer." ^self theme newToolSpacerIn: self! ! !ExampleBuilderMorph methodsFor: 'controls'! newToolbar "Answer a toolbar." ^self theme newToolbarIn: self! ! !ExampleBuilderMorph methodsFor: 'controls'! newToolbar: controls "Answer a toolbar with the given controls." ^self theme newToolbarIn: self for: controls! ! !ExampleBuilderMorph methodsFor: 'controls'! newToolbarHandle "Answer a toolbar handle." ^self theme newToolbarHandleIn: self! ! !ExampleBuilderMorph methodsFor: 'controls'! 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: 'controls'! newVerticalSeparator "Answer a vertical separator." ^self theme newVerticalSeparatorIn: self! ! !ExampleBuilderMorph methodsFor: 'controls'! newWindowFor: aModel title: titleString "Answer a new window morph." ^self theme newWindowIn: self for: aModel title: titleString! ! !ExampleBuilderMorph methodsFor: 'controls'! newWorkArea "Answer a new work area morph." ^self theme newWorkAreaIn: self! ! !ExampleBuilderMorph methodsFor: 'controls'! newYesButton "Answer a new Yes button." ^self newYesButtonFor: self! ! !ExampleBuilderMorph methodsFor: 'controls'! newYesButtonFor: aModel "Answer a new yes button." ^self theme newYesButtonIn: self for: aModel! ! !ExampleBuilderMorph methodsFor: 'services'! abort: aStringOrText "Open an error dialog." ^self abort: aStringOrText title: 'Error' translated! ! !ExampleBuilderMorph methodsFor: 'services'! abort: aStringOrText title: aString "Open an error dialog." ^self theme abortIn: self text: aStringOrText title: aString! ! !ExampleBuilderMorph methodsFor: 'services'! alert: aStringOrText "Open an alert dialog." ^self alert: aStringOrText title: 'Alert' translated! ! !ExampleBuilderMorph methodsFor: 'services'! alert: aStringOrText title: aString "Open an alert dialog." ^self alert: aStringOrText title: aString configure: [:d | ]! ! !ExampleBuilderMorph methodsFor: 'services'! 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: 'services'! 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: 'services'! chooseColor "Answer the result of a color selector dialog ." ^self chooseColor: Color black! ! !ExampleBuilderMorph methodsFor: 'services'! 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: '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: 'services'! chooseDirectory: title "Answer the result of a file dialog with the given title, answer a directory." ^self chooseDirectory: title path: nil! ! !ExampleBuilderMorph methodsFor: 'services'! 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: 'services'! chooseDropList: aStringOrText list: aList "Open a drop list chooser dialog." ^self chooseDropList: aStringOrText title: 'Choose' translated list: aList! ! !ExampleBuilderMorph methodsFor: 'services'! chooseDropList: aStringOrText title: aString list: aList "Open a drop list chooser dialog." ^self theme chooseDropListIn: self text: aStringOrText title: aString list: aList! ! !ExampleBuilderMorph methodsFor: 'services'! 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: 'services'! chooseFont "Answer the result of a font selector dialog." ^self chooseFont: nil! ! !ExampleBuilderMorph methodsFor: 'services'! 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: 'services'! deny: aStringOrText "Open a denial dialog." ^self deny: aStringOrText title: 'Access Denied' translated! ! !ExampleBuilderMorph methodsFor: 'services'! deny: aStringOrText title: aString "Open a denial dialog." ^self theme denyIn: self text: aStringOrText title: aString! ! !ExampleBuilderMorph methodsFor: 'services'! fileOpen: title "Answer the result of a file open dialog with the given title." ^self fileOpen: title extensions: nil! ! !ExampleBuilderMorph methodsFor: 'services'! 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: 'services'! 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: 'services'! 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: 'services'! fileSave: title "Answer the result of a file save dialog with the given title." ^self fileSave: title extensions: nil path: nil! ! !ExampleBuilderMorph methodsFor: 'services'! 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: 'services'! 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: 'services'! 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: 'services'! longMessage: aStringOrText title: aString "Open a (long) message dialog." ^self theme longMessageIn: self text: aStringOrText title: aString! ! !ExampleBuilderMorph methodsFor: 'services'! message: aStringOrText "Open a message dialog." ^self message: aStringOrText title: 'Information' translated! ! !ExampleBuilderMorph methodsFor: 'services'! message: aStringOrText title: aString "Open a message dialog." ^self theme messageIn: self text: aStringOrText title: aString! ! !ExampleBuilderMorph methodsFor: 'services'! proceed: aStringOrText "Open a proceed dialog." ^self proceed: aStringOrText title: 'Proceed' translated! ! !ExampleBuilderMorph methodsFor: 'services'! 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: 'services'! question: aStringOrText "Open a question dialog." ^self question: aStringOrText title: 'Question' translated! ! !ExampleBuilderMorph methodsFor: 'services'! 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'! questionWithoutCancel: aStringOrText "Open a question dialog." ^self questionWithoutCancel: aStringOrText title: 'Question' translated! ! !ExampleBuilderMorph methodsFor: 'services'! 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: 'services'! textEntry: aStringOrText "Open a text entry dialog." ^self textEntry: aStringOrText title: 'Entry' translated! ! !ExampleBuilderMorph methodsFor: 'services'! textEntry: aStringOrText title: aString "Open a text entry dialog." ^self textEntry: aStringOrText title: aString entryText: ''! ! !ExampleBuilderMorph methodsFor: 'services'! textEntry: aStringOrText title: aString entryText: defaultEntryText "Open a text entry dialog." ^self theme textEntryIn: self text: aStringOrText title: aString entryText: defaultEntryText! ! !ExampleBuilderMorph methodsFor: 'theme'! theme "Answer the ui theme that provides controls." ^UITheme current! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ExampleBuilderMorph class uses: TEasilyThemed classTrait instanceVariableNames: ''! Object subclass: #ExampleForTest1 instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Classes'! ExampleForTest1 subclass: #ExampleForTest11 instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Classes'! ExampleForTest11 subclass: #ExampleForTest111 instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Classes'! ExampleForTest11 subclass: #ExampleForTest112 instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Classes'! ExampleForTest1 subclass: #ExampleForTest12 instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Classes'! Object subclass: #ExampleRadioButtonModel instanceVariableNames: 'option' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !ExampleRadioButtonModel commentStamp: 'gvc 9/23/2008 11:58' prior: 0! Model used for radio buttons in example of basic controls (see "UITheme exampleBasicControls").! !ExampleRadioButtonModel methodsFor: 'accessing' stamp: 'gvc 8/7/2007 13:13'! option "Answer the value of option" ^ option! ! !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:17'! beCenter "Set the option to #center." self option: #center! ! !ExampleRadioButtonModel methodsFor: 'as yet unclassified' stamp: 'gvc 8/7/2007 13:17'! beLeft "Set the option to #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: 'as yet unclassified' 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:16'! isCenter "Answer whether the option if #center." ^self option == #center! ! !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:16'! isRight "Answer whether the option if #right." ^self option == #right! ! TestCase subclass: #ExampleSetTest instanceVariableNames: 'full empty' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Tests-Core'! !ExampleSetTest methodsFor: 'running' stamp: 'BaseSystem 8/30/2009 09:40'! setUp empty := Set new. full := Set with: 5 with: #abc! ! !ExampleSetTest methodsFor: 'testing' stamp: 'BaseSystem 8/30/2009 09:40'! testAdd empty add: 5. self assert: (empty includes: 5)! ! !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: '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'! testIncludes self assert: (full includes: 5). self assert: (full includes: #abc)! ! !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'! testRemove full remove: 5. self assert: (full includes: #abc). self deny: (full includes: 5)! ! Object subclass: #Exception instanceVariableNames: 'messageText tag signaler signalContext handlerContext outerContext' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Exceptions'! !Exception commentStamp: 'SvenVanCaekenberghe 4/18/2011 15:17' prior: 0! 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: '*SUnit-Core' stamp: 'jp 3/17/2003 10:03'! sunitExitWith: aValue self return: aValue! ! !Exception methodsFor: 'accessing' stamp: 'ajh 9/30/2001 15:33'! defaultAction "The default action taken if the exception is signaled." self subclassResponsibility! ! !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: 'accessing' stamp: 'StephaneDucasse 2/13/2010 12:18'! messageText "Return an exception's message text." ^ messageText ifNil: [ String empty ]! ! !Exception methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 4/18/2011 15:20'! receiver ^ self signalerContext receiver! ! !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: '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: 'accessing' stamp: 'SvenVanCaekenberghe 4/18/2011 15:20'! signalerContext "Find the first sender of signal(:)" ^ signalContext findContextSuchThat: [ :ctxt | (ctxt receiver == self or: [ ctxt receiver == self class ]) not ]! ! !Exception methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 4/18/2011 15:20'! tag "Return an exception's tag value." ^tag == nil ifTrue: [ self messageText ] ifFalse: [ tag ]! ! !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 9/21/2012 13:52'! debug "open a debugger on myself" ^ Smalltalk tools debugError: self! ! !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: '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: '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 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: 'handling' stamp: 'ajh 1/22/2003 23:04'! resignalAs: replacementException "Signal an alternative exception in place of the receiver." self resumeUnchecked: replacementException signal! ! !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: '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: '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: 'ajh 1/29/2003 13:36'! retry "Abort an exception handler and re-evaluate its protected block." handlerContext restart! ! !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: '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: '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: 'ajh 2/16/2003 17:37'! searchFrom: aContext " Set the context where the handler search will start. " signalContext := aContext contextTag! ! !Exception methodsFor: 'printing' stamp: 'ajh 9/30/2001 15:33'! printOn: stream stream nextPutAll: self description! ! !Exception methodsFor: 'signaling' stamp: 'ajh 9/30/2001 15:33'! messageText: signalerText "Set an exception's message text." messageText := signalerText! ! !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: '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: '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: 'testing' stamp: 'ajh 2/1/2003 00:58'! isResumable "Determine whether an exception is resumable." ^ true! ! !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: '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: 'private' stamp: 'ajh 1/29/2003 13:44'! privHandlerContext: aContextTag handlerContext := aContextTag! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Exception class instanceVariableNames: ''! !Exception class methodsFor: '*Nautilus' stamp: 'BenjaminVanRyseghem 1/2/2013 12:07'! nautilusIcon ^ self nautilusIconClass iconNamed: #exception! ! !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: 'exceptioninstantiator' stamp: 'ajh 9/30/2001 21:54'! signal: signalerText "Signal the occurrence of an exceptional condition with a specified textual description." ^ self new signal: signalerText! ! !Exception class methodsFor: 'exceptionselector' stamp: 'ajh 9/30/2001 15:33'! , anotherException "Create an exception set." ^ExceptionSet new add: self; add: anotherException; yourself! ! !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! ! Object subclass: #ExceptionSet instanceVariableNames: 'exceptions' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Exceptions'! !ExceptionSet commentStamp: '' prior: 0! 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: 'tfei 6/4/1999 18:37'! , 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. ^self! ! !ExceptionSet methodsFor: 'exceptionselector' stamp: 'pnm 8/16/2000 15:15'! handles: anException "Determine whether an exception handler will accept a signaled exception." exceptions do: [:ex | (ex handles: anException) ifTrue: [^true]]. ^false! ! !ExceptionSet methodsFor: 'private' stamp: 'StephaneDucasse 5/6/2010 08:44'! add: anException ^ exceptions add: anException! ! !ExceptionSet methodsFor: 'private' stamp: 'alain.plantec 5/28/2009 09:52'! initialize super initialize. exceptions := OrderedCollection new! ! Object subclass: #ExceptionTester instanceVariableNames: 'log suiteLog iterationsBeforeTimeout' classVariableNames: '' poolDictionaries: '' category: 'Tests-Exceptions'! !ExceptionTester methodsFor: 'accessing' stamp: 'dtl 6/1/2004 21:53'! basicANSISignaledExceptionTestSelectors ^#( simpleIsNestedTest simpleOuterTest doubleOuterTest doubleOuterPassTest doublePassOuterTest simplePassTest simpleResignalAsTest simpleResumeTest simpleRetryTest simpleRetryUsingTest simpleReturnTest)! ! !ExceptionTester methodsFor: 'accessing' stamp: 'brp 10/21/2004 17:54'! basicTestSelectors ^ #(#simpleEnsureTest #simpleEnsureTestWithNotification #simpleEnsureTestWithUparrow #simpleEnsureTestWithError #signalFromHandlerActionTest #resumableFallOffTheEndHandler #nonResumableFallOffTheEndHandler #doubleResumeTest #simpleTimeoutWithZeroDurationTest #simpleTimeoutTest simpleNoTimeoutTest)! ! !ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:14'! doSomethingElseString ^'Do something else.'! ! !ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:14'! doSomethingExceptionalString ^'Do something exceptional.'! ! !ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:13'! doSomethingString ^'Do something.'! ! !ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/8/1999 09:15'! doYetAnotherThingString ^'Do yet another thing.'! ! !ExceptionTester methodsFor: 'accessing' stamp: 'brp 10/21/2004 17:15'! iterationsBeforeTimeout ^ iterationsBeforeTimeout! ! !ExceptionTester methodsFor: 'accessing' stamp: 'brp 10/21/2004 17:16'! iterationsBeforeTimeout: anInteger iterationsBeforeTimeout := anInteger! ! !ExceptionTester methodsFor: 'accessing' stamp: 'tfei 6/7/1999 15:03'! log log == nil ifTrue: [log := OrderedCollection new]. ^log! ! !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: 'logging' stamp: 'tfei 6/8/1999 09:17'! clearLog log := nil! ! !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: 'logging' stamp: 'tfei 6/7/1999 15:03'! log: aString self log add: aString! ! !ExceptionTester methodsFor: 'logging' stamp: 'tfei 6/12/1999 23:07'! logTest: aSelector self suiteLog add: aSelector! ! !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: 'pseudo actions' stamp: 'tfei 6/8/1999 09:13'! doSomething self log: self doSomethingString! ! !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:14'! doSomethingExceptional self log: self doSomethingExceptionalString! ! !ExceptionTester methodsFor: 'pseudo actions' stamp: 'tfei 6/8/1999 09:15'! doYetAnotherThing self log: self doYetAnotherThingString! ! !ExceptionTester methodsFor: 'pseudo actions' stamp: 'tfei 6/8/1999 09:16'! methodWithError MyTestError signal: self testString! ! !ExceptionTester methodsFor: 'pseudo actions' stamp: 'tfei 6/8/1999 09:16'! methodWithNotification MyTestNotification signal: self testString! ! !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: '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: 'tfei 8/19/1999 02:39'! resumableFallOffTheEndHandlerResults ^OrderedCollection new add: self doSomethingString; add: self doSomethingExceptionalString; add: self doYetAnotherThingString; yourself! ! !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: 'results' stamp: 'tfei 6/8/1999 09:47'! simpleEnsureTestResults ^OrderedCollection new add: self doSomethingString; add: self doSomethingElseString; add: self doYetAnotherThingString; yourself! ! !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 10:13'! simpleEnsureTestWithNotificationResults ^OrderedCollection new add: self doSomethingString; add: self doSomethingElseString; 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: 'results' stamp: 'brp 10/21/2004 16:54'! simpleNoTimeoutTestResults ^OrderedCollection new add: self doSomethingString; yourself! ! !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: 'brp 10/21/2004 16:52'! simpleTimeoutWithZeroDurationTestResults ^OrderedCollection new add: self doSomethingElseString; yourself! ! !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 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:09'! simpleIsNestedTestResults ^OrderedCollection new add: self doSomethingString; add: self doYetAnotherThingString; add: self doSomethingElseString; yourself! ! !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 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:11'! simpleResignalAsTestResults ^OrderedCollection new add: self doSomethingString; add: 'Unhandled Exception'; yourself! ! !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:23'! simpleRetryTestResults ^OrderedCollection new add: self doSomethingString; add: self doYetAnotherThingString; add: self doSomethingString; add: self doSomethingElseString; yourself! ! !ExceptionTester methodsFor: 'signaledexception results' stamp: 'tfei 6/13/1999 01:23'! simpleRetryUsingTestResults ^OrderedCollection new add: self doSomethingString; add: self doYetAnotherThingString; yourself! ! !ExceptionTester methodsFor: 'signaledexception results' stamp: 'tfei 6/13/1999 02:22'! simpleReturnTestResults ^OrderedCollection new add: self doSomethingString; add: self doYetAnotherThingString; yourself! ! !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: '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: '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: 'signaledexception tests' stamp: 'tfei 6/13/1999 01:27'! simpleIsNestedTest "uses resignalAs:" [self doSomething. MyTestError signal. self doSomethingElse] on: MyTestError do: [:ex | ex isNested "expecting to detect handler in #runTest:" ifTrue: [self doYetAnotherThing. ex resignalAs: MyTestNotification new]]! ! !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: '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 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: '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: '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: '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: 'suites' stamp: 'tfei 6/13/1999 01:25'! runAllTests "ExceptionTester new runAllTests" self runBasicTests; runBasicANSISignaledExceptionTests! ! !ExceptionTester methodsFor: 'suites' stamp: 'tfei 6/12/1999 23:54'! runBasicANSISignaledExceptionTests self basicANSISignaledExceptionTestSelectors do: [:eachTestSelector | self runTest: eachTestSelector]! ! !ExceptionTester methodsFor: 'suites' stamp: 'tfei 6/9/1999 16:06'! runBasicTests self basicTestSelectors do: [:eachTestSelector | self runTest: eachTestSelector]! ! !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: '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: '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: '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: 'tests' stamp: 'tfei 8/19/1999 01:39'! signalFromHandlerActionTest [self doSomething. MyTestError signal. self doSomethingElse] on: MyTestError do: [self doYetAnotherThing. MyTestError signal]! ! !ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/8/1999 09:44'! simpleEnsureTest [self doSomething. self doSomethingElse] ensure: [self doYetAnotherThing]. ! ! !ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/8/1999 12:50'! simpleEnsureTestWithError [self doSomething. MyTestError signal. self doSomethingElse] ensure: [self doYetAnotherThing]. ! ! !ExceptionTester methodsFor: 'tests' stamp: 'tfei 6/8/1999 10:15'! simpleEnsureTestWithNotification [self doSomething. self methodWithNotification. self doSomethingElse] ensure: [self doYetAnotherThing]. ! ! !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: 'brp 10/22/2004 12:00'! simpleNoTimeoutTest [ self doSomething ] valueWithin: 1 day onTimeout: [ self doSomethingElse ]. ! ! !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: 'tests' stamp: 'brp 10/22/2004 12:00'! simpleTimeoutWithZeroDurationTest [ self doSomething ] valueWithin: 0 seconds onTimeout: [ self doSomethingElse ]. ! ! !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.'! ! TestCase subclass: #ExceptionTests instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Exceptions'! !ExceptionTests methodsFor: 'testing' stamp: 'brp 10/21/2004 16:42'! testNoTimeout self assertSuccess: (ExceptionTester new runTest: #simpleNoTimeoutTest ) ! ! !ExceptionTests methodsFor: 'testing' stamp: 'brp 10/21/2004 16:41'! testTimeoutWithZeroDuration self assertSuccess: (ExceptionTester new runTest: #simpleTimeoutWithZeroDurationTest ) ! ! !ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'dtl 6/1/2004 21:54'! testDoubleOuterPass self assertSuccess: (ExceptionTester new runTest: #doubleOuterPassTest ) ! ! !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:43'! testDoubleResume self assertSuccess: (ExceptionTester new runTest: #doubleResumeTest ) ! ! !ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:44'! testNonResumableFallOffTheEndHandler self assertSuccess: (ExceptionTester new runTest: #nonResumableFallOffTheEndHandler ) ! ! !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:44'! testSignalFromHandlerActionTest self assertSuccess: (ExceptionTester new runTest: #signalFromHandlerActionTest ) ! ! !ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:48'! testSimpleEnsure self assertSuccess: (ExceptionTester new runTest: #simpleEnsureTest ) ! ! !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:46'! testSimpleEnsureTestWithNotification self assertSuccess: (ExceptionTester new runTest: #simpleEnsureTestWithNotification ) ! ! !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:46'! testSimpleIsNested self assertSuccess: (ExceptionTester new runTest: #simpleIsNestedTest ) ! ! !ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:41'! testSimpleOuter self assertSuccess: (ExceptionTester new runTest: #simpleOuterTest ) ! ! !ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:42'! testSimplePass self assertSuccess: (ExceptionTester new runTest: #simplePassTest ) ! ! !ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:43'! testSimpleResignalAs self assertSuccess: (ExceptionTester new runTest: #simpleResignalAsTest ) ! ! !ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:48'! testSimpleResume self assertSuccess: (ExceptionTester new runTest: #simpleResumeTest ) ! ! !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:47'! testSimpleRetryUsing self assertSuccess: (ExceptionTester new runTest: #simpleRetryUsingTest ) ! ! !ExceptionTests methodsFor: 'testing-exceptiontester' stamp: 'md 3/25/2003 23:48'! testSimpleReturn self assertSuccess: (ExceptionTester new runTest: #simpleReturnTest ) ! ! !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-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-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-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: 'private' stamp: 'md 3/25/2003 23:40'! assertSuccess: anExceptionTester self should: [ ( anExceptionTester suiteLog first) endsWith: 'succeeded'].! ! NonReentrantWeakMessageSend weakSubclass: #ExclusiveWeakMessageSend instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-EventEnhancements'! !ExclusiveWeakMessageSend commentStamp: 'LaurentLaffont 4/15/2011 20:18' prior: 0! See NonReentrantWeakMessageSend! !ExclusiveWeakMessageSend methodsFor: 'accessing' stamp: 'gvc 10/25/2006 18:07'! executing "Answer from the shared value holder." ^executing contents! ! !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 methodsFor: 'initialize-release' stamp: 'gvc 10/25/2006 18:13'! initialize "Initialize the receiver." executing := self class newSharedState. super initialize.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ExclusiveWeakMessageSend class instanceVariableNames: ''! !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! ! PanelMorph subclass: #ExpanderMorph instanceVariableNames: 'titleMorph announcer' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !ExpanderMorph commentStamp: 'gvc 5/18/2007 13:13' prior: 0! A morph that can expand or collapse to show its contents.! !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: 'accessing' stamp: 'GaryChambers 1/25/2011 13:40'! announcer: anObject announcer := anObject! ! !ExpanderMorph methodsFor: 'accessing' stamp: 'gvc 7/27/2006 10:30'! titleMorph "Answer the value of titleMorph" ^ titleMorph! ! !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: '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: '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: '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 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:23'! expanded: aBoolean "Set whether the title is expanded." self titleMorph expanded: aBoolean! ! !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 10/18/2006 11:57'! fixLayout "Fix the owner layout, nasty!!" self owner ifNil: [^self]. self owner allMorphsDo: [:m | (m respondsTo: #resetExtent) ifTrue: [ WorldState addDeferredUIMessage: (MessageSend receiver: m selector: #resetExtent). WorldState addDeferredUIMessage: (MessageSend receiver: m selector: #setScrollDeltas)]. (m isKindOf: self class) ifTrue: [WorldState addDeferredUIMessage: (MessageSend receiver: m selector: #adoptPaneColor)]]. WorldState addDeferredUIMessage: (MessageSend receiver: self owner selector: #changed)! ! !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 9/13/2006 10:30'! font: aFont "Set the title font" self titleMorph font: aFont! ! !ExpanderMorph methodsFor: 'as yet unclassified' 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:32'! showMorphs: aBoolean "Hide/Show the other morphs." self submorphs do: [:m | m == self titleMorph ifFalse: [ m visible: aBoolean; disableTableLayout: aBoolean not]]! ! !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/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 class instanceVariableNames: ''! !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! ! Announcement subclass: #ExpanderMorphAnnouncement instanceVariableNames: 'expanderMorph' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !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 instanceVariableNames: ''! !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! ! ExpanderMorphAnnouncement subclass: #ExpanderMorphContracted instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !ExpanderMorphContracted commentStamp: 'LaurentLaffont 4/15/2011 20:18' prior: 0! 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}.! ExpanderMorphAnnouncement subclass: #ExpanderMorphExpanded instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! PanelMorph subclass: #ExpanderTitleMorph instanceVariableNames: 'labelMorph buttonMorph expanded' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !ExpanderTitleMorph commentStamp: 'gvc 5/18/2007 13:12' prior: 0! The titlebar area for and ExpanderMorph. Includes title label and expand/collapse button.! !ExpanderTitleMorph methodsFor: 'accessing' stamp: 'gvc 1/22/2009 15:37'! buttonMorph "Answer the value of buttonMorph" ^ buttonMorph! ! !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:16'! expanded "Answer the value of expanded" ^ expanded! ! !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: 'accessing' stamp: 'gvc 9/13/2006 10:23'! labelMorph "Answer the value of labelMorph" ^ labelMorph! ! !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: '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: '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 9/23/2006 16:46'! defaultBorderStyle "Answer the default border style for the receiver." ^BorderStyle raised width: 1! ! !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: '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: '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 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: '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: '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: 'GaryChambers 7/27/2011 17:10'! newLabelMorph "Answer a new label morph for the receiver." ^LabelMorph new hResizing: #spaceFill; vResizing: #shrinkWrap! ! !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 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: '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: ['']! ! !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: 'as yet unclassified' stamp: 'gvc 7/27/2006 10:23'! toggleExpanded "Toggle the expanded state." self expanded: self expanded not! ! SystemAnnouncement subclass: #ExpressionEvaluated instanceVariableNames: 'context expressionEvaluated' classVariableNames: '' poolDictionaries: '' category: 'System-Announcements'! !ExpressionEvaluated commentStamp: '' prior: 0! This announcement correspond to code evaluation. For example, a DoIt or PrintIt evaluated in a workspace raises one of this announcements.! !ExpressionEvaluated methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:42'! context ^ context! ! !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 ^ expressionEvaluated! ! !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:42'! expression ^self expressionEvaluated! ! !ExpressionEvaluated methodsFor: 'temporal for remove' stamp: 'GuillermoPolito 8/2/2012 00:50'! item ^expressionEvaluated! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ExpressionEvaluated class instanceVariableNames: ''! !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! ! SqNumberParser subclass: #ExtendedNumberParser instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Numbers'! !ExtendedNumberParser commentStamp: 'nice 2/13/2010 00:39' prior: 0! An ExtendedNumberParser is extending Squeak number syntax with these rules - allow partial specification of integer and fraction parts: 1.e2 .1e3 are both 100.0 - allow plus sign before number and in exponent ! !ExtendedNumberParser methodsFor: 'accessing' stamp: 'nice 2/13/2010 00:40'! allowPlusSign ^true! ! !ExtendedNumberParser methodsFor: 'parsing-private' stamp: 'nice 2/13/2010 00:57'! 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, but can be a 1.e2 syntax" fractionPart := 0. numberOfNonZeroFractionDigits := 0. numberOfTrailingZeroInFractionPart := 0] ifNotNil: [. numberOfNonZeroFractionDigits := lastNonZero. numberOfTrailingZeroInFractionPart := nDigits - lastNonZero]. self readExponent ifFalse: [self readScale 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]! ! !ExtendedNumberParser methodsFor: 'parsing-private' stamp: 'nice 2/13/2010 01:55'! readNumberWithoutIntegerPart "at this stage, sign followed by a decimal point have been read, but no intergerPart try and form a number with a fractionPart" ^self readNumberWithoutIntegerPartOrNil ifNil: [ "No integer part, no fractionPart, this does not look like a number..." ^self expected: 'a digit between 0 and 9'].! ! !ExtendedNumberParser methodsFor: 'parsing-private' stamp: 'nice 2/13/2010 01:54'! readNumberWithoutIntegerPartOrNil "at this stage, sign followed by a decimal point have been read, but no intergerPart try and form a number with a fractionPart" | numberOfNonZeroFractionDigits numberOfTrailingZeroInFractionPart mantissa value | integerPart := 0. fractionPart := self nextUnsignedIntegerOrNilBase: base. fractionPart ifNil: [ "No integer part, no fractionPart, this does not look like a number..." ^nil]. numberOfNonZeroFractionDigits := lastNonZero. numberOfTrailingZeroInFractionPart := nDigits - lastNonZero. self readExponent ifFalse: [self readScale ifTrue: [^self makeScaledDecimalWithNumberOfNonZeroFractionDigits: numberOfNonZeroFractionDigits andNumberOfTrailingZeroInFractionPart: numberOfTrailingZeroInFractionPart]]. fractionPart isZero ifTrue: [mantissa := 0] ifFalse: [mantissa := (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]! ! !ExtendedNumberParser methodsFor: 'parsing-public' stamp: 'nice 10/30/2011 16:18'! 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! ! !ExtendedNumberParser methodsFor: 'parsing-public' stamp: 'nice 2/13/2010 02:10'! 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: [(sourceStream peekFor: $.) ifTrue: [ "Try .1 syntax" ^self readNumberWithoutIntegerPart] ifFalse: [ "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" | 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: [ (sourceStream peekFor: $.) ifTrue: [self readNumberWithoutIntegerPartOrNil ifNotNil: [:aNumber | ^aNumber]]. sourceStream position: pos. ^oldNeg ifTrue: [base negated] ifFalse: [base]]. numberOfTrailingZeroInIntegerPart := nDigits - lastNonZero]. ^ (sourceStream peekFor: $.) ifTrue: [self readNumberWithFractionPartNumberOfTrailingZeroInIntegerPart: numberOfTrailingZeroInIntegerPart] ifFalse: [self makeIntegerOrScaledInteger]! ! ClassTestCase subclass: #ExtendedNumberParserTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Numbers'! !ExtendedNumberParserTest methodsFor: 'testing' stamp: 'nice 2/13/2010 02:25'! testFractionPartWithoutIntegerPart "The integer part before the decimal is optional" self assert: (ExtendedNumberParser parse: '.5') = (1/2). self assert: (ExtendedNumberParser parse: '.5') isFloat. self assert: (ExtendedNumberParser parse: '.3e2') = 30. self assert: (ExtendedNumberParser parse: '.3e2') isFloat. self assert: (ExtendedNumberParser parse: '-.4e2') = -40. self assert: (ExtendedNumberParser parse: '-.4e2') isFloat. self assert: (ExtendedNumberParser parse: '+.5e2') = 50. self assert: (ExtendedNumberParser parse: '+.5e2') isFloat. self assert: (ExtendedNumberParser parse: '+.6e+2') = 60. self assert: (ExtendedNumberParser parse: '+.6e+2') isFloat. self assert: (ExtendedNumberParser parse: '-.7e+2') = -70. self assert: (ExtendedNumberParser parse: '-.7e+2') isFloat. self assert: (ExtendedNumberParser parse: '+2r.1e-2') = (1/8). self assert: (ExtendedNumberParser parse: '+2r.1e-2') isFloat. self assert: (ExtendedNumberParser parse: '-4r.1e-2') = (-1/64). self assert: (ExtendedNumberParser parse: '-4r.1e-2') isFloat.! ! !ExtendedNumberParserTest methodsFor: 'testing' stamp: 'nice 2/13/2010 02:25'! testIntegerPartWithoutFraction "The fraction part after the decimal is optional" self assert: (ExtendedNumberParser parse: '1.') = 1. self assert: (ExtendedNumberParser parse: '1.') isFloat. self assert: (ExtendedNumberParser parse: '3.e2') = 300. self assert: (ExtendedNumberParser parse: '3.e2') isFloat. self assert: (ExtendedNumberParser parse: '-4.e2') = -400. self assert: (ExtendedNumberParser parse: '-4.e2') isFloat. self assert: (ExtendedNumberParser parse: '+5.e2') = 500. self assert: (ExtendedNumberParser parse: '+5.e2') isFloat. self assert: (ExtendedNumberParser parse: '+6.e+2') = 600. self assert: (ExtendedNumberParser parse: '+6.e+2') isFloat. self assert: (ExtendedNumberParser parse: '-7.e+2') = -700. self assert: (ExtendedNumberParser parse: '-7.e+2') isFloat. self assert: (ExtendedNumberParser parse: '+2r1.e-2') = (1/4). self assert: (ExtendedNumberParser parse: '+2r1.e-2') isFloat. self assert: (ExtendedNumberParser parse: '-4r1.e-2') = (-1/16). self assert: (ExtendedNumberParser parse: '-4r1.e-2') isFloat.! ! !ExtendedNumberParserTest methodsFor: 'testing' stamp: 'nice 2/13/2010 02:23'! testInvalidExponent "The leading number is returned, the invalid part is ignored" self assert: (ExtendedNumberParser parse: '1e') = 1. self assert: (ExtendedNumberParser parse: '1eZ') = 1. self assert: (ExtendedNumberParser parse: '+1eW') = 1. self assert: (ExtendedNumberParser parse: '-1eX') = -1. self assert: (ExtendedNumberParser parse: '2e-') = 2. self assert: (ExtendedNumberParser parse: '2e--1') = 2. self assert: (ExtendedNumberParser parse: '2e-+1') = 2. self assert: (ExtendedNumberParser parse: '2e-Z') = 2. self assert: (ExtendedNumberParser parse: '+2e-W') = 2. self assert: (ExtendedNumberParser parse: '-2e-X') = -2. self assert: (ExtendedNumberParser parse: '3e+') = 3. self assert: (ExtendedNumberParser parse: '3e+-') = 3. self assert: (ExtendedNumberParser parse: '3e+-1') = 3. self assert: (ExtendedNumberParser parse: '+3e+W') = 3. self assert: (ExtendedNumberParser parse: '-3e+Z') = -3.! ! !ExtendedNumberParserTest methodsFor: 'testing' stamp: 'nice 2/13/2010 02:08'! testInvalidRadix "The leading number is returned, the invalid part is ignored" self assert: (ExtendedNumberParser parse: '1r') = 1. self assert: (ExtendedNumberParser parse: '+1r') = 1. self assert: (ExtendedNumberParser parse: '-1r') = -1. self assert: (ExtendedNumberParser parse: '-1r+') = -1. self assert: (ExtendedNumberParser parse: '-1r-') = -1. self assert: (ExtendedNumberParser parse: '-2r.') = -2. self assert: (ExtendedNumberParser parse: '-2r-.') = -2. self assert: (ExtendedNumberParser parse: '+2r-.') = 2. self assert: (ExtendedNumberParser parse: '+2r3.') = 2. self assert: (ExtendedNumberParser parse: '+2r.3') = 2. self assert: (ExtendedNumberParser parse: '+2r-.3') = 2.! ! !ExtendedNumberParserTest methodsFor: 'testing' stamp: 'nice 2/13/2010 02:24'! testInvalidScale "The leading number is returned, the invalid part is ignored" self assert: (ExtendedNumberParser parse: '1s') = 1. self assert: (ExtendedNumberParser parse: '1sZ') = 1. self assert: (ExtendedNumberParser parse: '+1sW') = 1. self assert: (ExtendedNumberParser parse: '-1sX') = -1. self assert: (ExtendedNumberParser parse: '2s-') = 2. self assert: (ExtendedNumberParser parse: '2s--1') = 2. self assert: (ExtendedNumberParser parse: '2s-+1') = 2. self assert: (ExtendedNumberParser parse: '2s-1') = 2. self assert: (ExtendedNumberParser parse: '+2s-2') = 2. self assert: (ExtendedNumberParser parse: '-2s-3') = -2. self assert: (ExtendedNumberParser parse: '3s+') = 3. self assert: (ExtendedNumberParser parse: '3s+-') = 3. self assert: (ExtendedNumberParser parse: '3s+-1') = 3. self assert: (ExtendedNumberParser parse: '+3s+2') = 3. self assert: (ExtendedNumberParser parse: '-3s+3') = -3.! ! !ExtendedNumberParserTest methodsFor: 'testing' stamp: 'nice 2/13/2010 02:26'! testPositive "A leading + sign is allowed" self assert: (ExtendedNumberParser parse: '+1') = 1. self assert: (ExtendedNumberParser parse: '+22') = 22. self assert: (ExtendedNumberParser parse: '+2r11') = 3. self assert: (ExtendedNumberParser parse: '+2r+101') = 5. self assert: (ExtendedNumberParser parse: '+2r-101') = -5. self assert: (ExtendedNumberParser parse: '-2r+101') = -5. self assert: (ExtendedNumberParser parse: '+1.') isFloat. self assert: (ExtendedNumberParser parse: '+1.') = 1. self assert: (ExtendedNumberParser parse: '+21.') = 21. self assert: (ExtendedNumberParser parse: '+3r21.') = 7. self assert: (ExtendedNumberParser parse: '+3r+201.') = 19. self assert: (ExtendedNumberParser parse: '+3r-201.') = -19. self assert: (ExtendedNumberParser parse: '-3r+201.') = -19.! ! !ExtendedNumberParserTest methodsFor: 'testing' stamp: 'nice 2/13/2010 02:27'! testPositiveExponent "A leading + sign is allowed in exponent" self assert: (ExtendedNumberParser parse: '1e+2') = 100. self assert: (ExtendedNumberParser parse: '1e+2') isInteger. self assert: (ExtendedNumberParser parse: '-1e+2') = -100. self assert: (ExtendedNumberParser parse: '1.e+2') = 100. self assert: (ExtendedNumberParser parse: '1.e+2') isFloat. self assert: (ExtendedNumberParser parse: '-1.0e+2') = -100.! ! TabPanelBorder subclass: #ExtendedTabPanelBorder instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Themes'! !ExtendedTabPanelBorder commentStamp: '' prior: 0! 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"! ! Clipboard subclass: #ExternalClipboard instanceVariableNames: 'clipboard' classVariableNames: '' poolDictionaries: '' category: 'System-Clipboard'! !ExternalClipboard commentStamp: 'michael.rueger 3/2/2009 13:25' prior: 0! 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: 'accessing' stamp: 'michael.rueger 3/2/2009 13:42'! clearClipboard clipboard = 0 ifTrue: [^self]. ^ self primClearClipboard: clipboard.! ! !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: '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: 'initialize' 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/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: 'primitives' stamp: 'michael.rueger 3/25/2009 14:25'! primAddClipboardData: aClipboard data: data dataFormat: aFormat ^ self primitiveFailed! ! !ExternalClipboard methodsFor: 'primitives' stamp: 'michael.rueger 3/2/2009 13:42'! primClearClipboard: aClipboard ^ self primitiveFailed. ! ! !ExternalClipboard methodsFor: 'primitives' stamp: 'michael.rueger 3/2/2009 13:42'! primCreateClipboard ^ self primitiveFailed. ! ! !ExternalClipboard methodsFor: 'primitives' stamp: 'michael.rueger 3/25/2009 14:25'! primGetClipboardFormat: aClipboard formatNumber: formatNumber ^ self primitiveFailed! ! !ExternalClipboard methodsFor: 'primitives' stamp: 'marcus.denker 6/11/2009 12:24'! primReadClipboardData: aClipboard format: format ^ self primitiveFailed! ! !ExternalClipboard methodsFor: 'private' stamp: 'michael.rueger 3/2/2009 13:42'! createClipboard clipboard = 0 ifTrue: [^self]. ^ self primCreateClipboard.! ! Object subclass: #ExternalDropHandler instanceVariableNames: 'action type extension' classVariableNames: 'DefaultHandler RegisteredHandlers' poolDictionaries: '' category: 'System-Support'! !ExternalDropHandler methodsFor: 'accessing'! extension ^extension! ! !ExternalDropHandler methodsFor: 'accessing'! handle: dropStream in: pasteUp dropEvent: anEvent ^action cull: dropStream cull: pasteUp cull: anEvent ! ! !ExternalDropHandler methodsFor: 'accessing'! type ^type! ! !ExternalDropHandler methodsFor: 'initialize'! type: aType extension: anExtension action: anAction action := anAction. type := aType. extension := anExtension! ! !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'! matchesTypes: types (self type isNil or: [types isNil]) ifTrue: [^false]. ^types anySatisfy: [:mimeType | mimeType beginsWith: self type]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ExternalDropHandler class instanceVariableNames: ''! !ExternalDropHandler class methodsFor: 'accessing'! defaultHandler DefaultHandler ifNil: [DefaultHandler := ExternalDropHandler type: nil extension: nil action: [:dropStream | dropStream edit]]. ^DefaultHandler! ! !ExternalDropHandler class methodsFor: 'accessing'! defaultHandler: externalDropHandler DefaultHandler := externalDropHandler! ! !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: '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: 'accessing'! registerHandler: aHandler self registeredHandlers add: aHandler! ! !ExternalDropHandler class methodsFor: 'initialization' stamp: 'PavelKrivanek 11/20/2012 21:25'! initialize "ExternalDropHandler initialize" self resetRegisteredHandlers. ! ! !ExternalDropHandler class methodsFor: 'instance creation'! type: aType extension: anExtension action: anAction ^self new type: aType extension: anExtension action: anAction ! ! !ExternalDropHandler class methodsFor: 'private'! 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'! registeredHandlers RegisteredHandlers ifNil: [RegisteredHandlers := OrderedCollection new]. ^RegisteredHandlers! ! !ExternalDropHandler class methodsFor: 'private'! resetRegisteredHandlers RegisteredHandlers := nil! ! !ExternalDropHandler class methodsFor: 'private'! unwantedSelectors "private - answer a collection well known unwanted selectors " ^ #(#removeLineFeeds: #addFileToNewZip: #compressFile: #putUpdate: )! ! Object subclass: #ExternalSemaphoreTable instanceVariableNames: '' classVariableNames: 'ProtectAdd ProtectRemove' poolDictionaries: '' category: 'System-Support'! !ExternalSemaphoreTable commentStamp: 'HenrikSperreJohansen 8/18/2011 11:25' prior: 0! 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 instanceVariableNames: ''! !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: '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].! ! !ExternalSemaphoreTable class methodsFor: 'accessing' stamp: 'HenrikSperreJohansen 8/17/2011 14:55'! registerExternalObject: anObject ^ ProtectAdd critical: [self safelyRegisterExternalObject: anObject] ! ! !ExternalSemaphoreTable class methodsFor: 'accessing' stamp: 'HenrikSperreJohansen 8/18/2011 10:24'! 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 obj sz newObjects | 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 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: 'HenrikSperreJohansen 8/17/2011 14:55'! unregisterExternalObject: anObject ProtectRemove critical: [self safelyUnregisterExternalObject: anObject] ! ! !ExternalSemaphoreTable class methodsFor: 'initialize' stamp: 'HenrikSperreJohansen 8/17/2011 14:54'! initialize ProtectAdd := Semaphore forMutualExclusion. ProtectRemove := Semaphore forMutualExclusion! ! !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: 'StephaneDucasse 11/20/2011 15:32'! 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: TimeStamp 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: 'private' stamp: 'HenrikSperreJohansen 8/18/2011 10:20'! 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 == nil and: [obj == nil]) ifTrue: [firstEmptyIndex := i]]. ^firstEmptyIndex! ! !ExternalSemaphoreTable class methodsFor: 'private' stamp: 'HenrikSperreJohansen 8/16/2011 14:45'! unprotectedExternalObjects ^Smalltalk specialObjectsArray at: 39! ! !ExternalSemaphoreTable class methodsFor: 'private' stamp: 'HenrikSperreJohansen 8/16/2011 14:45'! unprotectedExternalObjects: aCollection ^Smalltalk specialObjectsArray at: 39 put: aCollection! ! TestCase subclass: #FIFOQueueTests instanceVariableNames: 'count' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Atomic'! !FIFOQueueTests methodsFor: 'instance creation' stamp: 'IgorStasenko 11/2/2010 01:39'! newQueue ^ WaitfreeQueue new! ! !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: '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: '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: '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: '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: '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: '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/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 ! ! !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: '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: '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! ! FLObjectCluster subclass: #FLAbstractCollectionCluster instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Clusters-Optionals'! !FLAbstractCollectionCluster commentStamp: '' prior: 0! A FLAbstractCollectionCluster is the common behavior for all cluster collections. ! !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:06'! materializeInstanceWith: aDecoder ^theClass new: aDecoder nextEncodedPositiveInteger! ! !FLAbstractCollectionCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 2/25/2013 14:44'! materializeReferencesOf: anObject with: aDecoder "Hook method" self subclassResponsibility! ! !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: 'MartinDias 2/25/2013 14:44'! serializeReferencesOf: anObject with: anEncoder ^ self subclassResponsibility ! ! !FLAbstractCollectionCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 7/26/2012 14:22'! serializeReferencesStepWith: anEncoder objects do: [ :anObject | self serializeReferencesOf: anObject with: anEncoder ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FLAbstractCollectionCluster class instanceVariableNames: ''! !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! ! Object subclass: #FLAnalysis instanceVariableNames: 'objectStack firstMapper clusterization root privateObjectStack privateFirstMapper' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Core'! !FLAnalysis commentStamp: 'MartinDias 8/29/2011 19:15' prior: 0! 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: 'accessing' stamp: 'MartinDias 9/9/2011 21:47'! clusterization ^clusterization! ! !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: 'hooks' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^ aGeneralMapper visitSubstitution: self by: nil! ! !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: 'MartinDias 1/8/2012 12:36'! mapAndTrace: anObject "Map an object to its cluster. Trace its references." firstMapper mapAndTrace: anObject! ! !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: 'tracing' stamp: 'MarianoMartinezPeck 9/18/2012 10:58'! privateTrace: anObject privateObjectStack push: anObject! ! !FLAnalysis methodsFor: 'tracing' stamp: 'MartinDias 8/20/2011 22:11'! trace: anObject objectStack push: anObject! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FLAnalysis class instanceVariableNames: ''! !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.! ! Object subclass: #FLAnalyzer instanceVariableNames: 'internalClasses pluggableSubstitutions globalMappersFactory analysisFactory generalMapperFactory globalSymbols internalMethods globalMappers globalEnvironment' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Core'! !FLAnalyzer commentStamp: 'MartinDias 8/29/2011 19:15' prior: 0! 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: '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: 'accessing' stamp: 'MartinDias 2/25/2013 11:26'! globalEnvironment: aDictionary globalEnvironment := aDictionary ! ! !FLAnalyzer methodsFor: 'accessing' stamp: 'MartinDias 9/11/2011 11:22'! globalMappers ^globalMappersFactory value! ! !FLAnalyzer methodsFor: 'accessing' stamp: 'MartinDias 5/21/2012 12:30'! useLightMappers globalMappersFactory := [self lightGlobalMappers]. generalMapperFactory := [FLLightGeneralMapper new].! ! !FLAnalyzer methodsFor: 'analyzing' stamp: 'MartinDias 9/14/2011 00:15'! analysisFor: anObject ^analysisFactory value: anObject! ! !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: 'configuring' stamp: 'MartinDias 12/30/2011 19:25'! considerGlobal: aSymbol globalSymbols add: aSymbol! ! !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: 'configuring' stamp: 'MartinDias 9/10/2011 17:04'! when: aCondition substituteBy: aFactory pluggableSubstitutions add: aCondition -> aFactory! ! !FLAnalyzer methodsFor: 'defaults' stamp: 'MarianoMartinezPeck 12/14/2011 20:43'! generalMapper ^generalMapperFactory value! ! !FLAnalyzer methodsFor: 'hooks' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^ aGeneralMapper visitSubstitution: self by: nil! ! !FLAnalyzer methodsFor: 'initialize-release' 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: 'protected' stamp: 'MartinDias 1/10/2012 14:25'! firstInMapperChain ^ self mappers first ! ! !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 methodsFor: 'protected' stamp: 'MartinDias 9/10/2011 17:55'! pluggableSubstitutionMappers ^pluggableSubstitutions collect: [:aLink | FLPluggableSubstitutionMapper when: aLink key substituteBy: aLink value]! ! !FLAnalyzer methodsFor: 'protected' stamp: 'MarianoMartinezPeck 9/18/2012 11:00'! privateFirstInMapperChain ^ self privateMappers first ! ! !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: 'protected' stamp: 'MarianoMartinezPeck 9/18/2012 11:00'! setDefaultAnalysis analysisFactory := [:anObject | (FLAnalysis newWith: self firstInMapperChain private: self privateFirstInMapperChain root: anObject) run; yourself ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FLAnalyzer class instanceVariableNames: ''! !FLAnalyzer class methodsFor: 'accessing' stamp: 'MartinDias 2/21/2013 16:55'! defaultGlobalSymbols ^ #(#Smalltalk #SourceFiles #Transcript #Undeclared #Display #TextConstants #ActiveWorld #ActiveHand #ActiveEvent #Sensor #Processor #ImageImports #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! ! FLMaterializationError subclass: #FLBadSignature instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Errors'! !FLBadSignature commentStamp: 'MarianoMartinezPeck 10/23/2011 14:32' prior: 0! 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 instanceVariableNames: ''! !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, '.'! ! FLMaterializationError subclass: #FLBadVersion instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Errors'! !FLBadVersion commentStamp: 'MarianoMartinezPeck 10/23/2011 14:33' prior: 0! 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 instanceVariableNames: ''! !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, '.' ! ! FLSerializationTest subclass: #FLBasicSerializationTest instanceVariableNames: 'currentTimeZone' classVariableNames: '' poolDictionaries: '' category: 'FuelTests'! !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: 'running' stamp: 'MaxLeske 10/18/2012 07:42'! setUp super setUp. currentTimeZone := DateAndTime localTimeZone.! ! !FLBasicSerializationTest methodsFor: 'running' stamp: 'MaxLeske 10/18/2012 07:42'! tearDown super tearDown. DateAndTime localTimeZone: currentTimeZone! ! !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' 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' stamp: 'MarianoMartinezPeck 9/28/2011 17:40'! testClasses "When we serialize this way, classes should be considered as globals." self assertSerializationEqualityOf: Collection withAllSubclasses asArray. ! ! !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 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: '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: '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' 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 9/9/2011 01:40'! testDuration self assertSerializationEqualityOf: 123 seconds. self assertSerializationEqualityOf: -123 seconds. self assertSerializationEqualityOf: ( Duration seconds: 3 nanoSeconds: 35). ! ! !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: 'MartinDias 10/17/2010 20:59'! testFalse self assertSerializationIdentityOf: false! ! !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' 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' stamp: 'MartinDias 6/3/2011 20:27'! testLotsOfNils self assertSerializationEqualityOf: (Array new: 1 << 16).! ! !FLBasicSerializationTest methodsFor: 'tests' stamp: 'MartinDias 10/17/2010 20:56'! testNil self assertSerializationIdentityOf: nil! ! !FLBasicSerializationTest methodsFor: 'tests' stamp: 'MartinDias 11/25/2010 18:40'! testPair self assertSerializationEqualityOf: (FLPair new left: 10; right: 20; yourself)! ! !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: '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' 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' 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' 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' stamp: 'MartinDias 10/17/2010 20:59'! testTrue self assertSerializationIdentityOf: true! ! !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' 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-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-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/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-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-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-collections' stamp: 'MartinDias 10/17/2010 20:59'! testDictionary self assertSerializationEqualityOf: (Dictionary with: 1->2).! ! !FLBasicSerializationTest methodsFor: 'tests-collections' stamp: 'MartinDias 10/26/2010 19:46'! testEmptyArray self assertSerializationEqualityOf: #()! ! !FLBasicSerializationTest methodsFor: 'tests-collections' stamp: 'MartinDias 10/26/2010 19:45'! testEmptyDictionary self assertSerializationEqualityOf: Dictionary new! ! !FLBasicSerializationTest methodsFor: 'tests-collections' stamp: 'MartinDias 10/26/2010 19:46'! testEmptyOrderedCollection self assertSerializationEqualityOf: OrderedCollection new! ! !FLBasicSerializationTest methodsFor: 'tests-collections' stamp: 'MartinDias 6/5/2011 01:52'! testEmptySet self assertSerializationEqualityOf: Set new! ! !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: 'MarianoMartinezPeck 4/20/2012 21:37'! testMethodDictionary self resultOfSerializeAndMaterializeMethodDictionary: FLPair methodDict. ! ! !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-collections' stamp: 'MartinDias 9/29/2010 11:27'! testOrderedCollection self assertSerializationEqualityOf: (OrderedCollection with: 10 with: 20)! ! !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-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-collections' stamp: 'MartinDias 3/21/2011 16:10'! testWordArray self assertSerializationEqualityOf: (WordArray with: 10 with: 20)! ! !FLBasicSerializationTest methodsFor: 'tests-collections-Pharo1.3' stamp: 'MartinDias 9/9/2011 12:49'! testSetElement self assertSerializationEqualityOf: (SetElement with: 3)! ! !FLBasicSerializationTest methodsFor: 'tests-collections-Pharo1.3' stamp: 'MartinDias 8/13/2011 20:58'! testSetWithNil self assertSerializationEqualityOf: (Set with: nil)! ! !FLBasicSerializationTest methodsFor: 'tests-collections-Pharo1.3' stamp: 'MartinDias 8/13/2011 21:00'! testSetWithSetElement self assertSerializationEqualityOf: (Set with: (SetElement with: 3))! ! !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-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-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-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-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-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-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-globals' stamp: 'MartinDias 12/15/2011 15:41'! testCompiledMethod "They should be considered as globals by default." self assertSerializationIdentityOf: FLPair >> #left ! ! !FLBasicSerializationTest methodsFor: 'tests-globals' stamp: 'MartinDias 1/10/2012 14:29'! testConsiderCustomGlobal "A custom global variable is treated as global by Fuel, when we explicitly specify this." | aPerson | self analyzer considerGlobal: #FLGlobalVariableForTesting. aPerson := FLPerson new. Smalltalk globals at: #FLGlobalVariableForTesting put: aPerson. self assertSerializationIdentityOf: aPerson. ! ! !FLBasicSerializationTest methodsFor: 'tests-globals' stamp: 'MartinDias 6/25/2012 21:08'! 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. ! ! !FLBasicSerializationTest methodsFor: 'tests-globals' stamp: 'MartinDias 1/10/2012 14:29'! testDontConsiderCustomGlobal "A custom global variable is not treated as global by Fuel, unless we explicitly specify this." | aPerson | aPerson := FLPerson new. Smalltalk globals at: #FLGlobalVariableForTesting put: aPerson. self deny: (self resultOfSerializeAndMaterialize: aPerson) == aPerson. ! ! !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-globals' stamp: 'MartinDias 12/30/2011 18:44'! testGlobalMetaclass "A metaclass should be global by default." self assertSerializationIdentityOf: Integer class. ! ! !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-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-not-so-basic' stamp: 'MartinDias 8/8/2011 15:47'! testGradientFillStyle self assertSerializationEqualityOf: GradientFillStyle sample! ! !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-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: '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-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:12'! testLargePositiveInteger self assertSerializationEqualityOf: 354314316134313999999999. self assertSerializationEqualityOf: 100 factorial. ! ! !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-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-numbers' stamp: 'MartinDias 10/17/2010 20:57'! testSmallIntegerMaxValue self assertSerializationIdentityOf: SmallInteger maxVal . ! ! !FLBasicSerializationTest methodsFor: 'tests-numbers' stamp: 'MartinDias 10/17/2010 21:04'! testSmallIntegerMinValue self assertSerializationIdentityOf: SmallInteger minVal ! ! !FLBasicSerializationTest methodsFor: 'tests-numbers' stamp: 'MartinDias 9/29/2010 11:27'! testSmallIntegerNegative self assertSerializationIdentityOf: -42.! ! !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-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-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-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-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-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 ] ] ). ! ! FLObjectCluster subclass: #FLBitsObjectCluster instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Clusters'! !FLBitsObjectCluster commentStamp: 'MartinDias 8/1/2011 02:59' prior: 0! 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: 'analyzing' stamp: 'MartinDias 1/8/2012 13:12'! newAnalyzingCollection "Answer a collection for the objects that correspond to this cluster." ^OrderedCollection new! ! !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.! ! FLSerializationTest subclass: #FLBlockClosureSerializationTest instanceVariableNames: '' classVariableNames: 'ClassVariableForTesting' poolDictionaries: '' category: 'FuelTests'! !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-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-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 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 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-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-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 class instanceVariableNames: 'interval'! !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 ].! ! Stream subclass: #FLBufferedWriteStream instanceVariableNames: 'stream buffer position streamRespondsToNextPutAllStartingAt' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Streams'! !FLBufferedWriteStream commentStamp: 'MarianoMartinezPeck 6/5/2011 12:41' prior: 0! 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: 'accessing' stamp: 'MarianoMartinezPeck 9/23/2011 22:34'! bufferFreeSize ^ buffer size - position! ! !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 8/16/2012 13:47'! nextPut: object self flushBufferIfFull. position := position + 1. self buffer at: position put: object ! ! !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: '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: 'file open/close' stamp: 'MarianoMartinezPeck 5/17/2011 23:32'! close self flushBuffer. stream close! ! !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: '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: '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: 'writing' stamp: 'MartinDias 1/11/2012 00:21'! nextWordsPut: aWordObject | byteSize | byteSize := aWordObject byteSize. "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: 'private' stamp: 'MarianoMartinezPeck 8/17/2012 12:10'! buffer buffer ifNil: [ self sizeBuffer: self defaultBufferSize ]. ^ buffer! ! !FLBufferedWriteStream methodsFor: 'private' stamp: 'MarianoMartinezPeck 9/8/2011 15:35'! copyWordObjectToBuffer: aWordObject | blt | blt := (BitBlt current 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: 'private' stamp: 'MarianoMartinezPeck 9/23/2011 22:35'! flushBufferIfFull position = buffer size ifTrue: [ self flushBuffer ] ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FLBufferedWriteStream class instanceVariableNames: ''! !FLBufferedWriteStream class methodsFor: 'accessing' stamp: 'MartinDias 1/6/2012 19:28'! defaultBufferSize ^ 4096! ! !FLBufferedWriteStream class methodsFor: 'instance creation' stamp: 'MartinDias 1/6/2012 19:27'! on: writeStream ^ self on: writeStream bufferSize: self defaultBufferSize! ! !FLBufferedWriteStream class methodsFor: 'instance creation' stamp: 'MartinDias 1/6/2012 19:14'! on: writeStream bufferSize: aSize ^ self basicNew initializeOn: writeStream bufferSize: aSize; yourself! ! FLStreamStrategy subclass: #FLByteArrayStreamStrategy instanceVariableNames: 'inMemoryStream' classVariableNames: '' poolDictionaries: '' category: 'FuelTests-StreamStrategies'! !FLByteArrayStreamStrategy commentStamp: 'MartinDias 10/12/2011 11:37' prior: 0! I am a strategy that emulate what we offer with FLSerializer class >> #serializeInMemory: and FLMaterializer class >> #materializeFromByteArray: ! !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! ! !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 ! ! FLBitsObjectCluster subclass: #FLByteObjectCluster instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Clusters'! !FLByteObjectCluster commentStamp: 'MartinDias 8/1/2011 02:59' prior: 0! 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.! ! FLMaterializationError subclass: #FLClassNotFound instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Errors'! !FLClassNotFound commentStamp: 'MarianoMartinezPeck 10/23/2011 14:34' prior: 0! I represent an error produced during materialization when a serialized class or trait name doesn't exist.! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FLClassNotFound class instanceVariableNames: ''! !FLClassNotFound class methodsFor: 'signaling' stamp: 'MartinDias 3/20/2012 12:06'! signalWithName: className ^ self signal: 'Class named ', className printString, ' not found.'! ! FLSerializationTest subclass: #FLClassSerializationTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FuelTests'! !FLClassSerializationTest commentStamp: '' prior: 0! I have the common behavior for testing class serialization.! !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: '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: 'tests' stamp: 'MartinDias 10/8/2011 03:11'! newClassOrTrait "Returns a class for testing" ^ self newClassWithInstanceVariableNames: ''! ! !FLClassSerializationTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 12/13/2011 20:45'! newClassOrTraitWithSuperClass: superclass "Returns a class for testing" ^ self newClassWithInstanceVariableNames: '' superclass: superclass! ! !FLClassSerializationTest methodsFor: 'tests' stamp: 'MartinDias 3/23/2011 17:42'! newInstanceFrom: aClass ^ aClass new! ! Object subclass: #FLClassWithRecursiveSubstitution instanceVariableNames: 'index' classVariableNames: '' poolDictionaries: '' category: 'FuelTests-Mocks'! !FLClassWithRecursiveSubstitution methodsFor: 'accessing' stamp: 'MartinDias 5/9/2012 00:48'! index ^ index! ! !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 ]! ! Object subclass: #FLCluster instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Clusters'! !FLCluster commentStamp: 'MartinDias 8/29/2011 19:20' prior: 0! I represent a cluster of objects grouped by some specific similarity. I know how to serialize and materialize them all together.! !FLCluster methodsFor: 'accessing' stamp: 'MartinDias 8/29/2011 00:50'! objects "Answer the objects that this cluster groups." self subclassResponsibility! ! !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: 'hooks' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^ aGeneralMapper visitSubstitution: self by: nil! ! !FLCluster methodsFor: 'initialize-release' stamp: 'MartinDias 1/8/2012 14:32'! initializeAnalyzing self initialize.! ! !FLCluster methodsFor: 'initialize-release' stamp: 'MartinDias 1/8/2012 14:36'! initializeMaterializing self initialize.! ! !FLCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 19:48'! afterMaterializationStepWith: aDecoder ! ! !FLCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 9/19/2012 14:38'! clusterMaterializeStepWith: aMaterialization "Materialize cluster stuff" ! ! !FLCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 9/19/2012 14:38'! clusterSerializeStepWith: aSerialization "Serialize cluster stuff"! ! !FLCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 1/8/2012 15:00'! materializeInstancesStepWith: aDecoder ! ! !FLCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 19:48'! materializePostInstancesStepWith: aDecoder ! ! !FLCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 19:48'! materializeReferencesStepWith: 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 1/8/2012 15:11'! serializeInstancesStepWith: anEncoder ! ! !FLCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 19:44'! serializePostInstancesStepWith: anEncoder ! ! !FLCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 19:44'! serializeReferencesStepWith: anEncoder ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FLCluster class instanceVariableNames: ''! !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:33'! new self error: 'Use another instance creation message.'! ! !FLCluster class methodsFor: 'instance creation' stamp: 'MartinDias 1/8/2012 14:32'! newAnalyzing ^ self basicNew initializeAnalyzing; yourself.! ! !FLCluster class methodsFor: 'instance creation' stamp: 'MartinDias 2/17/2012 03:18'! newMaterializing ^ self basicNew initializeMaterializing; yourself.! ! Object subclass: #FLClusterization instanceVariableNames: 'baselevelBucket substitutionsBucket globalsBucket metalevelInstanceSideBucket metalevelClassSideBucket primitivesBucket postBaselevelBucket' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Core'! !FLClusterization commentStamp: 'MartinDias 8/29/2011 19:12' prior: 0! I manage the clusters collected during the analysis step of serialization.! !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: 'accessing' stamp: 'MartinDias 1/11/2012 00:27'! clusters ^self clusterBuckets gather: [:c | c ]. ! ! !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: 'cluster buckets' stamp: 'MartinDias 8/20/2011 22:27'! baselevelBucket ^ baselevelBucket! ! !FLClusterization methodsFor: 'cluster buckets' stamp: 'MartinDias 9/15/2011 20:16'! globalsBucket ^ globalsBucket ! ! !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: 'MarianoMartinezPeck 7/26/2012 17:36'! postBaselevelBucket ^ postBaselevelBucket! ! !FLClusterization methodsFor: 'cluster buckets' stamp: 'MartinDias 9/17/2011 00:29'! primitivesBucket ^ primitivesBucket! ! !FLClusterization methodsFor: 'cluster buckets' stamp: 'MartinDias 8/20/2011 22:52'! substitutionsBucket ^ substitutionsBucket! ! !FLClusterization methodsFor: 'hooks' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^ aGeneralMapper visitSubstitution: self by: nil! ! !FLClusterization methodsFor: 'initialize-release' 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. ! ! FLIteratingCluster subclass: #FLCompiledMethodCluster instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Clusters'! !FLCompiledMethodCluster commentStamp: '' prior: 0! I am a cluster for CompiledMethod instances. How CompiledMethod trailers are serialized can be established using methods in 'configurating' class-side protocol.! !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: '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: '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: '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 methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 19:48'! materializeReferencesStepWith: aDecoder objects do: [ :aCompiledMethod | self materializeLiteralsTo: aCompiledMethod with: aDecoder ]! ! !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 19:43'! serializeReferencesStepWith: anEncoder objects do: [ :aCompiledMethod | self serializeLiteralsOf: aCompiledMethod with: anEncoder ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FLCompiledMethodCluster class instanceVariableNames: 'transformationForSerializing'! !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: 'accessing' stamp: 'MartinDias 2/18/2013 17:58'! transformationForSerializing: aBlockWithOneArgument transformationForSerializing := aBlockWithOneArgument! ! !FLCompiledMethodCluster class methodsFor: 'analyzing' stamp: 'MartinDias 1/8/2012 15:37'! clusterBucketIn: aClusterization ^aClusterization primitivesBucket! ! !FLCompiledMethodCluster class methodsFor: 'class initialization' stamp: 'MartinDias 2/25/2013 14:31'! initialize self setTrailerWithNoSource ! ! !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: '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) ]! ! Object subclass: #FLDecoder instanceVariableNames: 'stream objects isBigEndian indexStream migrations objectsWriteStream globalEnvironment' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Core'! !FLDecoder commentStamp: 'MartinDias 1/6/2012 16:08' prior: 0! I am an abstraction used by the materialization algorithm to decode the graph from a stream.! !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: 'accessing' stamp: 'MartinDias 2/21/2013 23:48'! globalClassNamed: className ^ globalEnvironment at: className ifAbsent: [ FLClassNotFound signalWithName: className ]! ! !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 12/29/2011 18:27'! isBigEndian ^ isBigEndian! ! !FLDecoder methodsFor: 'accessing' stamp: 'MartinDias 12/29/2011 18:51'! objects ^ objects! ! !FLDecoder methodsFor: 'accessing' stamp: 'MartinDias 2/17/2012 04:06'! registerAll: someObjects objectsWriteStream nextPutAll: someObjects.! ! !FLDecoder methodsFor: 'accessing' stamp: 'MartinDias 1/7/2012 11:54'! variablesMappingFor: aClass | variables | variables := FLVariablesMapping materializing: aClass from: self. migrations select: [ :m | m targetClass == aClass ] thenDo: [ :m | m applyTo: variables ]. ^ variables ! ! !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: 'MarianoMartinezPeck 1/7/2012 20:09'! nextEncodedBitmap ^ Bitmap newFromStream: stream! ! !FLDecoder methodsFor: 'decoding' stamp: 'MartinDias 12/29/2011 21:07'! nextEncodedByte ^stream next! ! !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 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 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: '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: 'MartinDias 12/30/2011 15:34'! nextEncodedReference ^ objects at: indexStream nextIndex! ! !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: '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 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: '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: 'decoding' stamp: 'MarianoMartinezPeck 6/8/2012 22:55'! nextEncodedUint8 "Answer the next unsigned, 16-bit integer from this (binary) stream." ^ stream next. ! ! !FLDecoder methodsFor: 'decoding' stamp: 'MartinDias 12/29/2011 21:02'! nextEncodedWordsInto: aWordsObject stream fuelNextWordsInto: aWordsObject ! ! !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 class instanceVariableNames: ''! !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.! ! FLAbstractCollectionCluster subclass: #FLDictionaryCollectionCluster instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Clusters-Optionals'! !FLDictionaryCollectionCluster commentStamp: '' prior: 0! 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: '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. ] ! ! !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: 'MarianoMartinezPeck 7/26/2012 16:15'! serializeReferencesOf: anObject with: anEncoder anEncoder encodePositiveInteger: anObject size. anObject keysAndValuesDo: [ :key :value | anEncoder encodeReferenceTo: key. anEncoder encodeReferenceTo: value. ] ! ! Object subclass: #FLEncoder instanceVariableNames: 'stream objectsIndexes objectCount indexStream globalEnvironment' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Core'! !FLEncoder commentStamp: 'MartinDias 1/6/2012 16:08' prior: 0! I am an abstraction used by the serialization algorithm to encode the graph in a stream.! !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: 'accessing' stamp: 'MartinDias 12/29/2011 18:46'! objectCount ^ objectCount! ! !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: 'accessing' stamp: 'MartinDias 12/29/2011 17:12'! objectsIndexes ^ objectsIndexes! ! !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: 'MartinDias 12/29/2011 20:11'! encodeByte: aSmallInteger stream nextPut: aSmallInteger! ! !FLEncoder methodsFor: 'encoding' stamp: 'MartinDias 12/29/2011 20:16'! encodeBytes: aBytesObject stream nextBytesPutAll: aBytesObject ! ! !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 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 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: 'encoding' stamp: 'MarianoMartinezPeck 1/11/2012 22:24'! encodeReferenceTo: anObject indexStream nextIndexPut: (objectsIndexes at: anObject ifAbsent: [FLObjectNotFound signalWith: anObject])! ! !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 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 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: '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: 'encoding' stamp: 'MartinDias 12/30/2011 15:34'! encodeWeakReferenceTo: anObject indexStream nextIndexPut: (objectsIndexes at: anObject ifAbsent: [objectsIndexes at: nil]) ! ! !FLEncoder methodsFor: 'encoding' stamp: 'MartinDias 12/29/2011 20:18'! encodeWords: aWordsObject stream nextWordsPut: aWordsObject! ! !FLEncoder methodsFor: 'encoding' stamp: 'MartinDias 12/30/2011 15:31'! encodeYourself self encodePositiveInteger: objectCount. self encodePositiveInteger: Smalltalk isBigEndian asBit.! ! !FLEncoder methodsFor: 'encoding' stamp: 'MartinDias 1/6/2012 22:42'! flush ^ stream flush.! ! !FLEncoder methodsFor: 'hooks' stamp: 'MartinDias 5/11/2012 16:15'! fuelAccept: aGeneralMapper ^ aGeneralMapper visitSubstitution: self by: nil! ! !FLEncoder methodsFor: 'initialize-release' stamp: 'MartinDias 2/22/2013 10:57'! initializeOn: aStream globalEnvironment: aDictionary self initialize. stream := FLBufferedWriteStream on: aStream. globalEnvironment := aDictionary.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FLEncoder class instanceVariableNames: ''! !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 ]! ! Error subclass: #FLError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Errors'! !FLError commentStamp: '' prior: 0! I represent an error produced during Fuel operation.! FLStreamStrategy subclass: #FLFileStreamStrategy instanceVariableNames: 'fileStreamClass' classVariableNames: '' poolDictionaries: '' category: 'FuelTests-StreamStrategies'! !FLFileStreamStrategy commentStamp: 'MartinDias 10/12/2011 11:37' prior: 0! I am a strategy for traditional file streams.! !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 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:01'! fileStreamClass "Returns the FileStream specific class" ^fileStreamClass! ! !FLFileStreamStrategy methodsFor: 'writing' stamp: 'MartinDias 12/7/2011 02:02'! initializeWith: aFileStreamClass self initialize. fileStreamClass := aFileStreamClass.! ! !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 class instanceVariableNames: ''! !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! ! FLPointerObjectCluster subclass: #FLFixedObjectCluster instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Clusters'! !FLFixedObjectCluster commentStamp: 'MartinDias 5/30/2011 01:25' prior: 0! I am a generic cluster for objects without indexable variables.! !FLFixedObjectCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 2/20/2013 21:46'! materializeInstanceWith: aDecoder ^theClass fuelNew! ! !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." ! ! CommandLineHandler subclass: #FLFuelCommandLineHandler instanceVariableNames: 'files' classVariableNames: '' poolDictionaries: '' category: 'FuelCommandLineHandler'! !FLFuelCommandLineHandler commentStamp: '' prior: 0! 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: ./vm.sh Pharo.image save quit path/to/foo.fuel #Load the contents of foo.fuel and save the image, but continue running: ./vm.sh Pharo.image save path/to/foo.fuel #Load the contents of foo.fuel and continue running without saving: ./vm.sh Pharo.image path/to/foo.fuel ! !FLFuelCommandLineHandler methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 8/4/2012 22:14'! fileExtension ^ self class fileExtension! ! !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 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 class instanceVariableNames: ''! !FLFuelCommandLineHandler class methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 8/4/2012 22:16'! commandName ^ '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:19'! fileExtension ^ '.fuel'! ! !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 ! ! FLStreamStrategy subclass: #FLGZipStrategy instanceVariableNames: 'targetStrategy' classVariableNames: '' poolDictionaries: '' category: 'FuelTests-StreamStrategies'! !FLGZipStrategy commentStamp: '' prior: 0! I am a strategy for using GZipStream.! !FLGZipStrategy methodsFor: 'initialize-release' stamp: 'MartinDias 10/12/2011 18:41'! initializeWith: aStreamStrategy self initialize. targetStrategy := aStreamStrategy.! ! !FLGZipStrategy methodsFor: 'reading' stamp: 'MartinDias 10/12/2011 18:38'! readStreamDo: aValuable "Evaluates the argument with a read stream. Answers the result." targetStrategy readStreamDo: [:aStream | ^ GZipReadStream on: aStream do: aValuable] ! ! !FLGZipStrategy methodsFor: 'writing' stamp: 'MartinDias 10/12/2011 18:36'! writeStreamDo: aValuable "Evaluates the argument with a write stream. Answers the result." targetStrategy writeStreamDo: [:aStream | ^ GZipWriteStream on: aStream do: aValuable] ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FLGZipStrategy class instanceVariableNames: ''! !FLGZipStrategy class methodsFor: 'instance creation' stamp: 'MartinDias 10/12/2011 18:40'! newWithTarget: aStreamStrategy ^self basicNew initializeWith: aStreamStrategy; yourself ! ! FLBasicSerializationTest subclass: #FLGZippedBasicSerializationTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FuelTests'! !FLGZippedBasicSerializationTest methodsFor: 'expected failures' stamp: 'MartinDias 4/12/2012 20:02'! expectedFailures ^ super expectedFailures, #(testWideString)! ! !FLGZippedBasicSerializationTest methodsFor: 'running' stamp: 'MartinDias 3/22/2012 20:14'! setUp super setUp. self useGzipInMemoryStream.! ! !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: '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 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 class instanceVariableNames: ''! !FLGZippedBasicSerializationTest class methodsFor: 'testing' stamp: 'MartinDias 3/22/2012 20:08'! shouldInheritSelectors ^true! ! FLGlobalCluster subclass: #FLGlobalClassCluster instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Clusters'! !FLGlobalClassCluster commentStamp: 'MartinDias 5/30/2011 01:28' prior: 0! 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! ! FLClassSerializationTest subclass: #FLGlobalClassSerializationTest uses: FLTGlobalClassOrTraitSerializationTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FuelTests'! !FLGlobalClassSerializationTest commentStamp: 'MartinDias 11/28/2011 10:48' prior: 0! 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'! 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'! 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'! 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'! testClassSidePreservesIdentity "Tests that serialization of the class side preserves identity" self assertSerializationIdentityOf: self newClassOrTrait classSide ! ! !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'! 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'! 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'! 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.! ! !FLGlobalClassSerializationTest methodsFor: 'tests'! 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'! 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'! testPreservesIdentity "Tests that serialization of the class or trait preserves identity" self assertSerializationIdentityOf: self newClassOrTrait! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FLGlobalClassSerializationTest class uses: FLTGlobalClassOrTraitSerializationTest classTrait instanceVariableNames: ''! FLGlobalCluster subclass: #FLGlobalClassSideCluster instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Clusters'! !FLGlobalClassSideCluster commentStamp: 'MartinDias 8/1/2011 02:57' prior: 0! 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 ! ! FLPrimitiveCluster subclass: #FLGlobalCluster instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Clusters'! !FLGlobalCluster commentStamp: 'MartinDias 9/16/2011 14:49' prior: 0! I am a cluster for objects that are reachables from Smalltalk global dictionary.! !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 methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/30/2011 12:24'! serializeGlobalAssociationKeyed: aSymbol on: anEncoder anEncoder encodeString: aSymbol! ! !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 class instanceVariableNames: ''! !FLGlobalCluster class methodsFor: 'analyzing' stamp: 'MartinDias 1/8/2012 15:38'! clusterBucketIn: aClusterization ^aClusterization globalsBucket ! ! FLGlobalCluster subclass: #FLGlobalCompiledMethodCluster instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Clusters'! !FLGlobalCompiledMethodCluster commentStamp: '' prior: 0! 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.! ! FLSerializationTest subclass: #FLGlobalEnvironmentTest instanceVariableNames: 'serializationEnvironment materializationEnvironment' classVariableNames: '' poolDictionaries: '' category: 'FuelTests'! !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: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: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: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: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: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: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'! 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: '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! ! !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'! ! FLMaterializationError subclass: #FLGlobalNotFound instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Errors'! !FLGlobalNotFound commentStamp: 'MartinDias 12/16/2011 01:16' prior: 0! I represent an error produced during materialization when a serialized global name doesn't exist (at Smalltalk globals).! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FLGlobalNotFound class instanceVariableNames: ''! !FLGlobalNotFound class methodsFor: 'signaling' stamp: 'MartinDias 3/20/2012 12:06'! signalWithName: aName ^ self signal: 'Global named ', aName printString, ' not found.'! ! FLGlobalCluster subclass: #FLGlobalSendCluster instanceVariableNames: 'globalSends' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Clusters'! !FLGlobalSendCluster commentStamp: 'MarianoMartinezPeck 10/23/2011 14:39' prior: 0! 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'! materializeInstanceWith: aDecoder | global selector | global := (self materializeGlobalAssociationFrom: aDecoder) value. selector := aDecoder nextEncodedString asSymbol. ^ global perform: 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. ! ! Object subclass: #FLGlobalSendMock instanceVariableNames: 'contents' classVariableNames: '' poolDictionaries: '' category: 'FuelTests-Mocks'! !FLGlobalSendMock methodsFor: 'accessing' stamp: 'MartinDias 9/15/2011 02:58'! contents ^ contents! ! !FLGlobalSendMock methodsFor: 'accessing' stamp: 'MartinDias 9/15/2011 02:58'! contents: anObject contents := anObject! ! !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: '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: 'initialization' stamp: 'MartinDias 9/15/2011 02:56'! initializeWith: aByteSymbol super initialize. contents := aByteSymbol ! ! !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: 'serialization' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^aGeneralMapper visitGlobalSend: self name: #FLGlobalSendMock selector: #newInstanceToMaterialize! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FLGlobalSendMock class instanceVariableNames: ''! !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! ! !FLGlobalSendMock class methodsFor: 'instance creation' stamp: 'MartinDias 9/15/2011 02:56'! newWith: aByteSymbol ^self basicNew initializeWith: aByteSymbol; yourself! ! Object subclass: #FLGlobalSendNotPresentMock instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FuelTests-Mocks'! !FLGlobalSendNotPresentMock methodsFor: 'serialization' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^aGeneralMapper visitGlobalSend: self name: #FLKeyNotPresentInSmalltalks selector: #someSelector! ! FLSerializationTest subclass: #FLGlobalSendSerializationTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FuelTests'! !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.! ! !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.' ! ! FLTraitSerializationTest subclass: #FLGlobalTraitSerializationTest uses: FLTGlobalClassOrTraitSerializationTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FuelTests'! !FLGlobalTraitSerializationTest commentStamp: '' prior: 0! 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'! 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'! 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'! 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'! testClassSidePreservesIdentity "Tests that serialization of the class side preserves identity" self assertSerializationIdentityOf: self newClassOrTrait classSide ! ! !FLGlobalTraitSerializationTest methodsFor: 'tests'! 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'! 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'! 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.! ! !FLGlobalTraitSerializationTest methodsFor: 'tests'! 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'! 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'! testPreservesIdentity "Tests that serialization of the class or trait preserves identity" self assertSerializationIdentityOf: self newClassOrTrait! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FLGlobalTraitSerializationTest class uses: FLTGlobalClassOrTraitSerializationTest classTrait instanceVariableNames: ''! FLGlobalCluster subclass: #FLGlobalValueCluster instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Clusters'! !FLGlobalValueCluster commentStamp: 'MartinDias 5/30/2011 01:28' prior: 0! 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! ! FLSerializationTest subclass: #FLHashedCollectionSerializationTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FuelTests'! !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).! ! !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).! ! Object subclass: #FLHeader instanceVariableNames: 'preMaterializationActions additionalObjects postMaterializationActions materialization' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Core'! !FLHeader commentStamp: '' prior: 0! 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: '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 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 ! ! !FLHeader methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 7/28/2012 11:53'! additionalObjectAt: key ^ additionalObjects at: key! ! !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 13:48'! materialization: aMaterialization "This is just set once the materialization had happened" materialization := aMaterialization ! ! !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: 'executing' stamp: 'MarianoMartinezPeck 7/28/2012 14:25'! executePostMaterializationActions postMaterializationActions do: [:each | each cull: materialization]! ! !FLHeader methodsFor: 'executing' stamp: 'MarianoMartinezPeck 7/28/2012 14:25'! executePreMaterializationActions preMaterializationActions do: [:each | each value]! ! !FLHeader methodsFor: 'initialize-release' stamp: 'MarianoMartinezPeck 7/28/2012 12:33'! initialize additionalObjects := IdentityDictionary new. preMaterializationActions := OrderedCollection new. postMaterializationActions := OrderedCollection new.! ! !FLHeader methodsFor: 'testing' stamp: 'MartinDias 2/25/2013 14:55'! isEmpty ^ preMaterializationActions isEmpty and: [ postMaterializationActions isEmpty and: [ additionalObjects isEmpty ] ]! ! FLSerializationTest subclass: #FLHeaderSerializationTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FuelTests'! !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 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. ! ! !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 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. ! ! FLPrimitiveCluster subclass: #FLHookPrimitiveCluster instanceVariableNames: 'theClass' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Clusters'! !FLHookPrimitiveCluster commentStamp: '' prior: 0! I am a cluster for simple objects who define serialization and materialization via hooks on their classes.! !FLHookPrimitiveCluster methodsFor: 'analyzing' stamp: 'MarianoMartinezPeck 4/23/2012 16:33'! clusterReferencesDo: aBlock aBlock value: theClass! ! !FLHookPrimitiveCluster methodsFor: 'initialize-release' stamp: 'MartinDias 2/25/2013 14:47'! initializeAnalyzing: aClass self initializeAnalyzing. theClass := aClass! ! !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 methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 9/19/2012 14:42'! clusterMaterializeStepWith: aMaterialization super clusterMaterializeStepWith: aMaterialization. theClass := aMaterialization decoder nextEncodedReference. ! ! !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:47'! materializeInstanceWith: aDecoder ^theClass materializeFrom: aDecoder! ! !FLHookPrimitiveCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/30/2011 10:48'! serializeInstance: anObject with: anEncoder anObject serializeOn: anEncoder! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FLHookPrimitiveCluster class instanceVariableNames: ''! !FLHookPrimitiveCluster class methodsFor: 'instance creation' stamp: 'MarianoMartinezPeck 4/23/2012 16:34'! newAnalyzing: aClass ^ self basicNew initializeAnalyzing: aClass; yourself.! ! FLSerializationTest subclass: #FLHookedSubstitutionTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FuelTests'! !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'! 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'! 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'! 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'! 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'! 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'. ! ! !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'! testTransientByNil | result aClassOfTransientObjects | aClassOfTransientObjects := self newClass duringTestCompileSilently: 'fuelAccept: aVisitor ^aVisitor visitSubstitution: self by: nil'; yourself. result := self resultOfSerializeAndMaterialize: aClassOfTransientObjects new. self assert: result isNil.! ! FLClassSerializationTest subclass: #FLIgnoredVariablesTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FuelTests'! !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: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)! ! !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).! ! FLBasicSerializationTest subclass: #FLInMemoryBasicSerializationTest instanceVariableNames: 'byteArray' classVariableNames: '' poolDictionaries: '' category: 'FuelTests'! !FLInMemoryBasicSerializationTest methodsFor: 'running' stamp: 'MartinDias 3/28/2012 22:48'! materialization self error: 'Disabled, instead use #materialized.' ! ! !FLInMemoryBasicSerializationTest methodsFor: 'running' stamp: 'MartinDias 3/28/2012 22:48'! materialized ^ FLMaterializer materializeFromByteArray: byteArray. ! ! !FLInMemoryBasicSerializationTest methodsFor: 'running' stamp: 'MartinDias 3/28/2012 22:46'! serialize: anObject byteArray := FLSerializer serializeToByteArray: anObject! ! !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 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 class instanceVariableNames: ''! !FLInMemoryBasicSerializationTest class methodsFor: 'testing' stamp: 'MartinDias 3/28/2012 22:49'! shouldInheritSelectors ^ true! ! Object subclass: #FLIndexStream instanceVariableNames: 'stream digits' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Streams'! !FLIndexStream commentStamp: '' prior: 0! 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 instanceVariableNames: ''! !FLIndexStream class methodsFor: 'instance creation' stamp: 'MartinDias 12/30/2011 14:33'! on: aStream digits: aNumberOfDigits ^ self basicNew initializeOn: aStream digits: aNumberOfDigits; yourself. ! ! TestCase subclass: #FLIndexStreamTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FuelTests-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'! testCreation self shouldnt: [ self indexStreamOn: #() writeStream digits: 2 ] raise: Error.! ! !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.! ! FLCluster subclass: #FLIteratingCluster instanceVariableNames: 'objects' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Clusters'! !FLIteratingCluster commentStamp: '' prior: 0! 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: 'accessing' stamp: 'MartinDias 8/29/2011 00:59'! objects ^objects! ! !FLIteratingCluster methodsFor: 'analyzing' stamp: 'MartinDias 10/13/2011 16:26'! add: anObject traceWith: aAnalysis "Add an object to the cluster and trace references." objects addIfNotPresent: anObject ifPresentDo: [ ^self ]. self referencesOf: anObject do: [ :aChild | aAnalysis trace: aChild ].! ! !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: 'MartinDias 8/29/2011 00:56'! referencesOf: anObject do: aBlock "Evaluate a block with each object referenced by anObject"! ! !FLIteratingCluster methodsFor: 'initialize-release' stamp: 'MartinDias 1/8/2012 14:32'! initializeAnalyzing super initializeAnalyzing. objects := self newAnalyzingCollection.! ! !FLIteratingCluster methodsFor: 'printing' stamp: 'MartinDias 8/29/2011 01:16'! printNameOn: aStream super printOn: aStream! ! !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: 'MarianoMartinezPeck 9/19/2012 14:42'! clusterMaterializeStepWith: aMaterialization super clusterMaterializeStepWith: aMaterialization. objects := Array new: aMaterialization decoder nextEncodedPositiveInteger! ! !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/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: '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: '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 2/17/2012 03:03'! serializeInstancesStepWith: anEncoder objects do: [ :instance | self serializeInstance: instance with: anEncoder ]! ! FLLargeIdentityHashedCollection subclass: #FLLargeIdentityDictionary instanceVariableNames: 'keys values' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Collections'! !FLLargeIdentityDictionary commentStamp: '' prior: 0! I am an IdentityDictionary optimized for including a large number of elements.! !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: '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: '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 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 3/24/2010 21:57'! keys ^Array new: tally streamContents: [ :stream | self keysDo: [ :key | stream nextPut: key ] ]! ! !FLLargeIdentityDictionary methodsFor: 'accessing' stamp: 'ul 3/24/2010 21:57'! values ^Array new: tally streamContents: [ :stream | self valuesDo: [ :value | stream nextPut: 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: 'enumerating' stamp: 'ul 3/24/2010 21:47'! do: aBlock ^self valuesDo: aBlock! ! !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: '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: '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: 'initialize-release' 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: '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: 'private' stamp: 'MarianoMartinezPeck 12/20/2011 10:29'! errorKeyNotFound: aKey KeyNotFound signalFor: aKey! ! Collection subclass: #FLLargeIdentityHashedCollection instanceVariableNames: 'tally tallies' classVariableNames: 'PermutationMap' poolDictionaries: '' category: 'Fuel-Collections'! !FLLargeIdentityHashedCollection commentStamp: '' prior: 0! I share behavior for special HashedCollections that are optimized for including a large number of elements.! !FLLargeIdentityHashedCollection methodsFor: 'accessing' stamp: 'ul 12/18/2011 11:33'! size ^tally! ! !FLLargeIdentityHashedCollection methodsFor: 'copying' stamp: 'ul 12/18/2011 11:35'! postCopy tallies := tallies copy ! ! !FLLargeIdentityHashedCollection methodsFor: 'initialize-release' stamp: 'ul 12/18/2011 11:31'! initialize tally := 0. tallies := Array new: 4096 withAll: 0! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FLLargeIdentityHashedCollection class instanceVariableNames: ''! !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! ! FLLargeIdentityHashedCollection subclass: #FLLargeIdentitySet instanceVariableNames: 'array includesNil' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Collections'! !FLLargeIdentitySet commentStamp: 'HenrikSperreJohansen 12/16/2011 12:55' prior: 0! 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: '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: '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: '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: '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: 'initialize-release' stamp: 'ul 12/18/2011 11:31'! initialize super initialize. array := Array new: 4096. includesNil := false! ! !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: '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 ]! ! FLMapper subclass: #FLLightGeneralMapper instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Mappers'! !FLLightGeneralMapper commentStamp: '' prior: 0! I know how to map an object to its default cluster. I can map every object.! !FLLightGeneralMapper methodsFor: 'mapping' stamp: 'MartinDias 1/8/2012 12:36'! mapAndTrace: anObject anObject fuelAccept: self ! ! !FLLightGeneralMapper methodsFor: 'protected-mapping' stamp: 'MartinDias 1/9/2012 21:08'! clusterClassForCharacter: aCharacter ^ aCharacter isOctetCharacter ifTrue: [ FLHookPrimitiveCluster ] ifFalse: [ FLFixedObjectCluster ]! ! !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: '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 21:08'! visitCharacter: aCharacter self flag: #todo. "confusing" self mapAndTraceByObjectClass: aCharacter to: (self clusterClassForCharacter: aCharacter)! ! !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'! visitClassTrait: aClassTrait self mapAndTraceByClusterName: aClassTrait to: FLGlobalClassSideCluster! ! !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: 'MarianoMartinezPeck 7/26/2012 16:14'! visitDictionary: aDictionary self mapAndTraceByObjectClass: aDictionary to: FLDictionaryCollectionCluster ! ! !FLLightGeneralMapper methodsFor: 'visiting' stamp: 'MartinDias 1/9/2012 18:23'! visitFixedObject: anObject self mapAndTraceByObjectClass: anObject to: FLFixedObjectCluster! ! !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: 'visiting' stamp: 'MartinDias 3/28/2012 21:19'! visitHookPrimitive: anObject self mapAndTraceByObjectClass: anObject to: FLHookPrimitiveCluster ! ! !FLLightGeneralMapper methodsFor: 'visiting' stamp: 'MartinDias 1/9/2012 18:23'! visitMetaclass: aMetaclass self mapAndTraceByClusterName: aMetaclass to: FLGlobalClassSideCluster! ! !FLLightGeneralMapper methodsFor: 'visiting' stamp: 'MartinDias 1/9/2012 18:23'! visitMethodContext: aMethodContext self mapAndTraceByObjectClass: aMethodContext to: FLMethodContextCluster ! ! !FLLightGeneralMapper methodsFor: 'visiting' stamp: 'MartinDias 5/18/2012 17:38'! visitNotSerializable: anObject FLNotSerializable signalWith: anObject! ! !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: 'MarianoMartinezPeck 7/26/2012 17:41'! visitSimpleCollection: aCollection self mapAndTraceByObjectClass: aCollection to: FLSimpleCollectionCluster ! ! !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:29'! visitSubstitution: anObject by: anotherObject (self clusterKeyedByClusterName: FLSubstitutionCluster) add: anObject substitutedBy: anotherObject traceWith: analysis ! ! !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: 'MartinDias 1/8/2012 20:14'! visitTrait: aTrait self mapAndTraceInstanceSideGlobal: aTrait! ! !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 18:23'! visitWeakObject: anObject self mapAndTraceByObjectClass: anObject to: FLWeakVariableObjectCluster! ! !FLLightGeneralMapper methodsFor: 'visiting' stamp: 'MartinDias 1/9/2012 18:23'! visitWordsObject: anObject self mapAndTraceByObjectClass: anObject to: FLWordObjectCluster! ! FLMapper subclass: #FLLightGlobalMapper instanceVariableNames: 'globals' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Mappers'! !FLLightGlobalMapper commentStamp: '' prior: 0! 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: 'initialize-release' stamp: 'MartinDias 1/9/2012 18:11'! initializeWith: someObjects self initialize. globals := someObjects.! ! !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 class instanceVariableNames: ''! !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! ! Object subclass: #FLMapper instanceVariableNames: 'next analysis' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Mappers'! !FLMapper commentStamp: 'MartinDias 8/11/2011 03:09' prior: 0! The purpose of my hierarchy is to map objects with clusters.! !FLMapper methodsFor: 'accessing' stamp: 'MartinDias 1/8/2012 18:40'! analysis: anAnalysis analysis := anAnalysis. next isNil ifFalse: [ next analysis: anAnalysis ]! ! !FLMapper methodsFor: 'accessing' stamp: 'MartinDias 8/7/2011 17:19'! next: anObject next := anObject! ! !FLMapper methodsFor: 'hooks' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^ aGeneralMapper visitSubstitution: self by: nil! ! !FLMapper methodsFor: 'mapping' stamp: 'MartinDias 1/8/2012 12:38'! mapAndTrace: anObject self subclassResponsibility! ! !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: 'protected-mapping' stamp: 'MartinDias 1/9/2012 18:29'! clusterKeyedByClusterName: aClusterClass ^ self clusterKeyedByClusterName: aClusterClass factory: [ aClusterClass newAnalyzing ]! ! !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:27'! clusterKeyedByObjectClass: clusterClass class: objectClass ^ self clusterInstanceOf: clusterClass keyInBucket: objectClass factory: [ clusterClass newAnalyzing: objectClass ]! ! !FLMapper methodsFor: 'protected-mapping' stamp: 'MartinDias 1/9/2012 18:29'! mapAndTraceByClusterName: anObject to: aClusterClass (self clusterKeyedByClusterName: aClusterClass) add: anObject traceWith: analysis ! ! !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 ! ! Object subclass: #FLMaterialization instanceVariableNames: 'clusterCount clusters root decoder header' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Core'! !FLMaterialization commentStamp: 'MarianoMartinezPeck 10/23/2011 14:42' prior: 0! I implement the algorithm for materializing an object graph on a stream. FLMaterializer known how to build instances of me.! !FLMaterialization methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 9/19/2012 14:36'! decoder ^ decoder! ! !FLMaterialization methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 7/28/2012 13:46'! header: aHeader header := aHeader ! ! !FLMaterialization methodsFor: 'accessing' stamp: 'MartinDias 12/29/2011 18:12'! objects "Answer a collection with the materialized objects." ^ decoder objects ! ! !FLMaterialization methodsFor: 'accessing' stamp: 'MartinDias 9/9/2011 01:58'! root ^ root ! ! !FLMaterialization methodsFor: 'header' stamp: 'MarianoMartinezPeck 7/28/2012 13:47'! additionalObjectAt: aKey ^ header additionalObjectAt: aKey! ! !FLMaterialization methodsFor: 'initialize-release' stamp: 'MartinDias 1/5/2012 14:30'! initializeWith: aDecoder self initialize. decoder := aDecoder. ! ! !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: '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 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: 'private' stamp: 'MartinDias 9/9/2011 01:58'! instancesStep clusterCount timesRepeat: [ self clusterInstancesStep ] ! ! !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:25'! registerAll: materializedObjects decoder registerAll: materializedObjects ! ! !FLMaterialization methodsFor: 'private' stamp: 'MartinDias 12/29/2011 18:11'! trailerStep root := decoder nextEncodedReference! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FLMaterialization class instanceVariableNames: ''! !FLMaterialization class methodsFor: 'instance creation' stamp: 'MartinDias 1/5/2012 14:29'! with: aDecoder ^self basicNew initializeWith: aDecoder; yourself ! ! FLError subclass: #FLMaterializationError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Errors'! !FLMaterializationError commentStamp: '' prior: 0! I represent an error happened during materialization.! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FLMaterializationError class instanceVariableNames: ''! !FLMaterializationError class methodsFor: 'exceptioninstantiator' stamp: 'MartinDias 3/20/2012 12:47'! signal: signalerText ^ super signal: 'Materialization error. ', signalerText ! ! Object subclass: #FLMaterializer instanceVariableNames: 'materializationFactory signature version migrations globalEnvironment' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Core'! !FLMaterializer commentStamp: 'MartinDias 8/29/2011 19:06' prior: 0! I am a binary object materializer. See an example of use in FLSerializer's documentation. ! !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: 'accessing' stamp: 'MarianoMartinezPeck 7/29/2012 23:31'! materializationFactory ^ materializationFactory! ! !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: 'accessing' stamp: 'MartinDias 10/6/2011 22:57'! version ^ version! ! !FLMaterializer methodsFor: 'accessing' stamp: 'MartinDias 10/6/2011 22:57'! version: anObject version := anObject! ! !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: '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: 'hooks' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^ aGeneralMapper visitSubstitution: self by: nil! ! !FLMaterializer methodsFor: 'initialize-release' 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: '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: '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: '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: 'protected' stamp: 'MartinDias 1/6/2012 20:34'! setDefaultMaterialization materializationFactory := [:aDecoder | (FLMaterialization with: aDecoder) run; yourself ] ! ! !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 class instanceVariableNames: ''! !FLMaterializer class methodsFor: '*FuelSystem-FileRegistry' stamp: 'CamilloBruni 2/3/2013 17:56'! fileReaderServicesForFile: fullName suffix: suffix suffix = 'fuel' ifFalse: [ ^ #() ]. ^ { self serviceFuelMaterialize }! ! !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: 'instance creation' stamp: 'MartinDias 9/10/2011 18:16'! newDefault ^self new! ! !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: 'MarianoMartinezPeck 7/28/2012 14:57'! materializationHeaderFromFileNamed: aFilename ^StandardFileStream oldFileNamed: aFilename do: [:aFileStream | (self newDefault materializeHeaderFrom: 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 ! ! !FLMaterializer class methodsFor: 'materializing-shortcuts' stamp: 'MarianoMartinezPeck 7/28/2012 14:58'! materializeHeaderFromFileNamed: aFilename ^ self materializationHeaderFromFileNamed: aFilename ! ! !FLMaterializer class methodsFor: 'protected' stamp: 'MartinDias 2/25/2013 15:07'! currentVersion "If you change this method, you should also create a version in ConfigurationOfFuel and FLSerializer >> currentVersion" ^ 19! ! !FLMaterializer class methodsFor: 'protected' stamp: 'MartinDias 10/6/2011 23:31'! defaultSignature ^ 'FUEL'! ! FLMaterializationError subclass: #FLMethodChanged instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Errors'! !FLMethodChanged commentStamp: '' prior: 0! 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 instanceVariableNames: ''! !FLMethodChanged class methodsFor: 'signaling' stamp: 'MartinDias 3/20/2012 17:47'! signalWith: aGlobalName and: aSelector ^ self signal: 'Method ', aGlobalName, '>>#', aSelector, ' changed its bytecodes.'! ! FLVariableObjectCluster subclass: #FLMethodContextCluster instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Clusters'! !FLMethodContextCluster commentStamp: 'MartinDias 5/30/2011 01:18' prior: 0! 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. ! ! FLSerializationTest subclass: #FLMethodContextSerializationTest instanceVariableNames: 'thisContextSample' classVariableNames: '' poolDictionaries: '' category: 'FuelTests'! !FLMethodContextSerializationTest methodsFor: 'running' stamp: 'MartinDias 3/26/2012 22:52'! setUp super setUp. thisContextSample := self class thisContextSample.! ! !FLMethodContextSerializationTest methodsFor: 'tests' stamp: 'MartinDias 2/18/2013 19:53'! testDoIt "Serialization of DoIt methods should be possible by default." | context | [ Compiler evaluate: 'self error' ] on: Error do: [:error | context:= error signalerContext copyStack ]. self serialize: context! ! !FLMethodContextSerializationTest methodsFor: 'tests' stamp: 'MartinDias 3/28/2012 01:19'! testFuelShouldIgnoreFuel "When serializing contexts, it may happen that internal objects used by Fuel such as clusters, mappers, etc., as found in the temps of the contexts, and hence they are serialized. This is something not desired. With this test we make sure that when we serialize a whole context, there is no Fuel objects. " | context serialization fuelClasses | 3 timesRepeat: [Smalltalk garbageCollect]. context := thisContextSample. fuelClasses := (PackageInfo named: 'Fuel') classes. serialization := self serializationOf: context. serialization clusters do: [:cluster | cluster objects do: [:object | self deny: (fuelClasses includes: object class) ] ]. ! ! !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: '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:21'! testMethodContextWithClosure "This test should be improved" | methodContext1 materializedMethodContext1 | methodContext1 := self class blockClosureContextTesting. materializedMethodContext1 := self resultOfSerializeAndMaterialize: methodContext1. 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'! 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'! 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: '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 class instanceVariableNames: ''! !FLMethodContextSerializationTest class methodsFor: 'closures for testing' stamp: 'MarianoMartinezPeck 5/24/2011 13:44'! blockClosureContextTesting ^ [self class] asContext! ! !FLMethodContextSerializationTest class methodsFor: 'closures for testing' stamp: 'MarianoMartinezPeck 5/24/2011 13:44'! blockClosureContextTestingWithSender: aSenderContext ^ [self class] asContextWithSender: aSenderContext! ! !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: 'running' stamp: 'MartinDias 3/26/2012 22:54'! thisContextSample ^ thisContext copy! ! FLMaterializationError subclass: #FLMethodNotFound instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Errors'! !FLMethodNotFound commentStamp: 'MartinDias 12/16/2011 01:17' prior: 0! 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 instanceVariableNames: ''! !FLMethodNotFound class methodsFor: 'signaling' stamp: 'MartinDias 3/20/2012 17:48'! signalWith: aGlobalName and: aSelector ^ self signal: 'Method ', aGlobalName, '>>#', aSelector, ' not found.'! ! Object subclass: #FLMigration instanceVariableNames: 'sourceClassName variables targetClass' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Core'! !FLMigration commentStamp: 'MartinDias 1/6/2012 16:04' prior: 0! I represent migration information about a class. See 'configuring-migration' protocol in FLMaterializer.! !FLMigration methodsFor: 'accessing' stamp: 'MartinDias 1/5/2012 01:09'! sourceClassName ^ sourceClassName! ! !FLMigration methodsFor: 'accessing' stamp: 'MartinDias 1/5/2012 13:12'! targetClass ^ targetClass! ! !FLMigration methodsFor: 'evaluating' stamp: 'MartinDias 1/5/2012 13:14'! applyTo: aVariablesMapping variables do: [:link | aVariablesMapping map: link key to: link value ] ! ! !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 class instanceVariableNames: ''! !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.! ! FLClassSerializationTest subclass: #FLMigrationTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FuelTests'! !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'! 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-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-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 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"! ! !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: '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-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.! ! FLStreamStrategy subclass: #FLMultiByteStreamStrategy instanceVariableNames: 'inMemoryStream' classVariableNames: '' poolDictionaries: '' category: 'FuelTests-StreamStrategies'! !FLMultiByteStreamStrategy commentStamp: 'MartinDias 10/12/2011 11:37' prior: 0! I am a strategy for MultiByteBinaryOrTextStream..! !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! ! !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 ! ! FLSmallIntegerCluster subclass: #FLNegative16SmallIntegerCluster instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Clusters'! !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! ! FLSmallIntegerCluster subclass: #FLNegative24SmallIntegerCluster instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Clusters'! !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! ! FLSmallIntegerCluster subclass: #FLNegative32SmallIntegerCluster instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Clusters'! !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! ! FLSmallIntegerCluster subclass: #FLNegative8SmallIntegerCluster instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Clusters'! !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! ! FLSerializationError subclass: #FLNotSerializable instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Errors'! !FLNotSerializable commentStamp: '' prior: 0! I represent an error which may happen while tracing in the graph an object that is forbidden of being serialized.! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FLNotSerializable class instanceVariableNames: ''! !FLNotSerializable class methodsFor: 'signaling' stamp: 'MartinDias 5/16/2012 00:39'! signalWith: anObject self signal: 'Found a forbidden object in the graph: ', anObject printString.! ! Object subclass: #FLNotSerializableMock instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FuelTests-Mocks'! !FLNotSerializableMock methodsFor: 'hooks' stamp: 'MartinDias 5/18/2012 17:37'! fuelAccept: aGeneralMapper aGeneralMapper visitNotSerializable: self! ! FLIteratingCluster subclass: #FLObjectCluster instanceVariableNames: 'theClass' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Clusters'! !FLObjectCluster commentStamp: 'MartinDias 8/29/2011 19:20' prior: 0! 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: 'analyzing' stamp: 'MartinDias 5/30/2011 03:45'! clusterReferencesDo: aBlock aBlock value: theClass! ! !FLObjectCluster methodsFor: 'initialize-release' stamp: 'MartinDias 1/11/2012 00:36'! initializeAnalyzing: aClass self initializeAnalyzing. theClass := aClass! ! !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: 'printing' stamp: 'MarianoMartinezPeck 12/9/2011 20:26'! theClass ^ theClass! ! !FLObjectCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 9/19/2012 14:42'! clusterMaterializeStepWith: aMaterialization super clusterMaterializeStepWith: aMaterialization. theClass := aMaterialization decoder nextEncodedReference. ! ! !FLObjectCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 9/19/2012 14:41'! clusterSerializeStepWith: aSerialization super clusterSerializeStepWith: aSerialization. aSerialization encoder encodeReferenceTo: theClass.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FLObjectCluster class instanceVariableNames: ''! !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.! ! FLSerializationError subclass: #FLObjectNotFound instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Errors'! !FLObjectNotFound commentStamp: '' prior: 0! 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 instanceVariableNames: ''! !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.'. ] )! ! FLSerializationError subclass: #FLObsolete instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Errors'! !FLObsolete commentStamp: '' prior: 0! 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 instanceVariableNames: ''! !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.'! ! FLIteratingCluster subclass: #FLOptimizedObjectCluster instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Clusters-Optionals'! !FLOptimizedObjectCluster commentStamp: '' prior: 0! 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: 'MartinDias 12/29/2011 19:48'! materializeReferencesStepWith: aDecoder objects do: [ :anObject | self materializeReferencesOf: anObject with: aDecoder ]! ! !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'! serializeReferencesOf: anObject with: anEncoder ^ self subclassResponsibility ! ! !FLOptimizedObjectCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 19:43'! serializeReferencesStepWith: anEncoder objects do: [ :anObject | self serializeReferencesOf: anObject with: anEncoder ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FLOptimizedObjectCluster class instanceVariableNames: ''! !FLOptimizedObjectCluster class methodsFor: 'analyzing' stamp: 'MartinDias 1/8/2012 15:39'! clusterBucketIn: aClusterization ^aClusterization baselevelBucket ! ! Object subclass: #FLPair instanceVariableNames: 'left right' classVariableNames: '' poolDictionaries: '' category: 'FuelTests-Mocks'! !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 5/23/2011 00:14'! method1 self name. self printString. ! ! !FLPair methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 5/23/2011 00:14'! method2 self name. ! ! !FLPair methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 7/1/2011 11:17'! methodWithTemp | string | string := 'test'. self name. self printString. ! ! !FLPair methodsFor: 'accessing' stamp: 'MartinDias 9/16/2010 19:58'! right ^ right! ! !FLPair methodsFor: 'accessing' stamp: 'MartinDias 9/16/2010 19:58'! right: anObject right := anObject! ! !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: '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: '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: ')'! ! Object subclass: #FLPerson instanceVariableNames: 'id' classVariableNames: '' poolDictionaries: '' category: 'FuelTests-Mocks'! !FLPerson commentStamp: 'MarianoMartinezPeck 5/19/2011 23:51' prior: 0! 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'! = anObject "Answer whether the receiver and anObject represent the same object." self == anObject ifTrue: [ ^ true ]. self class = anObject class ifFalse: [ ^ false ]. ^ id = anObject id! ! !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! ! FLMapper subclass: #FLPluggableSubstitutionMapper instanceVariableNames: 'condition substitutionFactory' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Mappers'! !FLPluggableSubstitutionMapper commentStamp: 'MartinDias 8/20/2011 23:45' prior: 0! 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: 'initialize-release' stamp: 'MartinDias 1/9/2012 14:53'! initializeWith: aCondition substitutionFactory: aBlock self initialize. condition := aCondition. substitutionFactory := aBlock.! ! !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 class instanceVariableNames: ''! !FLPluggableSubstitutionMapper class methodsFor: 'instance creation' stamp: 'MartinDias 1/9/2012 14:52'! when: aCondition substituteBy: aFactory ^self basicNew initializeWith: aCondition substitutionFactory: aFactory; yourself! ! FLSerializationTest subclass: #FLPluggableSubstitutionTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FuelTests'! !FLPluggableSubstitutionTest methodsFor: 'failures' stamp: 'MarianoMartinezPeck 11/17/2012 13:18'! expectedFailures ^ #(testPrivateExcludedAndWithConflicts)! ! !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 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'! 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: '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.! ! !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 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'! 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 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 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.! ! FLOptimizedObjectCluster subclass: #FLPointCluster instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Clusters-Optionals'! !FLPointCluster commentStamp: 'MarianoMartinezPeck 9/8/2011 22:33' prior: 0! 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: 'analyzing' stamp: 'MarianoMartinezPeck 9/8/2011 21:37'! referencesOf: aPoint do: aBlock aBlock value: aPoint x. aBlock value: aPoint y. ! ! !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: '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:43'! serializeReferencesOf: aPoint with: anEncoder anEncoder encodeReferenceTo: aPoint x. anEncoder encodeReferenceTo: aPoint y. ! ! FLObjectCluster subclass: #FLPointerObjectCluster instanceVariableNames: 'variablesMapping' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Clusters'! !FLPointerObjectCluster commentStamp: 'MartinDias 8/1/2011 03:00' prior: 0! I have the common behavior for storing and loading pointer objects.! !FLPointerObjectCluster methodsFor: 'analyzing' stamp: 'MartinDias 12/22/2011 15:07'! referencesOf: anObject do: aBlock variablesMapping referencesOf: anObject do: aBlock! ! !FLPointerObjectCluster methodsFor: 'initialize-release' stamp: 'MartinDias 1/8/2012 14:40'! initializeAnalyzing: aClass super initializeAnalyzing: aClass. variablesMapping := FLVariablesMapping newAnalyzing: theClass. ! ! !FLPointerObjectCluster methodsFor: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 19:48'! afterMaterializationStepWith: aDecoder objects do: [ :anObject | anObject fuelAfterMaterialization ]! ! !FLPointerObjectCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 9/19/2012 14:42'! clusterMaterializeStepWith: aMaterialization super clusterMaterializeStepWith: aMaterialization. variablesMapping := aMaterialization decoder variablesMappingFor: theClass.! ! !FLPointerObjectCluster methodsFor: 'serialize/materialize' stamp: 'MarianoMartinezPeck 9/19/2012 14:41'! clusterSerializeStepWith: aSerialization super clusterSerializeStepWith: aSerialization. variablesMapping serializeOn: aSerialization encoder.! ! !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:48'! materializeReferencesStepWith: aDecoder objects do: [ :anObject | self 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:43'! serializeReferencesStepWith: anEncoder objects do: [ :anObject | self serializeReferencesOf: anObject with: anEncoder ]! ! FLSmallIntegerCluster subclass: #FLPositive16SmallIntegerCluster instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Clusters'! !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! ! FLSmallIntegerCluster subclass: #FLPositive24SmallIntegerCluster instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Clusters'! !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! ! FLSmallIntegerCluster subclass: #FLPositive32SmallIntegerCluster instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Clusters'! !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! ! FLSmallIntegerCluster subclass: #FLPositive8SmallIntegerCluster instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Clusters'! !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! ! FLIteratingCluster subclass: #FLPrimitiveCluster instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Clusters'! !FLPrimitiveCluster commentStamp: 'MartinDias 8/29/2011 19:21' prior: 0! 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: 'analyzing' stamp: 'MartinDias 1/8/2012 13:12'! newAnalyzingCollection "Answer a collection for the objects that correspond to this cluster." ^OrderedCollection new! ! !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 class instanceVariableNames: ''! !FLPrimitiveCluster class methodsFor: 'analyzing' stamp: 'MartinDias 1/8/2012 15:39'! clusterBucketIn: aClusterization ^aClusterization primitivesBucket ! ! Object subclass: #FLProxyThatBecomesItsContent instanceVariableNames: 'contents' classVariableNames: '' poolDictionaries: '' category: 'FuelTests-Mocks'! !FLProxyThatBecomesItsContent commentStamp: 'MartinDias 11/17/2011 03:18' prior: 0! Used at #testObjectByProxyThatBecomesItsContent! !FLProxyThatBecomesItsContent methodsFor: 'initialization' stamp: 'MartinDias 11/17/2011 03:04'! initializeWith: anObject super initialize. contents := anObject! ! !FLProxyThatBecomesItsContent methodsFor: 'serialization' stamp: 'MartinDias 11/17/2011 03:03'! fuelAfterMaterialization self become: contents! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FLProxyThatBecomesItsContent class instanceVariableNames: ''! !FLProxyThatBecomesItsContent class methodsFor: 'instance creation' stamp: 'MartinDias 11/17/2011 02:59'! newWith: aByteSymbol ^self basicNew initializeWith: aByteSymbol; yourself! ! FLOptimizedObjectCluster subclass: #FLRectangleCluster instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Clusters-Optionals'! !FLRectangleCluster commentStamp: 'MarianoMartinezPeck 9/8/2011 22:53' prior: 0! 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: '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.! ! !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: '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:43'! serializeReferencesOf: aRectangle with: anEncoder anEncoder encodeReferenceTo: aRectangle origin x. anEncoder encodeReferenceTo: aRectangle origin y. anEncoder encodeReferenceTo: aRectangle corner x. anEncoder encodeReferenceTo: aRectangle corner y. ! ! Object subclass: #FLSerialization instanceVariableNames: 'encoder root clusters analyzer' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Core'! !FLSerialization commentStamp: 'MarianoMartinezPeck 10/23/2011 14:42' prior: 0! 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/13/2011 16:34'! clusters ^ clusters! ! !FLSerialization methodsFor: 'accessing' stamp: 'MartinDias 12/29/2011 16:55'! encoder ^ encoder! ! !FLSerialization methodsFor: 'accessing' stamp: 'MartinDias 1/6/2012 12:24'! objects "Answer a collection with the serialized objects." ^ encoder objectsIndexes keys! ! !FLSerialization methodsFor: 'accessing' stamp: 'MartinDias 9/9/2011 01:33'! root ^ root! ! !FLSerialization methodsFor: 'hooks' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^ aGeneralMapper visitSubstitution: self by: nil! ! !FLSerialization methodsFor: 'initialize-release' stamp: 'MartinDias 1/5/2012 14:34'! initializeWith: anEncoder root: anObject analyzer: anAnalyzer self initialize. encoder := anEncoder. root := anObject. analyzer := anAnalyzer.! ! !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 17:06'! analysisStep | anAnalysis | anAnalysis := analyzer analysisFor: root. clusters := anAnalysis clusterization clusters. encoder objectCount: anAnalysis clusterization objectCount. ! ! !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: 'private' stamp: 'MartinDias 12/29/2011 18:28'! headerStep encoder encodeYourself. encoder encodePositiveInteger: clusters size.! ! !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 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 class instanceVariableNames: ''! !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! ! FLError subclass: #FLSerializationError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Errors'! !FLSerializationError commentStamp: '' prior: 0! I represent an error happened during serialization.! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FLSerializationError class instanceVariableNames: ''! !FLSerializationError class methodsFor: 'exceptioninstantiator' stamp: 'MartinDias 3/20/2012 12:47'! signal: signalerText ^ super signal: 'Serialization error. ', signalerText ! ! TestCase subclass: #FLSerializationTest instanceVariableNames: 'serializer materializer classFactory streamFactory' classVariableNames: '' poolDictionaries: '' category: 'FuelTests'! !FLSerializationTest methodsFor: 'accessing' stamp: 'MartinDias 10/7/2011 16:33'! analyzer ^serializer analyzer! ! !FLSerializationTest methodsFor: 'accessing' stamp: 'MartinDias 10/7/2011 16:31'! classFactory ^classFactory! ! !FLSerializationTest methodsFor: 'accessing' stamp: 'MartinDias 10/6/2011 23:44'! materializer ^materializer! ! !FLSerializationTest methodsFor: 'accessing' stamp: 'MartinDias 10/6/2011 23:44'! serializer ^serializer! ! !FLSerializationTest methodsFor: 'accessing' stamp: 'MartinDias 10/12/2011 10:57'! streamFactory ^streamFactory! ! !FLSerializationTest methodsFor: 'class-factory' stamp: 'MarianoMartinezPeck 4/19/2012 19:14'! newClass ^ self newSubclassOf: Object instanceVariableNames: '' classVariableNames: '' ! ! !FLSerializationTest methodsFor: 'class-factory' stamp: 'MarianoMartinezPeck 4/19/2012 19:28'! newClassInCategory: aCategory ^ self classFactory silentlyNewClassInCategory: aCategory! ! !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: 'class-factory' stamp: 'MarianoMartinezPeck 4/19/2012 19:18'! withNotificationsNewClass ^ self classFactory withNotificationsNewClass! ! !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: 'cleaning' stamp: 'MartinDias 2/16/2013 19:42'! deleteFileNamed: aFilename aFilename asFileReference ensureDeleted! ! !FLSerializationTest methodsFor: 'cleaning' stamp: 'MarianoMartinezPeck 4/19/2012 19:39'! removeFromSystem: aClassOrTrait aClassOrTrait removeFromSystem: false! ! !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: '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 1/6/2012 11:07'! materialization self streamFactory readStreamDo: [:aStream | ^ self materializer materializeFrom: aStream ]! ! !FLSerializationTest methodsFor: 'running' stamp: 'MarianoMartinezPeck 7/28/2012 15:03'! materializationHeader self streamFactory readStreamDo: [:aStream | ^ self materializer materializeHeaderFrom: aStream ]! ! !FLSerializationTest methodsFor: 'running' stamp: 'MartinDias 1/6/2012 11:07'! materialized ^ self materialization root! ! !FLSerializationTest methodsFor: 'running' stamp: 'MartinDias 1/6/2012 11:07'! materializedObjects ^ self materialization objects! ! !FLSerializationTest methodsFor: 'running' stamp: 'MartinDias 10/12/2011 10:56'! resultOfSerializeAndMaterialize: anObject self serialize: anObject. ^ self materialized ! ! !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 5/11/2012 10:46'! resultOfSerializeAndMaterializeMethod: aCompiledMethod self analyzer considerInternalMethod: aCompiledMethod. self serialize: aCompiledMethod. ^ self materialized ! ! !FLSerializationTest methodsFor: 'running' stamp: 'MarianoMartinezPeck 4/20/2012 21:35'! resultOfSerializeAndMaterializeMethodDictionary: aMethodDictionary | materialized | materialized := self resultOfSerializeAndMaterialize: aMethodDictionary. self assert: (materialized isEqualRegardlessMethodsTrailerTo: aMethodDictionary)! ! !FLSerializationTest methodsFor: 'running' stamp: 'MarianoMartinezPeck 12/9/2011 20:28'! serializationOf: anObject self streamFactory writeStreamDo: [:aStream | ^ serializer serialize: anObject on: aStream. ]. ! ! !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: 'MartinDias 10/12/2011 10:58'! serialize: anObject self streamFactory writeStreamDo: [:aStream | self serializer serialize: anObject on: aStream ]! ! !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: 'running' stamp: 'MartinDias 10/6/2011 23:52'! setUpMaterializer materializer := FLMaterializer newDefault! ! !FLSerializationTest methodsFor: 'running' stamp: 'MartinDias 10/6/2011 23:52'! setUpSerializer serializer := FLSerializer newDefault! ! !FLSerializationTest methodsFor: 'running' stamp: 'MarianoMartinezPeck 8/19/2012 23:36'! 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.! ! !FLSerializationTest methodsFor: 'running' stamp: 'MartinDias 10/8/2011 01:26'! tearDownClassFactory self classFactory cleanUp! ! !FLSerializationTest methodsFor: 'running' stamp: 'MartinDias 12/30/2011 19:03'! tearDownGlobalVariables Smalltalk globals removeKey: #FLGlobalVariableForTesting ifAbsent: []! ! !FLSerializationTest methodsFor: 'running' stamp: 'MartinDias 10/8/2011 04:05'! tearDownTraits self cleanUpTraits! ! !FLSerializationTest methodsFor: 'stream-strategies' stamp: 'MartinDias 10/12/2011 18:42'! useGzipInMemoryStream streamFactory := FLGZipStrategy newWithTarget: FLByteArrayStreamStrategy new! ! !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: 'stream-strategies' stamp: 'MartinDias 10/12/2011 11:21'! useMemoryStream streamFactory := FLMultiByteStreamStrategy new! ! !FLSerializationTest methodsFor: 'stream-strategies' stamp: 'MartinDias 12/7/2011 02:11'! useMultiByteFileStream streamFactory := FLFileStreamStrategy newWithMultiByteFileStream! ! !FLSerializationTest methodsFor: 'stream-strategies' stamp: 'MartinDias 12/7/2011 02:11'! useStandardFileStream streamFactory := FLFileStreamStrategy newWithStandardFileStream! ! !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: '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: '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: 'traits-factory' stamp: 'MartinDias 10/8/2011 04:03'! traitNamePrefix ^'FLTraitForTesting'! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FLSerializationTest class instanceVariableNames: ''! !FLSerializationTest class methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 10/31/2011 11:58'! packageNamesUnderTest ^ #('Fuel')! ! Object subclass: #FLSerializer instanceVariableNames: 'analyzer serializationFactory signature version stream header' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Core'! !FLSerializer commentStamp: 'MartinDias 8/29/2011 19:10' prior: 0! 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: 'MarianoMartinezPeck 10/3/2011 16:18'! analyzer analyzer isNil ifTrue: [ analyzer := self defaultAnalyzer ]. ^ analyzer! ! !FLSerializer methodsFor: 'accessing' stamp: 'MartinDias 8/20/2011 17:33'! analyzer: anObject analyzer := anObject! ! !FLSerializer methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 8/21/2012 16:49'! header ^ header! ! !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: 'accessing' stamp: 'MarianoMartinezPeck 5/30/2012 21:50'! stream: aStream stream := aStream! ! !FLSerializer methodsFor: 'accessing' stamp: 'MartinDias 10/6/2011 22:56'! version ^ version! ! !FLSerializer methodsFor: 'accessing' stamp: 'MartinDias 10/6/2011 22:56'! version: anObject version := anObject! ! !FLSerializer methodsFor: 'header' stamp: 'MarianoMartinezPeck 7/28/2012 12:32'! addPostMaterializationAction: aCleanBlockClosure header addPostMaterializationAction: aCleanBlockClosure! ! !FLSerializer methodsFor: 'header' stamp: 'MarianoMartinezPeck 7/28/2012 11:38'! addPreMaterializationAction: aCleanBlockClosure header addPreMaterializationAction: aCleanBlockClosure! ! !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: 'hooks' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^ aGeneralMapper visitSubstitution: self by: nil! ! !FLSerializer methodsFor: 'initialize-release' 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: 'protected' stamp: 'MartinDias 9/13/2011 19:26'! defaultAnalyzer ^FLAnalyzer newDefault! ! !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/7/2012 12:07'! encodeSignatureWith: anEncoder anEncoder encodeBytes: self signature asByteArray! ! !FLSerializer methodsFor: 'protected' stamp: 'MartinDias 1/7/2012 12:07'! encodeVersionWith: anEncoder anEncoder encodeUint16: self version ! ! !FLSerializer methodsFor: 'protected' stamp: 'MartinDias 1/6/2012 20:31'! serializationFactory ^ serializationFactory ifNil: [ self setDefaultSerialization. serializationFactory ].! ! !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: '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: '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: '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 class instanceVariableNames: ''! !FLSerializer class methodsFor: 'instance creation' stamp: 'MartinDias 9/25/2011 20:12'! newDefault ^self newLight! ! !FLSerializer class methodsFor: 'instance creation' stamp: 'MartinDias 9/25/2011 20:12'! newLight ^self new! ! !FLSerializer class methodsFor: 'instance creation' stamp: 'MarianoMartinezPeck 5/30/2012 21:48'! on: aStream ^ self newLight stream: aStream; yourself! ! !FLSerializer class methodsFor: 'protected' stamp: 'MartinDias 2/25/2013 15:07'! currentVersion "If you change this method, you should also create a version in ConfigurationOfFuel and FLMaterializer >> currentVersion" ^ 19! ! !FLSerializer class methodsFor: 'protected' stamp: 'MartinDias 10/6/2011 23:28'! defaultSignature ^ 'FUEL'! ! !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: 'serializing-shortcuts' stamp: 'mada 5/10/2012 20:56'! serialize: anObject toFileNamed: aFilename self newDefault serialize: anObject toFileNamed: aFilename! ! !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! ! FLSerializationTest subclass: #FLSignatureTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FuelTests'! !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.'! ! !FLSignatureTest methodsFor: 'tests' stamp: 'MartinDias 10/7/2011 12:22'! testSameSignature serializer signature: 'FUELx'. materializer signature: 'FUELx'. self assertSerializationEqualityOf: 'content'! ! FLAbstractCollectionCluster subclass: #FLSimpleCollectionCluster instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Clusters-Optionals'! !FLSimpleCollectionCluster commentStamp: '' prior: 0! 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: 'analyzing' stamp: 'MarianoMartinezPeck 7/28/2012 22:27'! referencesOf: anObject do: aBlock aBlock value: anObject size. anObject do: [ :each | aBlock value: each ] ! ! !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: 'MarianoMartinezPeck 7/26/2012 16:10'! serializeReferencesOf: anObject with: anEncoder anEncoder encodePositiveInteger: anObject size. anObject do: [ :each | anEncoder encodeReferenceTo: each ] ! ! Object subclass: #FLSimpleStack instanceVariableNames: 'array slotIndex' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Collections'! !FLSimpleStack commentStamp: 'MarianoMartinezPeck 6/5/2011 12:29' prior: 0! 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: '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: '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: '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 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: '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 class instanceVariableNames: ''! !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! ! !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! ! TestCase subclass: #FLSimpleStackTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FuelTests-Collections'! !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: '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'! testPop | stack | stack := FLSimpleStack new. stack push: 1. stack pop. 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.! ! !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.! ! Object subclass: #FLSingletonMock instanceVariableNames: 'reference' classVariableNames: 'Instance' poolDictionaries: '' category: 'FuelTests-Mocks'! !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 instanceVariableNames: ''! !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!!'! ! FLSingletonMock subclass: #FLSingletonMockEnforced instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FuelTests-Mocks'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FLSingletonMockEnforced class instanceVariableNames: ''! !FLSingletonMockEnforced class methodsFor: 'fuel' stamp: 'MaxLeske 2/20/2013 23:13'! fuelNew ^ self instance! ! FLSerializationTest subclass: #FLSingletonTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FuelTests'! !FLSingletonTest methodsFor: 'running' stamp: 'MML 10/19/2012 17:28'! setUp super setUp. FLSingletonMock reset! ! !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: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"! ! !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"! ! FLPrimitiveCluster subclass: #FLSmallIntegerCluster instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Clusters'! !FLSmallIntegerCluster commentStamp: 'MartinDias 1/7/2012 11:57' prior: 0! I don't have so much sense as a class.! FLSerializationTest subclass: #FLSortedCollectionSerializationTest instanceVariableNames: 'instanceVariableForTesting' classVariableNames: 'ClassVariableForTesting' poolDictionaries: '' category: 'FuelTests'! !FLSortedCollectionSerializationTest methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 6/8/2011 17:50'! classVariableForTesting ^ ClassVariableForTesting! ! !FLSortedCollectionSerializationTest methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 6/8/2011 17:50'! classVariableForTesting: anObject ClassVariableForTesting := anObject ! ! !FLSortedCollectionSerializationTest methodsFor: 'running' stamp: 'MartinDias 3/26/2012 21:40'! sortedBlockClosureWithInstanceVariable ^ SortedCollection sortBlock: [ :a :b | instanceVariableForTesting ifTrue: [ a <= b ] ifFalse: [ a >= b ] ]! ! !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: 'MarianoMartinezPeck 6/8/2011 23:21'! 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 | ClassVariableForTesting := false. aSortedCollection := self class sortedCollectionForTestingWithClassVariable. materialized := self resultOfSerializeAndMaterialize: aSortedCollection. "the class variable ClassVariableForTesting should be false" self deny: (materialized sortBlock outerContext method literalAt: 3) value. ClassVariableForTesting := true. "the class variable ClassVariableForTesting should be true" self assert: (materialized sortBlock outerContext method literalAt: 3) value. ! ! !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: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: '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 class instanceVariableNames: ''! !FLSortedCollectionSerializationTest class methodsFor: 'sorted collections for testing' stamp: 'MarianoMartinezPeck 6/8/2011 18:05'! sortedCollectionForTestingWithClassVariable. ^ SortedCollection sortBlock: [:a :b | ClassVariableForTesting ifTrue: [ a <= b ] ifFalse: [ a >= b ] ]. ! ! Object subclass: #FLStreamStrategy instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FuelTests-StreamStrategies'! !FLStreamStrategy commentStamp: 'MartinDias 10/12/2011 11:36' prior: 0! I am a strategy that help tests for writing (and then reading) on streams.! !FLStreamStrategy methodsFor: 'reading' stamp: 'MartinDias 10/12/2011 10:18'! readStreamDo: aValuable "Evaluates the argument with a read stream. Answer the result." self subclassResponsibility ! ! !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 ! ! FLCluster subclass: #FLSubstitutionCluster instanceVariableNames: 'substitutions substitutes' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Clusters'! !FLSubstitutionCluster commentStamp: 'MartinDias 1/9/2012 15:04' prior: 0! 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: 'accessing' stamp: 'MartinDias 8/29/2011 01:04'! objects "This cluster does not have objects" ^#()! ! !FLSubstitutionCluster methodsFor: 'accessing' stamp: 'MarianoMartinezPeck 5/15/2012 11:52'! substitutions ^ substitutions ! ! !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 methodsFor: 'initialize-release' stamp: 'MartinDias 5/9/2012 00:14'! initializeAnalyzing super initializeAnalyzing. substitutions := IdentityDictionary new. substitutes := IdentitySet new.! ! !FLSubstitutionCluster methodsFor: 'printing' stamp: 'MartinDias 8/29/2011 01:16'! printOn: aStream super printOn: aStream. aStream nextPutAll: '->'. substitutions printElementsOn: aStream! ! !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 class instanceVariableNames: ''! !FLSubstitutionCluster class methodsFor: 'analyzing' stamp: 'MartinDias 1/8/2012 15:39'! clusterBucketIn: aClusterization ^aClusterization substitutionsBucket! ! Trait named: #FLTGlobalClassOrTraitSerializationTest uses: {} category: 'FuelTests'! !FLTGlobalClassOrTraitSerializationTest commentStamp: '' prior: 0! I test the serialization of classes and traits as *external* objects, i.e. the classes or traits have to be present in the image at materialization time.! !FLTGlobalClassOrTraitSerializationTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 4/19/2012 12:59'! 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.' ! ! !FLTGlobalClassOrTraitSerializationTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 4/19/2012 12:59'! 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! ! !FLTGlobalClassOrTraitSerializationTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 4/19/2012 19:38'! 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.' ! ! !FLTGlobalClassOrTraitSerializationTest methodsFor: 'tests' stamp: 'MartinDias 11/28/2011 01:03'! testClassSidePreservesIdentity "Tests that serialization of the class side preserves identity" self assertSerializationIdentityOf: self newClassOrTrait classSide ! ! !FLTGlobalClassOrTraitSerializationTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 4/19/2012 12:59'! 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.' ! ! !FLTGlobalClassOrTraitSerializationTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 4/19/2012 12:59'! 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! ! !FLTGlobalClassOrTraitSerializationTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 4/19/2012 19:37'! 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.! ! !FLTGlobalClassOrTraitSerializationTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 4/19/2012 18:47'! 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.! ! !FLTGlobalClassOrTraitSerializationTest methodsFor: 'tests' stamp: 'MarianoMartinezPeck 4/19/2012 19:37'! 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.' ! ! !FLTGlobalClassOrTraitSerializationTest methodsFor: 'tests' stamp: 'MartinDias 11/27/2011 21:08'! testPreservesIdentity "Tests that serialization of the class or trait preserves identity" self assertSerializationIdentityOf: self newClassOrTrait! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FLTGlobalClassOrTraitSerializationTest classTrait uses: {}! FLSerializationTest subclass: #FLTraitSerializationTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FuelTests'! !FLTraitSerializationTest commentStamp: '' prior: 0! I have the common behavior for testing trait serialization.! !FLTraitSerializationTest methodsFor: 'running' stamp: 'MartinDias 10/8/2011 04:14'! newClassOrTrait "Returns a trait for testing" ^ self newTraitSuffixed: 'Main'! ! !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'! newSecondaryTrait "Returns a trait for testing" ^ self newTraitSuffixed: 'Secondary'! ! FLSerializationTest subclass: #FLUserGuidesTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FuelTests'! !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-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: '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.! ! !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/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 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 14:32'! testMemoryStream | anArray materializedString | anArray := FLSerializer serializeToByteArray: 'stringToSerialize'. materializedString := FLMaterializer materializeFromByteArray: anArray. ! ! !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-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. ! ! FLPointerObjectCluster subclass: #FLVariableObjectCluster instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Clusters'! !FLVariableObjectCluster commentStamp: 'MartinDias 5/30/2011 01:25' prior: 0! I am a generic cluster for objects with indexable variables.! !FLVariableObjectCluster methodsFor: 'analyzing' stamp: 'MartinDias 12/22/2011 14:22'! referencesOf: anObject do: aBlock super referencesOf: anObject do: aBlock. self variablePartReferencesOf: anObject do: aBlock. ! ! !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 2/20/2013 21:46'! materializeInstanceWith: aDecoder ^theClass fuelNew: aDecoder nextEncodedPositiveInteger! ! !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 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 12/29/2011 19:44'! serializeInstance: anObject with: anEncoder anEncoder encodePositiveInteger: anObject basicSize! ! !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: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 19:44'! serializeReferencesVariablePartOf: anObject with: anEncoder 1 to: anObject basicSize do: [ :index | anEncoder encodeReferenceTo: (anObject basicAt: index) ]! ! Object subclass: #FLVariablesMapping instanceVariableNames: 'mapping theClass notIgnoredVariables' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Clusters'! !FLVariablesMapping commentStamp: 'MartinDias 8/1/2011 03:01' prior: 0! 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: '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: '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: 'MartinDias 12/22/2011 14:41'! initializeWith: aClass self initialize. theClass := aClass! ! !FLVariablesMapping methodsFor: 'serialize/materialize' stamp: 'MartinDias 1/8/2012 14:42'! initializeAnalyzing notIgnoredVariables := self instanceVariableNamesToSerialize. mapping := notIgnoredVariables collect: [ :name | theClass instVarIndexFor: name ].! ! !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 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: 'MartinDias 12/29/2011 20:10'! serializeOn: anEncoder anEncoder encodeByte: notIgnoredVariables size. notIgnoredVariables do: [ :name | anEncoder encodeString: name ].! ! !FLVariablesMapping methodsFor: 'serialize/materialize' stamp: 'MartinDias 5/11/2012 14:08'! serializeReferencesOf: anObject with: anEncoder mapping do: [ :index | anEncoder encodeReferenceTo: (anObject instVarAt: index) ].! ! !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 class instanceVariableNames: ''! !FLVariablesMapping class methodsFor: 'instance creation' stamp: 'MartinDias 1/7/2012 11:54'! materializing: aClass from: aDecoder ^ self basicNew initializeWith: aClass; initializeMaterializingFrom: aDecoder; yourself.! ! !FLVariablesMapping class methodsFor: 'instance creation' stamp: 'MartinDias 1/8/2012 14:42'! newAnalyzing: aClass ^ self basicNew initializeWith: aClass; initializeAnalyzing; yourself.! ! FLSerializationTest subclass: #FLVersionTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FuelTests'! !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'! ! FLPair weakSubclass: #FLWeakClassMock instanceVariableNames: 'instVar1' classVariableNames: '' poolDictionaries: '' category: 'FuelTests-Mocks'! !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! ! FLSerializationTest subclass: #FLWeakObjectsTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FuelTests'! !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: '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 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: '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). ! ! FLVariableObjectCluster subclass: #FLWeakVariableObjectCluster instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Clusters'! !FLWeakVariableObjectCluster commentStamp: '' prior: 0! I am a cluster for objects with weak indexable variables.! !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: '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: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 19:44'! serializeReferencesVariablePartOf: anObject with: anEncoder 1 to: anObject basicSize do: [ :index | anEncoder encodeWeakReferenceTo: (anObject basicAt: index) ]! ! FLBitsObjectCluster subclass: #FLWordObjectCluster instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel-Clusters'! !FLWordObjectCluster commentStamp: 'MarianoMartinezPeck 9/6/2011 22:50' prior: 0! 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: 'endianness' stamp: 'MarianoMartinezPeck 9/6/2011 12:34'! swapBytesOf: aWordObject Bitmap swapBytesIn: aWordObject from: 1 to: aWordObject basicSize. ^ 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: 'serialize/materialize' stamp: 'MartinDias 12/29/2011 20:05'! serializeInstance: aWordObject with: anEncoder anEncoder encodePositiveInteger: aWordObject basicSize. anEncoder encodeWords: aWordObject ! ! Object subclass: #FT2BitmapSize instanceVariableNames: 'height width size xPpEm yPpEm' classVariableNames: '' poolDictionaries: '' category: 'FreeType-Base'! !FT2BitmapSize commentStamp: '' prior: 0! 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. ! SharedPool subclass: #FT2Constants instanceVariableNames: '' classVariableNames: 'LoadCropBitmap LoadDefault LoadForceAutohint LoadIgnoreGlobalAdvanceWidth LoadIgnoreTransform LoadLinearDesign LoadMonochrome LoadNoAutohint LoadNoBitmap LoadNoHinting LoadNoRecurse LoadNoScale LoadPedantic LoadRender LoadSbitsOnly LoadTargetLCD LoadTargetLCDV LoadTargetLight LoadTargetMono LoadTargetNormal LoadVerticalLayout PixelModeGray PixelModeGray2 PixelModeGray4 PixelModeLCD PixelModeLCDV PixelModeMono PixelModeNone RenderModeLCD RenderModeLCDV RenderModeLight RenderModeMono RenderModeNormal StyleFlagBold StyleFlagItalic' poolDictionaries: '' category: 'FreeType-Base'! !FT2Constants commentStamp: '' prior: 0! 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 instanceVariableNames: ''! !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. ! ! Error subclass: #FT2Error instanceVariableNames: 'errorCode errorString' classVariableNames: '' poolDictionaries: '' category: 'FreeType-Base'! !FT2Error commentStamp: '' prior: 0! 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: $] ]]! ! FT2Handle subclass: #FT2Face instanceVariableNames: 'numFaces faceIndex faceFlags styleFlags numGlyphs familyName styleName numFixedSizes availableSizes numCharmaps charmaps bbox unitsPerEm ascender descender height maxAdvanceWidth maxAdvanceHeight underlinePosition underlineThickness glyph encoding platformId encodingId size' classVariableNames: '' poolDictionaries: '' category: 'FreeType-Base'! !FT2Face commentStamp: '' prior: 0! 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: 'accessing' stamp: 'nk 11/3/2004 11:56'! ascender ^ascender! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! availableSizes ^availableSizes! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 17:06'! bbox bbox ifNil: [bbox := Rectangle new. self primLoadBbox: bbox]. ^ bbox! ! !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: 'accessing' stamp: 'nk 11/3/2004 11:56'! descender ^descender! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 20:46'! encoding encoding ifNil: [ self getCharMap ]. ^encoding! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! faceFlags ^faceFlags! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! faceIndex ^faceIndex! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! familyName ^familyName! ! !FT2Face methodsFor: 'accessing' stamp: 'bf 11/17/2005 15:56'! glyph glyph ifNil: [ glyph := FT2GlyphSlot fromFace: self ]. ^glyph! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! height ^height! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! maxAdvanceHeight ^maxAdvanceHeight! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! maxAdvanceWidth ^maxAdvanceWidth! ! !FT2Face methodsFor: 'accessing' stamp: 'tween 7/24/2006 22:49'! memoryFaceData self subclassResponsibility! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! numCharmaps ^numCharmaps! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! numFaces ^numFaces! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! numFixedSizes ^numFixedSizes! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! numGlyphs ^numGlyphs! ! !FT2Face methodsFor: 'accessing' stamp: 'tween 8/11/2007 11:24'! postscriptName ^self primGetPostscriptName! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! size ^size! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! styleFlags ^styleFlags! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! styleName ^styleName! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! underlinePosition ^underlinePosition! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! underlineThickness ^underlineThickness! ! !FT2Face methodsFor: 'accessing' stamp: 'nk 11/3/2004 11:56'! unitsPerEm ^unitsPerEm! ! !FT2Face methodsFor: 'charmaps' stamp: 'nk 11/3/2004 19:36'! getCharMap self primGetCharMap.! ! !FT2Face methodsFor: 'charmaps' stamp: 'nk 11/3/2004 20:38'! getCharMapsInto: array self primGetCharMapsInto: array.! ! !FT2Face methodsFor: 'charmaps' stamp: 'nk 11/3/2004 20:39'! setCharMap: encodingString self primSetCharMap: encodingString. 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: 'glyphs' stamp: 'MichaelRueger 12/16/2009 15:41'! glyphOfCharacter: aCharacter fontSize: fontSize ^self glyphOfCharacter: aCharacter pixelSize: fontSize@fontSize! ! !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: '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: '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: 'glyphs' stamp: 'nk 11/3/2004 18:23'! setPixelWidth: x height: y self primSetPixelWidth: x height: y! ! !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: '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: '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: 'outlines' stamp: 'MichaelRueger 12/16/2009 14:59'! characterOutline: aCharacter ^self loadCharacterOutline: aCharacter asUnicode flags: LoadIgnoreTransform! ! !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: 'printing' stamp: 'tween 7/28/2006 14:53'! printOn: aStream super printOn: aStream. handle isNil ifTrue: [^self]. "self familyName isNil ifTrue: [ self loadFields ]." aStream nextPut: $[; nextPutAll: (self familyName ifNil: ['?']); space; nextPutAll: (self styleName ifNil: ['?']); nextPut: $]! ! !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: '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: '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: '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: 'rendering' stamp: 'tween 8/2/2006 21:19'! emboldenOutline: strength ^self primEmboldenGlyphSlotOutline: (strength * 64) rounded! ! !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: '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: '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: '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: '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: 'testing' stamp: 'tween 8/7/2006 08:46'! isBold styleFlags == nil ifTrue:[^false]. ^styleFlags allMask: StyleFlagBold! ! !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: 'testing' stamp: 'tween 8/7/2006 08:47'! isItalic styleFlags == nil ifTrue:[^false]. ^styleFlags allMask: StyleFlagItalic! ! !FT2Face methodsFor: 'testing' stamp: 'tween 8/7/2006 08:47'! isRegular styleFlags == nil ifTrue:[^true]. ^styleFlags = 0! ! !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: 'private' stamp: 'tween 7/29/2006 11:31'! primLoadFields ^self primitiveFailed! ! !FT2Face methodsFor: 'private-primitives' stamp: 'tween 8/6/2006 15:47'! primDestroyHandle ^self primitiveFailed.! ! !FT2Face methodsFor: 'private-primitives' stamp: 'tween 8/2/2006 21:14'! primEmboldenGlyphSlotOutline: strengthInteger ^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: 'private-primitives' stamp: 'nk 11/3/2004 19:35'! primGetCharMap ^self primitiveFailed! ! !FT2Face methodsFor: 'private-primitives' stamp: 'nk 11/4/2004 13:35'! primGetCharMapsInto: array ^self primitiveFailed.! ! !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: 'tween 8/11/2007 11:24'! primGetPostscriptName ^nil! ! !FT2Face methodsFor: 'private-primitives' stamp: 'jl 5/30/2006 15:59'! primGetTrackKerningPointSize: pointSize degree: degree ^self primitiveFailed.! ! !FT2Face methodsFor: 'private-primitives' stamp: 'jl 5/29/2006 15:52'! primHasKerning ^self primitiveFailed.! ! !FT2Face methodsFor: 'private-primitives' stamp: 'nk 11/4/2004 13:34'! primLoadBbox: aRectangle ^self primitiveFailed.! ! !FT2Face methodsFor: 'private-primitives' stamp: 'nk 11/3/2004 18:05'! primLoadCharacter: index flags: flags ^self primitiveFailed! ! !FT2Face methodsFor: 'private-primitives' stamp: 'nk 11/3/2004 18:05'! primLoadGlyph: index flags: flags ^self primitiveFailed! ! !FT2Face methodsFor: 'private-primitives' stamp: 'nk 11/3/2004 15:58'! primNewFaceFromFile: fileName index: anInteger ^self primitiveFailed! ! !FT2Face methodsFor: 'private-primitives' stamp: 'tween 7/24/2006 21:10'! primNewMemoryFaceByteSize: anInteger index: anInteger2 ^self primitiveFailed! ! !FT2Face methodsFor: 'private-primitives' stamp: 'bf 11/19/2005 12:56'! primRenderGlyphIntoForm: aForm ^self primitiveFailed! ! !FT2Face methodsFor: 'private-primitives' stamp: 'tween 8/13/2006 15:56'! primRenderGlyphIntoForm: aForm pixelMode: anInteger ^self primitiveFailed! ! !FT2Face methodsFor: 'private-primitives' stamp: 'bf 11/18/2005 19:33'! primSetBitmapLeft: x top: y ^self primitiveFailed.! ! !FT2Face methodsFor: 'private-primitives' stamp: 'nk 11/3/2004 19:35'! primSetCharMap: encodingString ^self primitiveFailed! ! !FT2Face methodsFor: 'private-primitives' stamp: 'nk 11/4/2004 13:35'! primSetPixelWidth: x height: y ^self primitiveFailed.! ! !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 20:45'! primTransformGlyphSlotOutline: anIntegerArray ^self primitiveFailed.! ! !FT2Face methodsFor: 'private-primitives' stamp: 'tween 8/2/2006 20:45'! primTranslateGlyphSlotOutline: anIntegerArray ^self primitiveFailed.! ! Object subclass: #FT2GlyphSlot instanceVariableNames: 'face linearHorizontalAdvance linearVerticalAdvance advanceX advanceY format bitmapLeft bitmapTop width height hBearingX hBearingY hAdvance vBearingX vBearingY vAdvance outline' classVariableNames: '' poolDictionaries: 'FT2Constants' category: 'FreeType-Base'! !FT2GlyphSlot commentStamp: '' prior: 0! 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: 'bf 11/19/2005 17:16'! advance ^advanceX@advanceY! ! !FT2GlyphSlot methodsFor: 'accessing-convenience' stamp: 'bf 11/20/2005 14:42'! extent ^width@height! ! !FT2GlyphSlot methodsFor: 'accessing-convenience' stamp: 'bf 11/20/2005 14:56'! hBearing ^hBearingX@hBearingY! ! !FT2GlyphSlot methodsFor: 'accessing-convenience' stamp: 'tween 8/5/2007 11:14'! linearAdvance ^"("(linearHorizontalAdvance @ linearVerticalAdvance) "* 2540) rounded" ! ! !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-fields' stamp: 'nk 11/3/2004 12:11'! advanceX ^advanceX! ! !FT2GlyphSlot methodsFor: 'accessing-fields' stamp: 'nk 11/3/2004 12:11'! advanceY ^advanceY! ! !FT2GlyphSlot methodsFor: 'accessing-fields' stamp: 'nk 11/3/2004 12:11'! bitmapLeft ^bitmapLeft! ! !FT2GlyphSlot methodsFor: 'accessing-fields' stamp: 'nk 11/3/2004 12:11'! bitmapTop ^bitmapTop! ! !FT2GlyphSlot methodsFor: 'accessing-fields' stamp: 'nk 11/3/2004 12:11'! format ^format! ! !FT2GlyphSlot methodsFor: 'accessing-fields' stamp: 'bf 11/20/2005 14:52'! hBearingX ^hBearingX! ! !FT2GlyphSlot methodsFor: 'accessing-fields' stamp: 'bf 11/20/2005 14:52'! hBearingY ^hBearingY! ! !FT2GlyphSlot methodsFor: 'accessing-fields' stamp: 'bf 11/20/2005 14:53'! height ^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'! linearVerticalAdvance ^linearVerticalAdvance! ! !FT2GlyphSlot methodsFor: 'accessing-fields' stamp: 'MichaelRueger 12/16/2009 15:10'! outline ^outline! ! !FT2GlyphSlot methodsFor: 'accessing-fields' stamp: 'MichaelRueger 12/16/2009 15:00'! outline: anOutline outline := anOutline! ! !FT2GlyphSlot methodsFor: 'accessing-fields' stamp: 'bf 11/20/2005 14:53'! width ^width! ! !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: 'private' stamp: 'nk 11/3/2004 17:58'! primLoadFrom: anFT2Face ^self primitiveFailed.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FT2GlyphSlot class instanceVariableNames: ''! !FT2GlyphSlot class methodsFor: 'instance creation' stamp: 'nk 11/3/2004 17:38'! fromFace: anFT2Face ^(super new) loadFrom: anFT2Face; yourself.! ! Object subclass: #FT2Handle instanceVariableNames: 'handle' classVariableNames: 'Registry Session' poolDictionaries: 'FT2Constants' category: 'FreeType-Base'! !FT2Handle commentStamp: '' prior: 0! handle holds a (typically 32-bit) pointer to an externally managed object.! !FT2Handle methodsFor: 'comparing' stamp: 'Igor.Stasenko 10/12/2010 19:47'! = anObject ^ (self class == anObject class) and: [ handle = anObject handle ]! ! !FT2Handle methodsFor: 'comparing' stamp: 'Igor.Stasenko 10/12/2010 19:48'! hash ^ handle hash! ! !FT2Handle methodsFor: 'error handling' stamp: 'nk 11/3/2004 13:51'! errorCode ^self primitiveFailed! ! !FT2Handle methodsFor: 'error handling' stamp: 'nk 11/3/2004 21:07'! errorString ^self primitiveFailed! ! !FT2Handle methodsFor: 'error handling' stamp: 'nk 11/4/2004 13:32'! primitiveFailed ^self primitiveFailed: 'Freetype2 primitive failed'! ! !FT2Handle methodsFor: 'error handling' stamp: 'nk 11/4/2004 13:33'! primitiveFailed: aString ^FT2Error new signal: aString! ! !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: 'initialize-release' stamp: 'nk 3/11/2005 18:44'! initialize self shouldNotImplement.! ! !FT2Handle methodsFor: 'printing' stamp: 'nk 3/17/2005 16:40'! isValid ^handle notNil and: [ handle anySatisfy: [ :b | b isZero not ] ]! ! !FT2Handle methodsFor: 'printing' stamp: 'StephaneDucasse 3/17/2010 20:56'! printOn: aStream | handleHex | super printOn: aStream. handle isNil ifTrue: [ ^aStream nextPutAll: '' ]. handleHex := (handle unsignedLongAt: 1 bigEndian: Smalltalk isBigEndian) printStringHex. aStream nextPutAll: '<0x'; nextPutAll: handleHex; nextPut: $>.! ! !FT2Handle methodsFor: 'private' stamp: 'nk 11/3/2004 16:10'! beNull handle := nil.! ! !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: 'private' stamp: 'nk 11/3/2004 21:19'! handle ^handle! ! !FT2Handle methodsFor: 'private' stamp: 'nk 11/3/2004 12:21'! primDestroyHandle self subclassResponsibility! ! !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 class instanceVariableNames: ''! !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: 'error reporting' stamp: 'nk 11/3/2004 13:51'! errorCode ^self primitiveFailed! ! !FT2Handle class methodsFor: 'error reporting' stamp: 'nk 11/3/2004 15:49'! errorString ^self primitiveFailed! ! !FT2Handle class methodsFor: 'error reporting' stamp: 'nk 11/3/2004 15:50'! moduleErrorCode ^self primitiveFailed! ! !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/9/2012 18:51'! clearRegistry self registry do: [:each | each beNull ]; removeAll.! ! !FT2Handle class methodsFor: 'system startup' stamp: 'IgorStasenko 10/15/2012 17:08'! startUp: booting booting ifFalse: [ ^ self ]. self clearRegistry. "update session" Session := Smalltalk session ! ! !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: 'IgorStasenko 10/9/2012 18:50'! register: anFT2Handle self registry add: anFT2Handle.! ! !FT2Handle class methodsFor: 'private-handle registry' stamp: 'Igor.Stasenko 10/12/2010 19:45'! registry ^Registry ifNil: [ Registry := WeakRegistry new]! ! FT2Handle subclass: #FT2Library instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FreeType-Base'! !FT2Library commentStamp: '' prior: 0! 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:27'! destroyHandle "This is not a managed handle, but a global. Do nothing."! ! !FT2Library methodsFor: 'private-primitives' stamp: 'nk 11/4/2004 13:32'! primCurrentLibrary ^self primitiveFailed! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FT2Library class instanceVariableNames: ''! !FT2Library class methodsFor: 'instance creation' stamp: 'nk 3/17/2005 14:19'! current ^[ (self basicNew) current ] on: FT2Error do: [ :ex | ex return: nil ].! ! FT2Handle subclass: #FT2MemoryFaceData instanceVariableNames: 'bytes' classVariableNames: '' poolDictionaries: '' category: 'FreeType-Base'! !FT2MemoryFaceData methodsFor: 'accessing' stamp: 'tween 7/24/2006 23:04'! bytes ^bytes ! ! !FT2MemoryFaceData methodsFor: 'accessing' stamp: 'tween 7/24/2006 22:43'! bytes: aByteArray bytes := aByteArray. ! ! !FT2MemoryFaceData methodsFor: 'initialize-release' stamp: 'tween 7/24/2006 21:53'! free ^self destroyHandle! ! !FT2MemoryFaceData methodsFor: 'primitives' stamp: 'tween 7/24/2006 21:52'! primDestroyHandle ^self primitiveFailed.! ! !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 class instanceVariableNames: ''! !FT2MemoryFaceData class methodsFor: 'instance creation' stamp: 'tween 8/6/2006 11:11'! bytes: aByteArray | answer | answer := self basicNew bytes: aByteArray; yourself. ^answer! ! Object subclass: #FT2Outline instanceVariableNames: 'contoursSize pointsSize points tags contours' classVariableNames: '' poolDictionaries: '' category: 'FreeType-Base'! !FT2Outline commentStamp: '' prior: 0! @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: '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/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: 'private' stamp: 'jl 5/23/2006 17:01'! primLoadArraysFrom: anFT2Face ^self primitiveFailed.! ! !FT2Outline methodsFor: 'private' stamp: 'jl 5/23/2006 17:01'! primLoadSizesFrom: anFT2Face ^self primitiveFailed.! ! Object subclass: #FT2Version instanceVariableNames: 'major minor patch' classVariableNames: '' poolDictionaries: '' category: 'FreeType-Base'! !FT2Version commentStamp: '' prior: 0! 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: 'accessing' stamp: 'nk 3/21/2004 11:03'! major ^major! ! !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: 'primitives' stamp: 'nk 11/3/2004 11:20'! libraryVersion ^self primitiveFailed. ! ! !FT2Version methodsFor: 'printing' stamp: 'nk 11/3/2004 11:22'! printOn: aStream aStream print: major; nextPut: $.; print: minor; nextPut:$.; print: patch.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FT2Version class instanceVariableNames: ''! !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]! ! TelnetProtocolClient subclass: #FTPClient instanceVariableNames: 'dataSocket' classVariableNames: '' poolDictionaries: '' category: 'Network-Protocols'! !FTPClient commentStamp: 'mir 5/12/2003 17:55' prior: 0! 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: 'protocol' stamp: 'mir 2/13/2002 18:05'! abortDataConnection self sendCommand: 'ABOR'. self closeDataSocket! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 3/7/2002 13:36'! ascii self sendCommand: 'TYPE A'. self lookForCode: 200! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 3/7/2002 13:36'! binary self sendCommand: 'TYPE I'. self lookForCode: 200! ! !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:11'! deleteDirectory: dirName self sendCommand: 'RMD ' , dirName. self checkResponse. ! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 11/19/2002 17:12'! deleteFileNamed: fileName self sendCommand: 'DELE ' , fileName. 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: '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 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: '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: '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: '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 17:10'! makeDirectory: newDirName self sendCommand: 'MKD ' , newDirName. self checkResponse. ! ! !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 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 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 methodsFor: 'protocol' stamp: 'mir 10/31/2000 13:12'! quit self sendCommand: 'QUIT'. self close! ! !FTPClient methodsFor: 'protocol' stamp: 'mir 11/13/2002 17:50'! removeFileNamed: remoteFileName self sendCommand: 'DELE ', remoteFileName. self checkResponse. ! ! !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: 'private' stamp: 'mir 2/19/2002 18:27'! closeDataSocket self dataSocket ifNotNil: [ self dataSocket closeAndDestroy. self dataSocket: nil] ! ! !FTPClient methodsFor: 'private' stamp: 'mir 10/31/2000 16:24'! dataSocket ^dataSocket! ! !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' stamp: 'mir 11/14/2002 18:14'! sendStreamContents: aStream self dataSocket sendStreamContents: aStream checkBlock: [self checkForPendingError. true]! ! !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: '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: '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: '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: '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 class instanceVariableNames: ''! !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.') ! ! Error subclass: #FTPConnectionException instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Network-Protocols'! !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! ! SimpleTestResourceTestCase subclass: #FailingTestResourceTestCase instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Tests-Core'! !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]]! ! Boolean subclass: #False instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Objects'! !False commentStamp: '' prior: 0! 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: 'controlling'! and: alternativeBlock "Nonevaluating conjunction -- answer with false since the receiver is false." ^self! ! !False methodsFor: 'controlling'! 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'! 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'! 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'! 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'! or: alternativeBlock "Nonevaluating disjunction -- answer value of alternativeBlock." ^alternativeBlock value! ! !False methodsFor: 'converting' stamp: 'IgorStasenko 12/28/2012 15:09'! asBit ^ 0! ! !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'! not "Negation -- answer true since the receiver is false." ^true! ! !False methodsFor: 'logical operations' stamp: 'CamilloBruni 8/1/2012 16:25'! xor: aBoolean ^aBoolean value! ! !False methodsFor: 'logical operations'! | aBoolean "Evaluating disjunction (OR) -- answer with the argument, aBoolean." ^aBoolean! ! !False methodsFor: 'printing'! printOn: aStream aStream nextPutAll: 'false'! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! False class instanceVariableNames: ''! !False class methodsFor: '*Fuel' stamp: 'MartinDias 2/21/2013 12:51'! materializeFrom: aDecoder "Answer my unique instance" ^ false! ! ClassTestCase subclass: #FalseTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Objects'! !FalseTest commentStamp: '' prior: 0! This is the unit test for the class False. 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 ! !FalseTest methodsFor: 'tests' stamp: 'FabrizioPerin 3/13/2010 15:23'! testAND self deny: (false & true). self deny: (false & false).! ! !FalseTest methodsFor: 'tests' stamp: 'FabrizioPerin 3/13/2010 15:23'! testAnd self deny: (false and: ['alternativeBlock']).! ! !FalseTest methodsFor: 'tests' stamp: 'StephaneDucasse 2/2/2010 13:49'! testAsBit self assert: (false asBit = 0).! ! !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: 'GabrielOmarCotelli 5/25/2010 21:22'! testIfTrue self assert: (false ifTrue: [ 'alternativeBlock' ]) isNil! ! !FalseTest methodsFor: 'tests' stamp: 'sd 6/5/2005 09:03'! testIfTrueIfFalse self assert: (false ifTrue: ['trueAlternativeBlock'] ifFalse: ['falseAlternativeBlock']) = 'falseAlternativeBlock'. ! ! !FalseTest methodsFor: 'tests' stamp: 'StephaneDucasse 6/9/2012 22:58'! testNew self should: [False new] raise: self defaultTestError ! ! !FalseTest methodsFor: 'tests' stamp: 'StephaneDucasse 3/5/2010 15:32'! testNot self assert: (false not).! ! !FalseTest methodsFor: 'tests' stamp: 'FabrizioPerin 3/13/2010 15:24'! testOR self assert: (false | true). self deny: (false | false).! ! !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:04'! testPrintOn self assert: (String streamContents: [:stream | false printOn: stream]) = 'false'. ! ! !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.! ! InflateStream subclass: #FastInflateStream instanceVariableNames: '' classVariableNames: 'DistanceMap FixedDistTable FixedLitTable LiteralLengthMap' poolDictionaries: '' category: 'Compression-Streams'! !FastInflateStream commentStamp: '' prior: 0! 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: '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 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: 'inflating' stamp: 'ar 12/4/1998 19:15'! processFixedBlock litTable := FixedLitTable. distTable := FixedDistTable. state := state bitOr: BlockProceedBit. self proceedFixedBlock.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FastInflateStream class instanceVariableNames: ''! !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.! ! Browser subclass: #FileContentsBrowser instanceVariableNames: 'packages infoString' classVariableNames: '' poolDictionaries: '' category: 'Tools-File Contents Browser'! !FileContentsBrowser commentStamp: '' prior: 0! 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: '*Shout-Styling'! shoutAboutToStyle: aPluggableShoutMorphOrView self shoutIsModeStyleable ifFalse: [^ false]. aPluggableShoutMorphOrView classOrMetaClass: self selectedClassOrMetaClass. ^ true! ! !FileContentsBrowser methodsFor: 'accessing'! contents self updateInfoView. (editSelection == #newClass and:[self selectedPackage notNil]) ifTrue: [^self selectedPackage packageInfo]. editSelection == #editClass ifTrue:[^self modifiedClassDefinition]. ^super contents! ! !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: 'accessing'! packages ^packages! ! !FileContentsBrowser methodsFor: 'accessing'! packages: aDictionary packages := aDictionary.! ! !FileContentsBrowser methodsFor: 'accessing'! selectedPackage | cat | cat := self selectedSystemCategoryName. cat isNil ifTrue:[^nil]. ^self packages at: cat asString ifAbsent:[nil]! ! !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: 'class list'! 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: '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: '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: 'class list'! 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: '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: 'creation' stamp: 'MarcusDenker 11/13/2012 15:10'! createViews contentsSymbol := self defaultDiffsSymbol. "#showDiffs or #prettyDiffs" ^ self open! ! !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: '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: '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: 'edit pane' stamp: 'jb 7/1/2011 10:51'! 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 evaluatorClass new parse: contents in: class notifying: nil. contents := contents generate. ^ contents symbolic asText! ! !FileContentsBrowser methodsFor: 'edit pane' stamp: 'AlainPlantec 11/27/2009 09:24'! 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 prettyPrinterClass format: contents in: class notifying: nil]. self showingAnyKindOfDiffs ifTrue: [contents := self methodDiffFor: contents class: self selectedClass selector: self selectedMessageName meta: self metaClassIndicated]. ^contents asText makeSelectorBoldIn: class! ! !FileContentsBrowser methodsFor: 'filein/fileout'! 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: 'filein/fileout' stamp: 'wod 2/3/1999 18:46'! fileInMessageCategories Cursor read showWhile:[ self selectedClassOrMetaClass fileInCategory: self selectedMessageCategoryName. ].! ! !FileContentsBrowser methodsFor: 'filein/fileout' stamp: 'wod 5/13/1998 12:50'! fileInPackage Cursor read showWhile:[ self selectedPackage fileIn. ].! ! !FileContentsBrowser methodsFor: 'filein/fileout' stamp: 'ar 9/27/2005 20:07'! fileIntoNewChangeSet | p ff | (p := self selectedPackage) ifNil: [^ Beeper beep]. ff := FileStream readOnlyFileNamed: p fullPackageName. ChangeSet newChangesFromStream: ff named: p packageName! ! !FileContentsBrowser methodsFor: 'filein/fileout'! fileOutClass Cursor write showWhile:[ self selectedClass fileOut. ].! ! !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: 'filein/fileout' stamp: 'wod 2/3/1999 18:46'! fileOutMessageCategories Cursor write showWhile:[ self selectedClassOrMetaClass fileOutCategory: self selectedMessageCategoryName. ].! ! !FileContentsBrowser methodsFor: 'filein/fileout' stamp: 'wod 5/13/1998 14:19'! fileOutPackage Cursor write showWhile:[ self selectedPackage fileOut. ].! ! !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: '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: '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: 'infoview' stamp: 'alain.plantec 5/30/2008 13:04'! updateInfoView self changed: #infoViewContents! ! !FileContentsBrowser methodsFor: 'initialization' stamp: 'dew 9/15/2001 16:19'! defaultBrowserTitle ^ 'File Contents Browser'! ! !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: 'keys' stamp: 'sma 5/6/2000 18:50'! messageListKey: aChar from: view aChar == $b ifTrue: [^ self browseMethodFull]. super messageListKey: aChar from: view! ! !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: '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: '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: '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: '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: '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: '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: 'other' stamp: 'bkv 8/13/2003 23: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 browseAllCallsOn: self selectedMessageName]! ! !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: 'other'! 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: '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: 'other' stamp: 'sw 10/1/2001 11:16'! labelString "Answer the string for the window title" ^ 'File Contents Browser ', (self selectedSystemCategoryName ifNil: [''])! ! !FileContentsBrowser methodsFor: 'other' stamp: 'sma 2/6/2000 12:27'! methodHierarchy (self selectedClassOrMetaClass isNil or: [self selectedClassOrMetaClass hasDefinition]) ifFalse: [super methodHierarchy]! ! !FileContentsBrowser methodsFor: 'removing' stamp: 'sd 11/20/2005 21:27'! 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: '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: 'removing' stamp: 'sd 11/20/2005 21:27'! 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 removeCategory: messageCategoryName. self messageCategoryListIndex: 0. self changed: #messageCategoryList.! ! !FileContentsBrowser methodsFor: 'removing' stamp: 'wod 5/24/1998 20:52'! 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 removeCategory: self selectedSystemCategoryName. self systemCategoryListIndex: 0. self changed: #systemCategoryList! ! !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: 'removing' stamp: 'wod 5/24/1998 20:37'! removeUnmodifiedClasses | packageList | self okToChange ifFalse:[^self]. packageList := self selectedPackage isNil ifTrue:[self packages] ifFalse:[Array with: self selectedPackage]. packageList do:[:package| package classes copy do:[:theClass| Cursor wait showWhile:[ theClass removeAllUnmodified. ]. theClass hasChanges ifFalse:[ package removeClass: theClass. ]. ]]. self classListIndex: 0. self changed: #classList.! ! !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 class instanceVariableNames: ''! !FileContentsBrowser class methodsFor: 'System-FileRegistry' stamp: 'CamilloBruni 2/3/2013 17:27'! fileReaderServicesForDirectory: aDirectory ^{ self serviceBrowseCodeFiles }! ! !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: '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: '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:11'! serviceBrowseCodeFiles ^ (SimpleServiceEntry provider: self label: 'Browse code files' selector: #selectAndBrowseFile:) argumentGetter: [ :fileList | fileList ]; yourself! ! !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: 'initialization' stamp: 'GabrielOmarCotelli 6/4/2009 20:37'! unload FileServices unregisterFileReader: self ! ! !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: '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: 'instance creation' stamp: 'nb 6/17/2003 12:25'! browseFile: aFilename "Open a file contents browser on a file of the given name" aFilename ifNil: [^ Beeper beep]. self browseFiles: (Array with: aFilename)! ! !FileContentsBrowser class methodsFor: 'instance creation' stamp: 'IgorStasenko 3/6/2011 18:12'! browseStream: aStream aStream setConverterForCode. self browseStream: aStream named: aStream name! ! !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: '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 ! ! DialogWindow subclass: #FileDialogWindow instanceVariableNames: 'directoryTreeMorph fileListMorph directories selectedDirectory selectedFileIndex fileSelectionBlock showDirectoriesInFileList fileSortBlock fileNameText defaultExtension actionSelector answer entryCache entryCacheDirectory previewType previewMorph' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Windows'! !FileDialogWindow commentStamp: 'gvc 5/18/2007 13:10' prior: 0! 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: 'accessing' stamp: 'gvc 8/27/2006 10:33'! actionSelector "Answer the value of actionSelector" ^ actionSelector! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/27/2006 10:33'! actionSelector: anObject "Set the value of actionSelector" actionSelector := anObject! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 10/11/2006 13:33'! defaultExtension "Answer the value of defaultExtension" ^ defaultExtension! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 10/11/2006 13:33'! defaultExtension: anObject "Set the value of defaultExtension" defaultExtension := anObject! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/23/2006 14:19'! directories "Answer the value of directories" ^ directories! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/23/2006 14:19'! directories: anObject "Set the value of directories" directories := anObject! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/23/2006 19:51'! directoryTreeMorph "Answer the value of directoryTreeMorph" ^ directoryTreeMorph! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/23/2006 19:51'! directoryTreeMorph: anObject "Set the value of directoryTreeMorph" directoryTreeMorph := anObject! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 9/27/2006 10:21'! entryCache "Answer the value of entryCache" ^ entryCache! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 9/27/2006 10:21'! entryCache: anObject "Set the value of entryCache" entryCache := anObject! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 9/27/2006 10:21'! entryCacheDirectory "Answer the value of entryCacheDirectory" ^ entryCacheDirectory! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 9/27/2006 10:21'! entryCacheDirectory: anObject "Set the value of entryCacheDirectory" entryCacheDirectory := anObject! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/23/2006 19:51'! fileListMorph "Answer the value of fileListMorph" ^ fileListMorph! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/23/2006 19:51'! fileListMorph: anObject "Set the value of fileListMorph" fileListMorph := anObject! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/24/2006 08:39'! fileSelectionBlock "Answer the value of fileSelectionBlock" ^ fileSelectionBlock! ! !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/24/2006 08:51'! fileSortBlock "Answer the value of fileSortBlock" ^ fileSortBlock! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/24/2006 08:51'! fileSortBlock: anObject "Set the value of fileSortBlock" fileSortBlock := anObject! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 9/27/2006 13:55'! previewMorph "Answer the value of previewMorph" ^ previewMorph! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 9/27/2006 13:55'! previewMorph: anObject "Set the value of previewMorph" previewMorph := anObject! ! !FileDialogWindow methodsFor: 'accessing' stamp: 'gvc 9/27/2006 13:30'! previewType "Answer the value of previewType" ^ previewType! ! !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: 'accessing' stamp: 'gvc 8/23/2006 14:33'! selectedDirectory "Answer the value of selectedDirectory" ^ selectedDirectory! ! !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: 'accessing' stamp: 'gvc 8/23/2006 15:42'! selectedFileIndex "Answer the value of selectedFileIndex" ^ selectedFileIndex! ! !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 8/24/2006 08:42'! showDirectoriesInFileList "Answer the value of showDirectoriesInFileList" ^ showDirectoriesInFileList! ! !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: 'CamilloBruni 5/4/2012 19:59'! addInitialPanel "Add the panel." super addInitialPanel. self selectDirectory: FileSystem disk workingDirectory ! ! !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: 'gvc 7/30/2009 14:00'! answer: anObject "Set the answer." answer := anObject! ! !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 4/4/2007 16:08'! answerFileEntry "Set the receiver to answer the selected file entry." self actionSelector: #selectedFileEntry. self changed: #okEnabled! ! !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 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: '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: '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: 'gvc 3/23/2007 16:04'! answerSaveFile "Set the receiver to answer a new file stream." self actionSelector: #saveSelectedFile. self changed: #okEnabled! ! !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: '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: '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: '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: '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: '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: 'as yet unclassified' stamp: 'CamilloBruni 2/14/2012 11:46'! directoriesFor: item "Answer the filtered entries." ^item directories! ! !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 8/23/2006 14:29'! directoryNamesFor: item "Answer the filtered entries." ^item directoryNames! ! !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: 'as yet unclassified' stamp: 'SvenVanCaekenberghe 1/8/2012 14:43'! fileNamePattern "Answer the file name pattern to filter on." ^self fileNameText trimBoth, '*'! ! !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: '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: '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: '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: 'SeanDeNigris 6/21/2012 20:22'! hasSelectedFileOrDirectory "Answer whether a file or directopry is selected in the file list." ^ self selectedFileIndex ~= 0! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'SeanDeNigris 6/21/2012 20:23'! iconFor: anEntry "Answer the icon to use for the directory entry." ^ anEntry isDirectory ifTrue: [self theme smallOpenIcon] ifFalse: [(self isImageFile: anEntry basename) ifTrue: [self theme smallPaintIcon] ifFalse: [self theme smallLeftFlushIcon]]! ! !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: 'AlainPlantec 1/11/2010 22:00'! initialExtent ^ 750@550! ! !FileDialogWindow methodsFor: 'as yet unclassified' 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: '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 9/22/2009 11:17'! isResizeable "Answer whether we are not we can be resized." ^true! ! !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 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: 'AlainPlantec 10/19/2010 20:48'! newDeleteButton "Answer a new delete button." ^self newButtonFor: self getState: nil action: #deleteFileOrDirectory arguments: nil getEnabled: #hasSelectedFileOrDirectory labelForm: self theme smallDeleteIcon help: 'Press to delete the selected file or directory' translated! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 6/22/2012 13:20'! 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) ensureDirectory ] on: Error do: [:ex | ^self alert: 'Invalid directory name' translated, ' "', dirName, '"' title: title ]. self clearEntryCache; updateDirectories! ! !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: '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: '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 5/14/2007 16:33'! newImagePreviewMorph "Answer a new image preview morph." ^ImagePreviewMorph new cornerStyle: self preferredCornerStyle; image: nil size: self previewSize! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 10/19/2010 20:48'! newNewDirectoryButton "Answer a new 'new directory' button." ^self newButtonFor: self getState: nil action: #newDirectory arguments: nil getEnabled: nil labelForm: self theme smallOpenIcon help: 'Press to create a new directory within the current directory' translated! ! !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: '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: '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: 'AlainPlantec 10/19/2010 20:48'! newUpButton "Answer a new up one directory level button." ^self newButtonFor: self getState: nil action: #selectParentDirectory arguments: nil getEnabled: #hasParentDirectory labelForm: self theme smallUndoIcon help: 'Press to switch to the parent of the current directory' translated! ! !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: '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: '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: '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: '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: '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: '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: '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: 'GuillermoPolito 6/22/2012 13:12'! selectParentDirectory "Switch to the parent directory." self hasParentDirectory ifFalse: [^self]. self selectDirectory: self selectedFileDirectory asFileReference parent! ! !FileDialogWindow methodsFor: 'as yet unclassified' stamp: 'SeanDeNigris 7/17/2012 17:39'! selectPathName: aString "Select the directory and set the file name text from the given string." | reference | reference := aString asFileReference asAbsolute. reference isDirectory ifTrue: [ ^ self selectDirectory: reference ]. reference isFile ifTrue: [ self selectDirectory: reference parent. self fileNameText: reference basename ]. self selectDirectory: FileSystem disk workingDirectory. self fileNameText: ''.! ! !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: 'SeanDeNigris 6/21/2012 19:16'! selectedDirectoryName ^ self selectedFileDirectory ifNotNil: [ :dir | dir basename ] ifNil: [ nil ].! ! !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 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: 'SeanDeNigris 6/21/2012 19:16'! selectedFileName ^ self selectedFileEntry ifNotNil: [ :dir | dir basename ] ifNil: [ nil ].! ! !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: '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: 'GaryChambers 12/2/2011 12:45'! updateFiles "Notify that the files have changed." self changed: #files! ! !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: '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:41'! updateSelectedDirectory "Notify that the selected directory has changed." self changed: #selectedDirectory; changed: #selectedFileDirectory; changed: #selectedPathName; changed: #hasParentDirectory! ! !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: '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: '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 class instanceVariableNames: ''! !FileDialogWindow class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'AlainPlantec 10/19/2010 20:48'! taskbarIcon "Answer the icon for the receiver in a task bar." ^self theme smallOpenIcon! ! TestCase subclass: #FileDialogWindowTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Polymorph-Widgets'! !FileDialogWindowTest methodsFor: 'tests' stamp: 'CamilloBruni 7/20/2012 18:00'! testIssue6406 | aFolder dialog file invalidFolder | aFolder := (FileSystem workingDirectory / 'testIssue6406') ensureDirectory. "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: 'testIssue6406' 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.! ! ListItemWrapper subclass: #FileDirectoryWrapper instanceVariableNames: 'itemName balloonText hasContents' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Explorer'! !FileDirectoryWrapper methodsFor: 'accessing' stamp: 'RAA 7/21/2000 11:00'! balloonText ^balloonText! ! !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: 'accessing' stamp: 'GuillermoPolito 6/22/2012 12:44'! 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 hasDirectories ]]. ^ hasContents! ! !FileDirectoryWrapper methodsFor: 'accessing' stamp: 'CamilloBruni 8/12/2011 19:10'! icon "Answer a form to be used as icon" "^ item isRemoteDirectory ifTrue: [ self theme smallRemoteOpenIcon] ifFalse: [self theme smallOpenIcon]" ^ self theme smallOpenIcon! ! !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: '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: 'as yet unclassified' stamp: 'RAA 6/16/2000 18:30'! settingSelector ^#setSelectedDirectoryTo:! ! !FileDirectoryWrapper methodsFor: 'converting' stamp: 'dgd 8/27/2004 18:45'! asString ^itemName translatedIfCorresponds! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FileDirectoryWrapper class instanceVariableNames: ''! !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! ! FileSystemError subclass: #FileDoesNotExist instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Core-Kernel'! !FileDoesNotExist commentStamp: 'cwp 11/18/2009 12:35' prior: 0! 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.! FileStreamException subclass: #FileDoesNotExistException instanceVariableNames: 'readOnly' classVariableNames: '' poolDictionaries: '' category: 'Files-Kernel'! !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 instanceVariableNames: ''! !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! ! FileSystemError subclass: #FileExists instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Core-Kernel'! !FileExists commentStamp: 'cwp 11/18/2009 12:37' prior: 0! I am raised on an attempt to create a file or directory over top of an existing file.! FileStreamException subclass: #FileExistsException instanceVariableNames: 'fileClass' classVariableNames: '' poolDictionaries: '' category: 'Files-Kernel'! !FileExistsException methodsFor: 'accessing' stamp: 'LC 10/24/2001 21:49'! fileClass ^ fileClass ifNil: [StandardFileStream]! ! !FileExistsException methodsFor: 'accessing' stamp: 'LC 10/24/2001 21:42'! fileClass: aClass fileClass := aClass! ! !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 instanceVariableNames: ''! !FileExistsException class methodsFor: 'exceptioninstantiator' stamp: 'LC 10/24/2001 21:50'! fileName: aFileName fileClass: aClass ^ self new fileName: aFileName; fileClass: aClass! ! FileSystemHandle subclass: #FileHandle instanceVariableNames: 'id' classVariableNames: 'Registry' poolDictionaries: '' category: 'FileSystem-Disk'! !FileHandle commentStamp: 'cwp 11/18/2009 13:02' prior: 0! 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: 'finalization' stamp: 'CamilloBruni 5/24/2012 15:07'! finalize self primCloseNoError: id.! ! !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: 'CamilloBruni 5/24/2012 15:19'! assureOpen "compatibility method to make the FileHandle Tests pass" self isOpen ifFalse: [ id := self basicOpen ].! ! !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: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: 'public' stamp: 'cwp 11/20/2009 14:59'! close Primitives close: id. id := nil! ! !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: 'abc 5/11/2012 23:22'! readStream ^ (FileStream onHandle: self) ifNil: [ self streamError ] ! ! !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: '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: 'cwp 7/22/2009 08:17'! truncateTo: anInteger Primitives truncate: id to: anInteger. self reopen! ! !FileHandle methodsFor: 'public' stamp: 'abc 5/11/2012 23:22'! writeStream ^( FileStream onHandle: self) ifNil: [ self streamError ]! ! !FileHandle methodsFor: 'testing' stamp: 'cwp 7/22/2009 07:10'! isOpen ^ (Primitives sizeOrNil: id) notNil! ! !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 class instanceVariableNames: ''! !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: 'as yet unclassified' stamp: 'CamilloBruni 5/24/2012 15:06'! registry ^Registry ifNil: [Registry := WeakRegistry new] ! ! !FileHandle class methodsFor: 'class initialization' stamp: 'cwp 11/20/2009 16:16'! initialize self useFilePlugin. ! ! !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]]! ! !FileHandle class methodsFor: 'class initialization' stamp: 'EstebanLorenzano 4/2/2012 11:46'! useFilePlugin Primitives := FilePluginPrims new! ! FileSystemHandleTest subclass: #FileHandleTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Tests-Disk'! !FileHandleTest methodsFor: 'running' stamp: 'EstebanLorenzano 4/3/2012 11:42'! createFileSystem ^ FileSystem store: DiskStore activeClass createDefault! ! Model subclass: #FileList instanceVariableNames: 'reference volumeList volumeListIndex list listIndex pattern sortMode brevityState currentDirectorySelected dirSelectionBlock modalView ok contents optionalButtonSpecs grid fileEncoding sortBlock' classVariableNames: 'FileReaderRegistry RecentDirs' poolDictionaries: '' category: 'Tools-FileList'! !FileList commentStamp: 'StephaneDucasse 3/28/2010 20:44' prior: 0! A FileList is a tool to deal with files. FileList open "open FileList"! !FileList methodsFor: '*Shout-Styling' stamp: 'AlainPlantec 8/27/2011 00:26'! shoutAboutToStyle: aPluggableShoutMorphOrView ^ false! ! !FileList methodsFor: 'accessing' stamp: 'CamilloBruni 2/14/2012 14:37'! directory ^ reference isFile ifTrue: [ reference parent ] ifFalse: [ reference ]! ! !FileList methodsFor: 'accessing' stamp: 'CamilloBruni 2/16/2012 12:14'! directory: dir ^ self reference: dir! ! !FileList methodsFor: 'accessing' stamp: 'hfm 11/29/2008 18:30'! fileList "Answer the list of files in the current volume." ^ list! ! !FileList methodsFor: 'accessing' stamp: 'CamilloBruni 2/14/2012 15:00'! fileListIndex "Answer the index of the currently selected file." ^ listIndex! ! !FileList methodsFor: 'accessing' stamp: 'CamilloBruni 8/12/2011 21:36'! fileListIndex: anInteger "Select the file name having the given index, and display its contents." | item name | 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: 'accessing' stamp: 'CamilloBruni 2/14/2012 15:02'! getListIndex ^ list indexOf: reference ifAbsent: [ 0 ]! ! !FileList methodsFor: 'accessing' stamp: 'CamilloBruni 8/12/2011 21:18'! pattern ^ pattern ! ! !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: 'accessing' stamp: 'CamilloBruni 2/16/2012 12:13'! reference ^ reference! ! !FileList methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 22:47'! reference: dir | tmpReference | "Set the path of the volume to be displayed." self okToChange ifFalse: [^ self]. tmpReference := dir ifNotNilDo: [ :d| d asFileReference] ifNil: [ FileSystem disk workingDirectory ]. tmpReference isReadable ifFalse: [ ^ self inform: ('Cannot read {1}' translated format: { tmpReference})]. reference := tmpReference. sortMode isNil ifTrue: [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: 'drag''n''drop' stamp: 'EstebanLorenzano 4/2/2012 11:43'! acceptDroppingMorph: aTransferMorph event: evt inMorph: dest | oldFile oldEntry destDirectory newFile newEntry baseName 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: 'drag''n''drop' stamp: 'CamilloBruni 8/12/2011 22:03'! dragPassengerFor: item inMorph: dragSource ^ item contents copy ! ! !FileList methodsFor: 'drag''n''drop' stamp: 'hfm 11/29/2008 19:21'! dragTransferTypeForMorph: aMorph ^#file! ! !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: 'drag''n''drop' stamp: 'nk 6/15/2003 22:00'! isDirectoryList: aMorph ^aMorph isKindOf: SimpleHierarchicalListMorph! ! !FileList methodsFor: 'drag''n''drop' stamp: 'MarcusDenker 8/15/2010 15:08'! wantsDroppedMorph: aTransferMorph event: evt inMorph: dest | retval | retval := (aTransferMorph isKindOf: TransferMorph) and: [ (aTransferMorph dragTransferType == #file) and: [ self isDirectoryList: dest ]]. ^retval! ! !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: '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:03'! fileListMenu: aMenu reference ifNil: [^ self noFileSelectedMenu: aMenu] ifNotNil: [^ self fileSelectedMenu: aMenu]. ! ! !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: '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: '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: '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: '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: 'file list menu' stamp: 'hfm 11/29/2008 19:26'! noFileSelectedMenu: aMenu ^ aMenu addServices: self itemsForNoFile for: self extraLines: #() ! ! !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: 'file menu action' stamp: 'CamilloBruni 8/12/2011 21:06'! 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. index := list indexOf: newName. index = 0 ifTrue: [ index := list findFirst: [:line | line basename endsWith: newName]]. self fileListIndex: index. ! ! !FileList methodsFor: 'file menu action' stamp: 'CamilloBruni 8/12/2011 20:03'! addNewFile self addNew: 'File' byEvaluating: [:newName | (reference / newName) ensureFile ] ! ! !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: '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: '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: 'file menu action' stamp: 'hfm 11/29/2008 19:24'! getEncodedText Cursor read showWhile: [ self selectEncoding. self changed: #contents]. ! ! !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: '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: '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: '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: 'initialization' stamp: 'EstebanLorenzano 4/2/2012 11:43'! initialDirectoryList | dirList | dirList := (FileSystem disk root) directories collect: [ :each | FileDirectoryWrapper with: each name: each basename model: self]. dirList isEmpty ifTrue:[ dirList := Array with: (FileDirectoryWrapper with: FileSystem disk workingDirectory name: FileSystem disk workingDirectory basename model: self)]. ^dirList! ! !FileList methodsFor: 'initialization' stamp: 'CamilloBruni 8/12/2011 20:18'! labelString reference ifNil: [ ^ '[]' ]. ^ reference basename contractTo: 50! ! !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: '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: 'initialization' stamp: 'sw 2/22/2002 02:34'! universalButtonServices "Answer the services to be reflected in the receiver's buttons" ^ self optionalButtonSpecs! ! !FileList methodsFor: 'initialization' stamp: 'CamilloBruni 8/14/2011 15:17'! updateButtonRow "Dynamically update the contents of the button row, if any." | aWindow aRow | aWindow := self dependents detect: [:m | (m isSystemWindow) and: [m model == self]] ifNone: [^self]. 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: '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: 'initialize-release' stamp: 'MarcusDenker 8/15/2010 15:05'! initialize super initialize. ok := false. dirSelectionBlock := [ :dirName | true].! ! !FileList methodsFor: 'menu messages' stamp: 'hfm 11/29/2008 19:22'! copyName listIndex = 0 ifTrue: [^ self]. Clipboard clipboardText: self fullName asText. ! ! !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: 'own services' stamp: 'CamilloBruni 8/12/2011 20:06'! addNewDirectory self addNew: 'Directory' byEvaluating: [:newName | (reference / newName ) ensureDirectory ] ! ! !FileList methodsFor: 'own services' stamp: 'CamilloBruni 8/12/2011 20:07'! basicDeleteDirectory "Remove the currently selected directory" | localDirName | 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.! ! !FileList methodsFor: 'own services' stamp: 'CarloTeixeira 7/3/2010 22:25'! deleteDirectory self basicDeleteDirectory. self updateFileList. self updateDirectory. ! ! !FileList methodsFor: 'own services' stamp: 'sw 2/22/2002 02:35'! okayAndCancelServices "Answer ok and cancel services" ^ {self serviceOkay. self serviceCancel}! ! !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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: 'own services' stamp: 'tbn 8/11/2010 10:15'! serviceRenameFile ^ (SimpleServiceEntry provider: self label: 'Rename' selector: #renameFile description: 'Rename file')! ! !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: '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: 'MarcusDenker 5/25/2011 12:24'! 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:)" | services col | col := OrderedCollection new. services := self class allRegisteredServices. symbolArray do: [:sel | | res | sel == #- ifTrue: [col add: sel] ifFalse: [res := services detect: [:each | each selector = sel] ifNone: [nil]. res notNil ifTrue: [col add: res]]]. ^ col! ! !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: '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: 'user interface' stamp: 'AlexisParseghian 3/15/2012 23:57'! grid ^ grid ifNil: [ grid := self morphicGrid ]! ! !FileList methodsFor: 'user interface' stamp: 'RAA 2/17/2001 12:18'! morphicDirectoryTreePane ^self morphicDirectoryTreePaneFiltered: #initialDirectoryList ! ! !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: 'user interface' stamp: 'AlainPlantec 8/28/2011 13:51'! morphicFileContentsPane ^(PluggableTextMorph on: self text: #contents accept: #put: readSelection: nil menu: #fileContentsMenu:shifted:) ! ! !FileList methodsFor: 'user interface' stamp: 'AlexisParseghian 3/15/2012 23:38'! morphicFileListPane ^ grid ifNil: [ grid := self morphicGrid ]. ! ! !FileList methodsFor: 'user interface'! morphicGrid grid := FileListGrid new parent: self. grid onSelectionChangeSend: #findFileListIndex: to: self ; menu: #fileListMenu shifted: false. ^ grid treeMorph ! ! !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: 'user interface' stamp: 'CamilloBruni 2/16/2012 11:15'! optionalButtonSpecs ^ optionalButtonSpecs! ! !FileList methodsFor: 'user interface' stamp: 'CamilloBruni 2/16/2012 11:15'! optionalButtonSpecs: aSpecArray optionalButtonSpecs := aSpecArray! ! !FileList methodsFor: 'user interface' stamp: 'AlexisParseghian 3/26/2012 00:18'! setSortSelector: aByteSymbol self sortBlock: (self perform: aByteSymbol).! ! !FileList methodsFor: 'user interface' stamp: 'CamilloBruni 2/16/2012 15:00'! wrapFile: aFile ^ aFile basename! ! !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: '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: '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: 'volume list and pattern' stamp: 'MarcusDenker 2/11/2012 13:57'! volumeList "Answer the current list of volumes." ^ volumeList ! ! !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: 'volume list and pattern' stamp: 'MarcusDenker 4/25/2012 08:02'! 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 delimiter. path := String streamContents: [:stream | 2 to: index do: [:i | stream nextPutAll: (volumeList at: i) trimBoth. i < index ifTrue: [stream nextPut: delim]]]. self directory: (reference on: path)]. brevityState := #FileList. self addPath: path. self changed: #fileList. self changed: #contents. self updateButtonRow! ! !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 5/7/2012 01:13'! 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)] ifNone: [nil]) ifNotNil: [^self]. [RecentDirs size >= 10] whileTrue: [RecentDirs removeFirst]. RecentDirs addLast: full! ! !FileList methodsFor: 'private' stamp: 'CamilloBruni 8/14/2011 15:33'! cancelHit modalView delete.! ! !FileList methodsFor: 'private' stamp: 'CamilloBruni 7/10/2012 22:53'! 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]. Halt halt: 'unknown state ' , brevityState printString! ! !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: '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: '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: 'private' stamp: 'AlexisParseghian 3/25/2012 23:26'! fileEncoding: aByteSymbol fileEncoding := aByteSymbol. brevityState := #needToGetBrief. self changed: #contents! ! !FileList methodsFor: 'private' stamp: 'CamilloBruni 2/14/2012 14:24'! 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. pattern ifNil: [ ^ files ]. ^ files select: [:entry | (aRegex search: entry basename)]! ! !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: '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: '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: 'private' stamp: 'CamilloBruni 8/12/2011 20:09'! isFileSelected "return if a file is currently selected" ^ reference notNil and: [ reference isFile ].! ! !FileList methodsFor: 'private' stamp: 'RAA 6/21/2000 12:06'! modalView: aSystemWindowOrSuch modalView := aSystemWindowOrSuch! ! !FileList methodsFor: 'private' stamp: 'SeanDeNigris 7/7/2012 21:45'! okHit ok := true. self directory ifNil: [Beeper beep] 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: 'SeanDeNigris 7/7/2012 21:45'! put: aText "Private - put the supplied text onto the file" | ff type | brevityState == #fullFile ifTrue:[ ff := reference writeStream. Cursor write showWhile: [ff nextPutAll: aText asString; close]. reference basename = ff localName ifTrue: [contents := aText asString] ifFalse: [ self updateList. "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: '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: '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: '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: 'hfm 11/29/2008 18:38'! registeredFileReaderClasses "return the list of classes that provide file reader services" ^ self class registeredFileReaderClasses! ! !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: '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: 'private' stamp: 'CamilloBruni 8/14/2011 15:48'! selectedDirectory ^ self directory! ! !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: '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: '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: 'private' stamp: 'AlexisParseghian 3/26/2012 00:19'! sortBlock: aBlockClosure sortBlock := aBlockClosure. self updateFileList! ! !FileList methodsFor: 'private'! 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: '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: '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: '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: 'private' stamp: 'AlexisParseghian 3/15/2012 23:56'! 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 := self listForPattern: pattern. listIndex := self getListIndex. volumeListIndex := volumeList size. contents := ''. self changed: #volumeListIndex. self changed: #fileList. self grid updateList. self updateButtonRow! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FileList class instanceVariableNames: 'searchList'! !FileList class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'FernandoOlivero 4/12/2011 09:45'! taskbarIcon "Answer the icon for the receiver in a task bar." ^self theme smallOpenIcon! ! !FileList class methodsFor: 'accessing' stamp: 'FernandoOlivero 4/12/2011 09:51'! theme ^ UITheme current ! ! !FileList class methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 8/12/2011 21:53'! searchList ^ searchList ifNil: [ searchList := OrderedCollection new ].! ! !FileList class methodsFor: 'file reader registration' stamp: 'hfm 11/29/2008 19:35'! allRegisteredServices "self allRegisteredServices" | col | col := OrderedCollection new. self registeredFileReaderClasses do: [:each | col addAll: (each services)]. ^ col! ! !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: '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: '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: '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: '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! ! !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: '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: '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: 'menu' stamp: 'EstebanLorenzano 2/1/2013 11:24'! contentMenu: aBuilder (aBuilder item: #'Find...' translated) keyText: 'f'; selector: #find; icon: UITheme current smallFindIcon. (aBuilder item: #'Find again' translated) keyText: 'g'; selector: #findAgain; icon: UITheme current smallFindIcon. (aBuilder item: #'Set search string' translated) keyText: 'h'; selector: #setSearchString; withSeparatorAfter. (aBuilder item: #'Do again' translated) keyText: 'j'; selector: #again; icon: UITheme current smallRedoIcon. (aBuilder item: #'Undo' translated) keyText: 'z'; selector: #undo; icon: UITheme current smallUndoIcon; withSeparatorAfter. (aBuilder item: #'Copy' translated) keyText: 'c'; selector: #copySelection; icon: UITheme current smallCopyIcon. (aBuilder item: #'Cut' translated) keyText: 'x'; selector: #cut; icon: UITheme current smallCutIcon. (aBuilder item: #'Paste' translated) keyText: 'v'; selector: #paste; icon: UITheme current smallPasteIcon. (aBuilder item: #'Paste...' translated) selector: #pasteRecent; icon: UITheme current smallPasteIcon; withSeparatorAfter . (aBuilder item: #'Do it' translated) keyText: 'd'; selector: #doIt; icon: UITheme current smallDoItIcon. (aBuilder item: #'Print it' translated) keyText: 'p'; selector: #printIt; icon: UITheme current smallPrintItIcon. (aBuilder item: #'Inspect it' translated) keyText: 'i'; selector: #inspectIt; icon: UITheme current smallInspectItIcon. (aBuilder item: #'FileIn selection' translated) keyText: 'G'; selector: #fileItIn; withSeparatorAfter. (aBuilder item: #'Accept' translated) keyText: 's'; selector: #accept; icon: UITheme current smallOkIcon. (aBuilder item: #'Cancel' translated) keyText: 'l'; selector: #cancel; icon: UITheme current smallCancelIcon; withSeparatorAfter. (aBuilder item: #'More...' translated) selector: #shiftedYellowButtonActivity. ! ! !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: 'modal dialogs' stamp: 'EstebanLorenzano 4/2/2012 11:43'! modalFolderSelector ^self modalFolderSelector: FileSystem disk root! ! !FileList class methodsFor: 'modal dialogs' stamp: 'CamilloBruni 2/16/2012 11:44'! modalFolderSelector: aDir | window fileModel | window := self morphicViewFolderSelector: aDir. fileModel := window model. window openInWorld: self currentWorld extent: 300@400. World openModal: window. ^fileModel directory fullName! ! !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/16/2012 11:04'! morphicViewFolderSelector: aDir "Answer a tool that allows the user to select a folder" | aFileList window fixedSize | aFileList := self new directory: aDir. aFileList optionalButtonSpecs: aFileList servicesForFolderSelector. ^ self morphicViewOnFile: aDir contents: nil fileList: aFileList! ! !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: '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: '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: 'StephaneDucasse 12/19/2012 16:36'! addFullPanesTo: window from: aCollection aCollection do: [ :each | window addMorph: each first fullFrame: each second ]! ! !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: '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: 'utility' stamp: 'hfm 11/29/2008 18:37'! registeredFileReaderClasses FileReaderRegistry := nil. "wipe it out" ^FileServices registeredFileReaderClasses ! ! !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: '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: '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: 'world menu' stamp: 'AlainPlantec 2/18/2010 11:20'! menuCommandOn: aBuilder (aBuilder item: #'File Browser') parent: #Tools; action:[self open]; icon: self taskbarIcon.! ! MorphTreeModel subclass: #FileListGrid instanceVariableNames: 'parent treeMorph' classVariableNames: '' poolDictionaries: '' category: 'Tools-FileList'! !FileListGrid methodsFor: 'as yet unclassified'! parent ^ parent! ! !FileListGrid methodsFor: 'as yet unclassified'! parent: aFileList parent := aFileList! ! !FileListGrid methodsFor: 'as yet unclassified'! rootItems ^ parent fileList! ! !FileListGrid methodsFor: 'as yet unclassified'! rootNodeClassFromItem: anItem ^ FileListGridNode! ! !FileListGrid methodsFor: 'menus' stamp: 'AlexisParseghian 3/15/2012 23:25'! fileListMenu: aMenuMorph ^ parent fileListMenu: aMenuMorph! ! !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 ! ! MorphTreeNodeModel subclass: #FileListGridNode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tools-FileList'! !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:04'! fileSize ^ self theme newTextIn: self text: item humanReadableSize asString! ! !FileListGridNode methodsFor: 'user interface' stamp: 'CamilloBruni 7/10/2012 22:03'! modificationDate ^ self theme newTextIn: self text: item modificationTime asString! ! AbstractFileReference subclass: #FileLocator instanceVariableNames: 'origin path' classVariableNames: 'Resolver' poolDictionaries: '' category: 'FileSystem-Core-Public'! !FileLocator commentStamp: '' prior: 0! 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: 'accessing' stamp: 'StephaneDucasse 9/14/2012 11:12'! absolutePath "Return the absolute path" ^ self resolve path! ! !FileLocator methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 15:23'! fullPath ^ self resolve path! ! !FileLocator methodsFor: 'accessing' stamp: 'cwp 10/25/2009 21:31'! origin ^ origin! ! !FileLocator methodsFor: 'accessing' stamp: 'cwp 10/25/2009 21:31'! path ^ path! ! !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: 'comparing' stamp: 'cwp 10/25/2009 11:05'! hash ^ origin hash bitXor: path hash! ! !FileLocator methodsFor: 'converting' stamp: 'cwp 10/25/2009 10:30'! asAbsolute ^ self ! ! !FileLocator methodsFor: 'converting' stamp: 'EstebanLorenzano 4/12/2012 14:28'! asFileReference ^ self resolve! ! !FileLocator methodsFor: 'copying' stamp: 'CamilloBruni 7/10/2012 15:17'! copyWithPath: newPath ^ self class origin: origin path: newPath! ! !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: 'initialize-release' stamp: 'cwp 10/25/2009 09:56'! initializeWithOrigin: aSymbol path: aPath self initialize. origin := aSymbol. path := aPath.! ! !FileLocator methodsFor: 'navigating' stamp: 'cwp 10/25/2009 09:59'! resolve ^ (Resolver resolve: origin) resolve: path! ! !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: '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: '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: 'streams' stamp: 'CamilloBruni 7/10/2012 15:26'! readStream ^ self resolve readStream ! ! !FileLocator methodsFor: 'streams' stamp: 'CamilloBruni 7/10/2012 15:26'! writeStream ^ self resolve writeStream ! ! !FileLocator methodsFor: 'testing' stamp: 'cwp 10/25/2009 10:30'! isAbsolute ^ true! ! !FileLocator methodsFor: 'testing' stamp: 'cwp 10/25/2009 11:15'! isRelative ^ false! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FileLocator class instanceVariableNames: ''! !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: 'class initialization' stamp: 'cwp 10/26/2009 20:54'! addResolver: aResolver Resolver addResolver: aResolver! ! !FileLocator class methodsFor: 'class initialization' stamp: 'cwp 10/27/2009 10:28'! flushCaches Resolver flushCaches! ! !FileLocator class methodsFor: 'class initialization' stamp: 'cwp 11/20/2009 15:01'! initialize Smalltalk addToStartUpList: self. self startUp: true! ! !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: 'instance creation' stamp: 'EstebanLorenzano 4/2/2012 11:42'! origin: aSymbol ^ self origin: aSymbol path: Path workingDirectory! ! !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: 'origins' stamp: 'lr 7/13/2010 13:29'! changes ^ self origin: #changes ! ! !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: 'origins' stamp: 'CamilloBruni 5/24/2012 12:07'! documents ^ self origin: #documents! ! !FileLocator class methodsFor: 'origins' stamp: 'cwp 10/27/2009 09:34'! home ^ self origin: #home! ! !FileLocator class methodsFor: 'origins' stamp: 'cwp 10/25/2009 09:54'! image ^ self origin: #image ! ! !FileLocator class methodsFor: 'origins' stamp: 'lr 7/13/2010 13:35'! imageDirectory ^ self origin: #imageDirectory ! ! !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'! root ^ FileSystem disk root! ! !FileLocator class methodsFor: 'origins' stamp: 'cwp 10/26/2009 11:37'! vmBinary ^ self origin: #vmBinary! ! !FileLocator class methodsFor: 'origins' stamp: 'cwp 10/26/2009 13:49'! vmDirectory ^ self origin: #vmDirectory! ! !FileLocator class methodsFor: 'origins' stamp: 'CamilloBruni 7/10/2012 21:36'! workingDirectory ^ FileSystem disk referenceTo: RelativePath new! ! !FileLocator class methodsFor: 'windows-origins' stamp: 'CamilloBruni 7/10/2012 21:38'! A ^ self driveNamed: #A ! ! !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'! C ^ self driveNamed: #C ! ! !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'! E ^ self driveNamed: #E ! ! !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'! G ^ self driveNamed: #G ! ! !FileLocator class methodsFor: 'windows-origins' stamp: 'CamilloBruni 7/10/2012 21:38'! H ^ self driveNamed: #H ! ! !FileLocator class methodsFor: 'windows-origins' stamp: 'CamilloBruni 7/10/2012 21:38'! I ^ self driveNamed: #I ! ! !FileLocator class methodsFor: 'windows-origins' stamp: 'CamilloBruni 7/10/2012 21:38'! J ^ self driveNamed: #J ! ! !FileLocator class methodsFor: 'windows-origins' stamp: 'CamilloBruni 7/10/2012 21:38'! K ^ self driveNamed: #K ! ! !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'! M ^ self driveNamed: #M ! ! !FileLocator class methodsFor: 'windows-origins' stamp: 'CamilloBruni 7/10/2012 21:38'! N ^ self driveNamed: #N ! ! !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'! P ^ self driveNamed: #P ! ! !FileLocator class methodsFor: 'windows-origins' stamp: 'CamilloBruni 7/10/2012 21:38'! Q ^ self driveNamed: #Q ! ! !FileLocator class methodsFor: 'windows-origins' stamp: 'CamilloBruni 7/10/2012 21:38'! R ^ self driveNamed: #R ! ! !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:38'! T ^ self driveNamed: #T ! ! !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'! V ^ self driveNamed: #V ! ! !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'! X ^ self driveNamed: #X ! ! !FileLocator class methodsFor: 'windows-origins' stamp: 'CamilloBruni 7/10/2012 21:38'! Y ^ self driveNamed: #Y ! ! !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:39'! driveNamed: driveName ^ FileReference fileSystem: (FileSystem disk) path: Path / (driveName, ':')! ! TestCase subclass: #FileLocatorTest instanceVariableNames: 'locator' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Tests-Core'! !FileLocatorTest methodsFor: 'compatibility tests' stamp: 'EstebanLorenzano 4/12/2012 14:26'! testAsAbsolute locator := FileLocator image. self assert: locator asAbsolute = locator! ! !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: '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'! 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'! testContainsLocator locator := FileLocator image. self assert: (locator contains: locator / 'griffle').! ! !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'! 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'! testFileSystem locator := FileLocator image. self assert: (locator fileSystem isKindOf: FileSystem)! ! !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'! testIsNotRoot locator := FileLocator image. self deny: locator isRoot! ! !FileLocatorTest methodsFor: 'compatibility tests' stamp: 'EstebanLorenzano 4/12/2012 14:26'! testIsRelative locator := FileLocator image. self deny: locator isRelative! ! !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: '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'! testParent locator := FileLocator image. self assert: locator parent resolve = FileLocator imageDirectory resolve! ! !FileLocatorTest methodsFor: 'compatibility tests' stamp: 'EstebanLorenzano 4/12/2012 14:26'! testSlash locator := FileLocator image / 'griffle'. self assert: locator = (FileLocator image / 'griffle')! ! !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'! testWithExtensionReplacesExtension locator := FileLocator image / 'griffle.nurp'. self assert: (locator withExtension: 'plonk') basename = 'griffle.plonk'! ! !FileLocatorTest methodsFor: 'resolution tests' stamp: 'EstebanLorenzano 4/12/2012 14:26'! testImageDirectory locator := FileLocator image. self assert: locator resolve = FileLocator image resolve! ! !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: '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: 'resolution tests' stamp: 'EstebanLorenzano 4/12/2012 14:26'! 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: '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: 'resolution tests' stamp: 'EstebanLorenzano 4/12/2012 14:26'! 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: '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')! ! SimpleServiceEntry subclass: #FileModifyingSimpleServiceEntry instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-FileRegistry'! !FileModifyingSimpleServiceEntry commentStamp: 'nk 11/26/2002 12:03' prior: 0! I represent a service that may change the contents of a directory. Such changes include: * file creation * file deletion * file modification! !FileModifyingSimpleServiceEntry methodsFor: 'as yet unclassified' stamp: 'nk 11/26/2002 12:08'! performServiceFor: anObject | retval | retval := super performServiceFor: anObject. self changed: #fileListChanged. ^retval "is this used anywhere?"! ! Object subclass: #FilePackage instanceVariableNames: 'fullName sourceSystem classes doIts classOrder' classVariableNames: 'LogFileStream' poolDictionaries: '' category: 'System-FilePackage'! !FilePackage methodsFor: 'accessing'! classAt: className ^self classes at: className! ! !FilePackage methodsFor: 'accessing'! classes ^classes! ! !FilePackage methodsFor: 'accessing' stamp: 'pnm 8/23/2000 17:10'! fullName: aString fullName := aString! ! !FilePackage methodsFor: 'accessing'! fullPackageName ^fullName! ! !FilePackage methodsFor: 'accessing'! packageInfo ^String streamContents:[:s| s nextPutAll:'Package: '. s nextPutAll: self fullPackageName; 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: 'accessing' stamp: 'CamilloBruni 5/7/2012 02:09'! packageName ^ self fullPackageName asFileReference basename! ! !FilePackage methodsFor: 'accessing'! removeClass: aPseudoClass (self classes removeKey: aPseudoClass name). classOrder copy do:[:cls| cls name = aPseudoClass name ifTrue:[ classOrder remove: cls]. ].! ! !FilePackage methodsFor: 'accessing'! renameClass: aPseudoClass to: newName | oldName | oldName := aPseudoClass name. self classes removeKey: oldName. self classes at: newName put: aPseudoClass. aPseudoClass renameTo: newName.! ! !FilePackage methodsFor: 'change record types'! classComment: chgRec (self getClass: chgRec methodClassName) classComment: chgRec! ! !FilePackage methodsFor: 'change record types' stamp: 'al 12/2/2005 13:58'! classDefinition: string with: chgRec | tokens theClass | self flag: #traits. tokens := Scanner new scanTokens: string. "tokens size = 11 ifFalse:[^doIts add: chgRec]." theClass := self getClass: (tokens at: 3). theClass definition: string. classOrder add: theClass.! ! !FilePackage methodsFor: 'change record types'! 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: 'change record types' stamp: 'avi 1/19/2004 23:47'! doIts ^ doIts! ! !FilePackage methodsFor: 'change record types'! method: chgRec (self getClass: chgRec methodClassName) methodChange: chgRec! ! !FilePackage methodsFor: 'change record types'! preamble: chgRec self doIt: 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: '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: 'filein/fileout'! fileInDoits doIts do:[:chgRec| chgRec fileIn].! ! !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: 'filein/fileout'! fileOutDoits: aStream doIts do:[:chgRec| chgRec fileOutOn: aStream].! ! !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: 'initialize' stamp: 'StephaneDucasse 2/2/2010 21:52'! fromFileNamed: aName fullName := aName. FileStream readOnlyFileNamed: aName do: [ :aStream | aStream setConverterForCode. self fileInFrom: aStream] ! ! !FilePackage methodsFor: 'initialize' stamp: 'alain.plantec 5/28/2009 09:54'! initialize super initialize. classes := Dictionary new. classOrder := OrderedCollection new. sourceSystem := ''. doIts := OrderedCollection new.! ! !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: 'private'! getClass: className | pseudoClass | (classes includesKey: className) ifTrue:[ ^classes at: className. ]. pseudoClass := PseudoClass new. pseudoClass name: className. classes at: className put: pseudoClass. ^pseudoClass.! ! !FilePackage methodsFor: 'private'! metaClassDefinition: string with: chgRec | tokens theClass | tokens := Scanner new scanTokens: string. theClass := self getClass: (tokens at: 1). theClass metaClass definition: string. classOrder add: theClass metaClass.! ! !FilePackage methodsFor: 'private' stamp: 'ar 4/10/2005 18:46'! msgClassComment: string with: chgRec | tokens theClass | tokens := Scanner new scanTokens: string. (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: 'private' stamp: 'ar 4/10/2005 18:46'! possibleSystemSource: chgRec | tokens | sourceSystem isEmpty ifTrue:[ tokens := Scanner new scanTokens: chgRec string. (tokens size = 1 and:[tokens first isString]) ifTrue:[ sourceSystem := tokens first. ^self]]. doIts add: chgRec.! ! !FilePackage methodsFor: 'private'! removedMethod: string with: chgRec | class tokens | tokens := Scanner new scanTokens: string. (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 class instanceVariableNames: ''! !FilePackage class methodsFor: 'instance creation'! fromFileNamed: aName ^self new fromFileNamed: aName! ! Object subclass: #FilePath instanceVariableNames: 'squeakPathName vmPathName' classVariableNames: '' poolDictionaries: '' category: 'Files-Directories'! !FilePath commentStamp: 'yo 10/19/2004 21:36' prior: 0! 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". ! !FilePath methodsFor: 'conversion' stamp: 'yo 12/19/2003 21:10'! asSqueakPathName ^ self pathName. ! ! !FilePath methodsFor: 'conversion' stamp: 'ar 1/31/2005 11:16'! asString ^self asSqueakPathName! ! !FilePath methodsFor: 'conversion' stamp: 'yo 2/24/2005 18:45'! asVmPathName ^ vmPathName. ! ! !FilePath methodsFor: 'conversion' stamp: 'yo 12/19/2003 21:07'! pathName ^ squeakPathName. ! ! !FilePath methodsFor: 'conversion' stamp: 'CamilloBruni 9/22/2012 10:24'! pathName: p isEncoded: isEncoded | encodingConverter | encodingConverter := LanguageEnvironment defaultFileNameConverter. isEncoded ifTrue: [ squeakPathName := p convertFromWithConverter: encodingConverter. vmPathName := p. ] ifFalse: [ squeakPathName := p isOctetString ifTrue: [p asOctetString] ifFalse: [p]. vmPathName := squeakPathName convertToWithConverter: encodingConverter. ]. ! ! !FilePath methodsFor: 'conversion' stamp: 'yo 12/19/2003 21:07'! printOn: aStream aStream nextPutAll: 'FilePath('''. aStream nextPutAll: squeakPathName. aStream nextPutAll: ''')'. ! ! !FilePath methodsFor: 'file in/out' stamp: 'stephaneducasse 2/4/2006 20:31'! copySystemToVm (self class instVarNames includes: 'systemPathName') ifTrue: [ vmPathName := self instVarNamed: 'systemPathName'. ]. ! ! !FilePath methodsFor: 'testing' stamp: 'tpr 11/5/2004 11:39'! isNullPath "an empty path is used to represent the root path(s) when calling the primitive to list directory entries. Some users need to check for this and this is cleaner than grabbing the pathname and assuming it is a plain String" ^self pathName isEmpty! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FilePath class instanceVariableNames: ''! !FilePath class methodsFor: '*system-settings' stamp: 'AlainPlantec 9/3/2010 17:28'! settingInputWidgetForNode: aSettingNode ^ aSettingNode inputWidgetForFileOrDirectoryWithAction: #chooseFilePath.! ! !FilePath class methodsFor: 'as yet unclassified' stamp: 'yo 2/24/2005 18:38'! classVersion ^ 1. ! ! !FilePath class methodsFor: 'instance creation' stamp: 'yo 12/19/2003 16:30'! pathName: pathName ^ self pathName: pathName isEncoded: false. ! ! !FilePath class methodsFor: 'instance creation' stamp: 'yo 12/19/2003 16:30'! pathName: pathName isEncoded: aBoolean ^ (self new) pathName: pathName isEncoded: aBoolean; yourself. ! ! Object subclass: #FilePluginPrims instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Disk'! !FilePluginPrims commentStamp: 'cwp 11/18/2009 13:02' prior: 0! 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: 'encoding primitives' stamp: 'lr 7/13/2010 14:11'! encode: aString ^ aString convertToWithConverter: LanguageEnvironment defaultFileNameConverter! ! !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: 'file primitives' stamp: 'cwp 7/20/2009 17:27'! close: id "Close this file." ! ! !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:27'! getPosition: id "Get this files current position." 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: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'! setPosition: id to: anInteger "Set this file to the given position." 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: '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'! truncate: id to: anInteger "Truncate this file to the given position." self primitiveFailed ! ! !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 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: '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 ! ! !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 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: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: 'path primitives' stamp: 'cwp 10/11/2009 11:02'! imageFile "Answer the full path name for the current image." self primitiveFailed! ! !FilePluginPrims methodsFor: 'path primitives' stamp: 'CamilloBruni 1/17/2012 17:09'! lookupDirectory: fullPath filename: fileName ^ #badDirectoryPath ! ! !FilePluginPrims methodsFor: 'path primitives' stamp: 'cwp 7/20/2009 17:24'! 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: '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: '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 ! ! AbstractFileReference subclass: #FileReference instanceVariableNames: 'filesystem path' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Core-Public'! !FileReference commentStamp: '' prior: 0! 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: 'accessing' stamp: 'StephaneDucasse 9/14/2012 11:13'! absolutePath "Return the absolute of the receiver" ^ self path! ! !FileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 20:50'! creationTime ^ filesystem creationTime: self 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: 'accessing' stamp: 'EstebanLorenzano 4/3/2012 13:03'! fileSystem "Return the filesystem to which the receiver belong." ^ filesystem! ! !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: 'accessing' stamp: 'CamilloBruni 7/10/2012 15:23'! fullPath ^ 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: 'CamilloBruni 5/9/2012 13:04'! mimeTypes "Return the possible mime types for the given path." ^ filesystem mimeTypesAt: path! ! !FileReference methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 20:51'! modificationTime ^ filesystem modificationTime: self path! ! !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: 'accessing' stamp: 'CamilloBruni 7/10/2012 21:29'! permissions ^ filesystem permissions: self path! ! !FileReference methodsFor: 'accessing' stamp: 'cwp 10/26/2009 02:02'! resolve ^ self! ! !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 methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 22:06'! size ^ filesystem size: 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: 'comparing' stamp: 'EstebanLorenzano 4/3/2012 13:05'! containsReference: aReference ^ aReference fileSystem = filesystem and: [path contains: aReference path]! ! !FileReference methodsFor: 'comparing' stamp: 'cwp 9/16/2009 23:54'! hash ^ path hash bitXor: filesystem hash! ! !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: 'converting' stamp: 'EstebanLorenzano 4/12/2012 14:28'! asFileReference ^ self! ! !FileReference methodsFor: 'copying' stamp: 'CamilloBruni 7/10/2012 15:17'! copyWithPath: newPath ^ filesystem referenceTo: newPath! ! !FileReference methodsFor: 'deprecated' stamp: 'CamilloBruni 8/1/2012 16:25'! pathName self deprecated: 'Use fullName instead' on: '2012-06-22 19:00' in: #Pharo20. ^ self fullName. ! ! !FileReference methodsFor: 'initialize-release' stamp: 'EstebanLorenzano 4/3/2012 13:07'! setFileSystem: aFilesystem path: aPath filesystem := aFilesystem. path := aPath! ! !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: 'operations' stamp: 'EstebanLorenzano 4/3/2012 13:05'! copyTo: aReference self isDirectory ifTrue: [ aReference ensureDirectory ] ifFalse: [ filesystem = aReference fileSystem ifTrue: [ filesystem copy: path to: aReference path ] ifFalse: [ filesystem copy: path toReference: aReference ] ]! ! !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: 'operations' stamp: 'cwp 7/22/2009 07:42'! delete filesystem delete: path! ! !FileReference methodsFor: 'operations' stamp: 'CamilloBruni 7/10/2012 15:52'! deleteIfAbsent: aBlock self exists ifTrue: [ self delete ] ifFalse: aBlock! ! !FileReference methodsFor: 'operations' stamp: 'sd 2/11/2011 20:16'! ensureDirectory "Create if necessary a directory for the receiver." filesystem ensureDirectory: path ! ! !FileReference methodsFor: 'operations' stamp: 'EstebanLorenzano 4/3/2012 13:08'! moveTo: aReference | result | result := self fileSystem rename: self path to: aReference path. result ifNotNil: [ self setFileSystem: filesystem path: aReference path ]. ! ! !FileReference methodsFor: 'operations' stamp: 'SeanDeNigris 5/12/2012 11:14'! renameTo: newBasename | destinationPath | destinationPath := self fileSystem rename: self to: self parent / newBasename. destinationPath ifNotNil: [ self setFileSystem: filesystem path: destinationPath ]. ^ self ! ! !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: 'printing' stamp: 'cwp 10/11/2009 22:32'! printOn: aStream filesystem forReferencePrintOn: aStream. filesystem printPath: path on: aStream! ! !FileReference methodsFor: 'resolving' stamp: 'cwp 10/26/2009 01:03'! resolve: anObject ^ anObject asResolvedBy: self! ! !FileReference methodsFor: 'resolving' stamp: 'CamilloBruni 1/19/2012 12:45'! resolvePath: anObject ^ self withPath: (path resolve: anObject)! ! !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: 'resolving' stamp: 'cwp 11/21/2009 11:30'! resolveString: aString | thePath | thePath := filesystem pathFromString: aString. ^ filesystem referenceTo: (path resolve: thePath)! ! !FileReference methodsFor: 'streams' stamp: 'CamilloBruni 1/20/2012 13:24'! openWritable: aBoolean ^ filesystem open: path writable: aBoolean! ! !FileReference methodsFor: 'streams' stamp: 'CamilloBruni 7/10/2012 15:25'! readStream ^ filesystem readStreamOn: self path! ! !FileReference methodsFor: 'streams' stamp: 'CamilloBruni 7/10/2012 15:25'! writeStream ^ filesystem writeStreamOn: self path! ! !FileReference methodsFor: 'testing' stamp: 'cwp 1/13/2009 20:52'! exists ^ filesystem exists: 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: '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: '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: 'cwp 7/20/2009 09:24'! isAbsolute ^ path isAbsolute! ! !FileReference methodsFor: 'testing' stamp: 'cwp 1/13/2009 21:39'! isDirectory ^ filesystem isDirectory: path! ! !FileReference methodsFor: 'testing' stamp: 'cwp 1/13/2009 21:57'! isFile ^ filesystem isFile: path! ! !FileReference methodsFor: 'testing' stamp: 'CamilloBruni 5/9/2012 00:37'! isReadable ^ filesystem isReadable: path! ! !FileReference methodsFor: 'testing' stamp: 'cwp 7/20/2009 09:25'! isRelative ^ path isRelative! ! !FileReference methodsFor: 'testing' stamp: 'cwp 7/20/2009 09:26'! isRoot ^ path isRoot! ! !FileReference methodsFor: 'testing' stamp: 'EstebanLorenzano 8/2/2012 15:42'! isSymlink ^ filesystem isSymlink: path! ! !FileReference methodsFor: 'testing' stamp: 'CamilloBruni 5/9/2012 00:37'! isWritable ^ filesystem isWritable: path! ! !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 class instanceVariableNames: ''! !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: 'instance creation' stamp: 'EstebanLorenzano 4/3/2012 13:21'! fileSystem: aFilesystem path: aPath ^ self new setFileSystem: aFilesystem path: aPath! ! TestCase variableSubclass: #FileReferenceTest instanceVariableNames: 'filesystem' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Tests-Core'! !FileReferenceTest methodsFor: 'running' stamp: 'EstebanLorenzano 4/2/2012 11:43'! setUp filesystem := FileSystem memory.! ! !FileReferenceTest methodsFor: 'support' stamp: 'cwp 11/17/2009 21:23'! createFile: aPath filesystem ensureDirectory: aPath parent. (filesystem writeStreamOn: aPath) 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: '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: '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: '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 8/12/2011 15:44'! testAsAbsoluteIdentity | ref | ref := filesystem / 'plonk'. self assert: ref asAbsolute == ref! ! !FileReferenceTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/12/2012 14:28'! testAsReference | ref | ref := filesystem * 'plonk'. self assert: ref asFileReference == ref! ! !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 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: '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/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: '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: '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' 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: '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 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 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: 'EstebanLorenzano 4/12/2012 14:26'! testContainsLocator | ref | ref := FileLocator imageDirectory resolve parent. self assert: (ref contains: FileLocator image)! ! !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: 'CamilloBruni 8/12/2011 15:49'! testContainsReference | ref | ref := filesystem * 'griffle'. self assert: (ref contains: ref / 'nurp')! ! !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: '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: 'SeanDeNigris 6/14/2012 10:27'! testDeleteIfAbsent | flag reference | flag := false. reference := filesystem / 'plonk'. reference ensureFile. 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: 'EstebanLorenzano 4/12/2012 14:26'! testDoesntContainLocator | ref | ref := filesystem * 'griffle'. self deny: (ref contains: FileLocator image)! ! !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/3/2012 13:18'! testDoesntContainReferenceFileSystem | ref other | ref := filesystem * 'griffle'. other := FileSystem memory / 'griffle' / 'nurp'. self deny: (ref contains: other)! ! !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: 'SeanDeNigris 6/14/2012 10:28'! testEnsureDeleted | reference | reference := filesystem / 'plonk'. "Deletes the file if it exists" reference ensureFile. self assert: reference exists. reference ensureDeleted. self deny: reference exists. "No-op if file does not exist" self shouldnt: [reference ensureDeleted] raise: Error. ! ! !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: '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/14/2012 10:29'! testExists | reference | reference := filesystem / 'plonk'. reference ensureFile. self assert: reference exists. reference delete. self deny: reference exists. ! ! !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: '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 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: 'CamilloBruni 6/22/2012 18:09'! testHasDirectories "self debug: #testHasDirectories" | ref children | filesystem createDirectory: '/alpha'. filesystem createDirectory: '/alpha/beta'. (filesystem / 'alpha' / 'beta' / 'delta') ensureFile. 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 6/22/2012 18:06'! testHasFiles "self debug: #testHasFiles" | ref children | filesystem createDirectory: '/alpha'. filesystem createDirectory: '/alpha/beta'. (filesystem / 'alpha' / 'beta' / 'delta') ensureFile. 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: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: 'CamilloBruni 8/12/2011 15:41'! testIsAbsolute self assert: (filesystem / 'plonk') isAbsolute! ! !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'! testIsNotRelative self deny: (filesystem / 'plonk') isRelative! ! !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:31'! testIsRelative self assert: (filesystem * 'plonk') isRelative! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 8/12/2011 15:49'! testIsRoot self assert: (filesystem root) isRoot! ! !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 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: '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: '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: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: '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: '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 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: '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 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/2/2012 11:41'! testReadStreamNotFound | ref | ref := filesystem * 'plonk'. self should: [ref readStream] raise: FileDoesNotExist ! ! !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: '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: 'SeanDeNigris 7/12/2012 08:44'! testRename | file newName tmp originalPwd originalFullName | [ file := (FileLocator imageDirectory / 'oldName') ensureFile. originalFullName := file fullName. tmp := (FileLocator imageDirectory / 'tmp') ensureDirectory. 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: 'SeanDeNigris 8/17/2012 09:40'! testRenameTargetExists | existingFile fileToRename | [ existingFile := 'existingFile' asFileReference ensureFile. fileToRename := 'fileToRename' asFileReference ensureFile. self should: [ fileToRename renameTo: existingFile basename ] raise: FileExists ] ensure: [ existingFile delete. fileToRename delete ].! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 8/12/2011 15:47'! testResolve | ref | ref := filesystem / 'griffle'. self assert: ref resolve == ref! ! !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 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'! 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: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: 'CamilloBruni 8/12/2011 15:46'! testUnequalContent | a b | a := filesystem * 'plonk'. b := filesystem * 'griffle'. self deny: a = b.! ! !FileReferenceTest methodsFor: 'tests' stamp: 'CamilloBruni 8/12/2011 15:46'! testUnequalSize | a b | a := filesystem * 'plonk'. b := filesystem / 'plonk' / 'griffle'. self deny: a = b.! ! !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: '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/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 6/23/2012 00:17'! testWriteStream | ref stream | ref := filesystem / 'plonk'. [stream := ref writeStream.] ensure: [stream ifNotNil: [stream close]]! ! !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: '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 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: '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: '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: '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/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 stream' stamp: 'EstebanLorenzano 4/2/2012 11:41'! testReadStreamDoNotFound | ref | ref := filesystem / 'plonk'. self should: [ref readStreamDo: [:s]] raise: FileDoesNotExist ! ! Object subclass: #FileServices instanceVariableNames: '' classVariableNames: 'FileReaderRegistry' poolDictionaries: '' category: 'System-FileRegistry'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FileServices class instanceVariableNames: ''! !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: '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: '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: '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: 'adding' stamp: 'ar 7/16/2005 16:59'! registeredFileReaderClasses FileReaderRegistry ifNil: [FileReaderRegistry := OrderedCollection new]. ^ FileReaderRegistry! ! !FileServices class methodsFor: 'cleanup' stamp: 'StephaneDucasse 3/9/2010 16:31'! cleanUp "Remove obsolete services" self removeObsolete! ! !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: '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: '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: '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: '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 ] ! ! ReadWriteStream subclass: #FileStream instanceVariableNames: 'rwmode' classVariableNames: 'Stderr Stdin StdioFiles Stdout TheStdioHandles' poolDictionaries: '' category: 'Files-Kernel'! !FileStream commentStamp: '' prior: 0! 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: '*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: '*Network-URI' stamp: 'bf 1/27/2006 18:01'! uri ^self directory uri resolveRelativeURI: self localName encodeForHTTP! ! !FileStream methodsFor: '*Network-URI' 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: 'SeanDeNigris 2/1/2013 21:08'! asUrl "Convert my path into a file:// type url - a FileUrl." ^ FileUrl pathParts: (self directory pathSegments copyWith: self localName)! ! !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: '*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: '*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: '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: '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: 'accessing' stamp: 'abc 5/11/2012 23:29'! directoryEntry ^(self directory / self localName) entry! ! !FileStream methodsFor: 'accessing' stamp: 'CamilloBruni 5/23/2012 16:55'! mimeTypes ^ self name asFileReference mimeTypes.! ! !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: '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: 'accessing'! nextPut: aByte "1/31/96 sw: subclassResponsibility" self subclassResponsibility! ! !FileStream methodsFor: 'accessing'! nextPutAll: aCollection "1/31/96 sw: made subclass responsibility" self subclassResponsibility! ! !FileStream methodsFor: 'accessing' stamp: 'CamilloBruni 8/1/2012 16:16'! size "Answer the size of the file in characters." 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:05'! file "Answer the file for the page the receiver is streaming over." self subclassResponsibility! ! !FileStream methodsFor: 'file accessing' stamp: 'CamilloBruni 5/7/2012 02:09'! localName ^ self name asFileReference basename ! ! !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: 'file modes' stamp: 'jm 9/21/1998 13:01'! ascii "Set this file to ascii (text) mode." 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 modes' stamp: 'jm 9/21/1998 12:59'! readOnly "Set this file's mode to read-only." self subclassResponsibility ! ! !FileStream methodsFor: 'file modes' stamp: 'mir 8/24/2004 17:58'! readOnlyStream ^self readOnly! ! !FileStream methodsFor: 'file modes' stamp: 'jm 9/21/1998 13:00'! readWrite "Set this file's mode to read-write." self subclassResponsibility ! ! !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:02'! close "Close this file." self subclassResponsibility ! ! !FileStream methodsFor: 'file open/close' stamp: 'jm 9/21/1998 13:02'! closed "Answer true if this file is closed." 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: '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: 'CamilloBruni 8/1/2012 16:12'! position "Answer the current character position in the file." self subclassResponsibility! ! !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: 'positioning' stamp: 'CamilloBruni 8/1/2012 16:15'! reset "Set the current character position to the beginning of the file." 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: '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: 'positioning' stamp: 'JMM 5/24/2001 22:58'! truncate: pos "Truncate file to pos" 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: '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: 'printing'! printOn: aStream super printOn: aStream. aStream nextPutAll: ' on '. self file printOn: aStream! ! !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 class instanceVariableNames: ''! !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: '*Network-URI' stamp: 'JMM 2/3/2008 14:17'! oldFileFullyNamed: t1 ^ self concreteStream oldFileNamed: t1! ! !FileStream class methodsFor: '*Network-URI' stamp: 'JMM 2/3/2008 14:14'! readOnlyFileFullyNamed: t1 ^ self concreteStream readOnlyFileFullyNamed: t1! ! !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: '*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: '*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: '*Tools-FileList' stamp: 'sd 2/1/2002 22:28'! services ^ Array with: self serviceRemoveLineFeeds with: self serviceFileIn ! ! !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: '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: 'CamilloBruni 5/23/2012 16:56'! fileIn: fullName "File in the entire contents of the file specified by the name provided" | ff fn | fullName ifNil: [^ Beeper beep]. 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: 'file reader services' stamp: 'tpr 9/15/2005 15:06'! isSourceFileSuffix: suffix ^ FileStream sourceFileSuffixes includes: suffix ! ! !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: 'file reader services' stamp: 'MarcusDenker 2/14/2010 09:35'! sourceFileSuffixes ^#('st' 'cs') ! ! !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: '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: 'initialize-release' stamp: 'GabrielOmarCotelli 6/4/2009 20:36'! unload FileServices unregisterFileReader: self ! ! !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: 'instance creation'! fileNamed: fileName ^ self concreteStream fileNamed: (self fullName: fileName)! ! !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: '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: '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: 'CamilloBruni 5/4/2012 21:11'! fullName: fileName ^ fileName asFileReference fullName ! ! !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: 'instance creation' stamp: 'di 2/15/98 14:03'! new ^ self basicNew! ! !FileStream class methodsFor: 'instance creation'! newFileNamed: fileName ^ self concreteStream newFileNamed: (self fullName: fileName)! ! !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'! oldFileNamed: fileName ^ self concreteStream oldFileNamed: (self fullName: fileName)! ! !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: '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'! readOnlyFileNamed: fileName ^ self concreteStream readOnlyFileNamed: (self fullName: fileName)! ! !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: '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: 'stdio' stamp: 'StephaneDucasse 5/18/2011 23:15'! newForStdio "This is a hook for subclasses to initialize themselves properly." ^self new! ! !FileStream class methodsFor: 'stdio' stamp: 'CamilloBruni 2/21/2013 16:57'! 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." OSPlatform 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: 'stdio' stamp: 'StephaneDucasse 5/18/2011 23:19'! stderr ^Stderr ifNil: [ Stderr := self standardIOStreamNamed: #stderr forWrite: true ]! ! !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: 'stdio' stamp: 'StephaneDucasse 5/18/2011 23:19'! stdioHandles self primitiveFailed! ! !FileStream class methodsFor: 'stdio' stamp: 'StephaneDucasse 5/18/2011 23:20'! stdout ^Stdout ifNil: [ Stdout := self standardIOStreamNamed: #stdout forWrite: true ]! ! !FileStream class methodsFor: 'stdio' stamp: 'StephaneDucasse 5/18/2011 23:20'! voidStdioFiles Stdin := Stdout := Stderr := StdioFiles := nil! ! !FileStream class methodsFor: 'system startup' stamp: 'StephaneDucasse 5/18/2011 23:15'! shutDown: quitting quitting ifTrue: [ self flushAndVoidStdioFiles ]! ! !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: '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. ! ! Error subclass: #FileStreamException instanceVariableNames: 'fileName' classVariableNames: '' poolDictionaries: '' category: 'Files-Kernel'! !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 methodsFor: 'exceptiondescription' stamp: 'mir 2/23/2000 20:14'! messageText "Return an exception's message text." ^messageText == nil ifTrue: [fileName printString] ifFalse: [messageText]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FileStreamException class instanceVariableNames: ''! !FileStreamException class methodsFor: 'exceptioninstantiator' stamp: 'mir 2/23/2000 20:12'! fileName: aFileName ^self new fileName: aFileName! ! ClassTestCase subclass: #FileStreamTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Files'! !FileStreamTest methodsFor: 'testing' stamp: 'CamilloBruni 7/23/2012 19:55'! testCachingNextChunkPut "Ensure that nextChunkPut:/nextChunk works properly on a caching file" | file text read | [file := FileStream forceNewFileNamed: 'testCachingNextChunkPut'. 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 / file name) ensureDeleted ].! ! !FileStreamTest methodsFor: 'testing' stamp: 'CamilloBruni 7/23/2012 19:58'! 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 ensureDeleted ].! ! !FileStreamTest methodsFor: 'testing' stamp: 'CamilloBruni 7/23/2012 20:14'! 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 ensureDeleted ] ! ! !FileStreamTest methodsFor: 'testing' stamp: 'CamilloBruni 7/23/2012 19:56'! testNextChunkOutOfBounds "self debug: #testNextChunkOutOfBounds" "Ensure that nextChunkPut:/nextChunk works properly on a caching file" | file text read | [file := FileStream forceNewFileNamed: 'testNextChunkOutOfBounds'. 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 / file name) ensureDeleted ].! ! !FileStreamTest methodsFor: 'testing' stamp: 'CamilloBruni 7/23/2012 19:56'! 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) ensureDeleted ].! ! !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: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: '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: '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: 'private' stamp: 'CamilloBruni 7/23/2012 19:54'! 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) ensureDeleted ]! ! Object subclass: #FileSystem instanceVariableNames: 'workingDirectory store' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Core-Public'! !FileSystem commentStamp: '' prior: 0! 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: 'accessing' stamp: 'cwp 3/29/2011 15:58'! changeDirectory: aPath self workingDirectoryPath: (self resolve: aPath)! ! !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: 'accessing' stamp: 'CamilloBruni 5/7/2012 01:12'! separator "Return path separator used by this filesystem." ^ store separator! ! !FileSystem methodsFor: 'accessing' stamp: 'cwp 2/18/2011 16:08'! store ^ store! ! !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: 'accessing' stamp: 'cwp 3/29/2011 15:57'! workingDirectoryPath ^ workingDirectory! ! !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: 'as yet unclassified' 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: 'comparing' stamp: 'cwp 2/18/2011 16:08'! = other ^ self species = other species and: [self store = other store]! ! !FileSystem methodsFor: 'comparing' stamp: 'cwp 2/18/2011 16:08'! hash ^ store hash! ! !FileSystem methodsFor: 'converting' stamp: 'cwp 11/21/2009 11:30'! pathFromObject: anObject ^ anObject asPathWith: self! ! !FileSystem methodsFor: 'converting' stamp: 'cwp 2/18/2011 16:39'! pathFromString: aString ^ store pathFromString: aString! ! !FileSystem methodsFor: 'converting' stamp: 'cwp 2/18/2011 12:09'! stringFromPath: aPath ^ store stringFromPath: aPath! ! !FileSystem methodsFor: 'delegated' stamp: 'cwp 3/25/2011 13:16'! openFileStream: aResolvable writable: aBoolean ^ store openFileStream: (self resolve: aResolvable) writable: aBoolean! ! !FileSystem methodsFor: 'initialize-release' stamp: 'cwp 2/18/2011 20:33'! initializeWithStore: aStore store := aStore. workingDirectory := store defaultWorkingDirectory! ! !FileSystem methodsFor: 'navigating' stamp: 'EstebanLorenzano 4/2/2012 11:42'! * anObject "Return a relative reference." ^ self referenceTo:( Path * anObject)! ! !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: '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: 'navigating' stamp: 'EstebanLorenzano 4/3/2012 13:06'! resolveReference: aReference ^ aReference fileSystem = self ifTrue: [workingDirectory resolvePath: aReference path]! ! !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: 'printing' stamp: 'cwp 2/18/2011 16:34'! forReferencePrintOn: aStream store forReferencePrintOn: aStream! ! !FileSystem methodsFor: 'printing' stamp: 'cwp 2/28/2011 12:29'! printPath: aPath on: aStream store printPath: aPath on: aStream! ! !FileSystem methodsFor: 'public' stamp: 'CamilloBruni 5/10/2012 16:01'! checkName: aString fixErrors: fixErrors ^ store checkName: aString fixErrors: fixErrors! ! !FileSystem methodsFor: 'public' stamp: 'cwp 2/19/2011 01:39'! close store close! ! !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' 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: '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: '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' stamp: 'cwp 3/25/2011 13:14'! delete: aResolvable store delete: (self resolve: aResolvable)! ! !FileSystem methodsFor: 'public' stamp: 'cwp 3/25/2011 19:14'! delimiter "Return path delimiter used by this filesystem." ^ store delimiter! ! !FileSystem methodsFor: 'public' stamp: 'cwp 3/25/2011 19:16'! ensureDirectory: 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 ensureDirectory: (self resolve: aResolvable)! ! !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: '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: 'CamilloBruni 5/7/2012 01:15'! extensionDelimiter ^ $.! ! !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' 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: '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' 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' 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' 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' 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: '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: 'public' stamp: 'cwp 3/29/2011 15:54'! resolve: aResolvable ^ aResolvable asResolvedBy: self! ! !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: '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-enumerating' stamp: 'CamilloBruni 7/10/2012 15:43'! childNamesAt: aResolvable ^ Array streamContents: [ :out | self childNamesAt: aResolvable do: [ :path| out nextPut: path ]].! ! !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-enumerating' stamp: 'CamilloBruni 1/19/2012 00:31'! childrenAt: aResolvable ^ Array streamContents: [ :out | self childrenAt: aResolvable do: [ :path| out nextPut: path ]].! ! !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 1/19/2012 00:32'! directoriesAt: aResolvable ^ Array streamContents: [ :out | self directoriesAt: aResolvable do: [ :path| out nextPut: path ]].! ! !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: 'CamilloBruni 7/10/2012 15:48'! directoryNamesAt: aResolvable ^ Array streamContents: [ :out | self directoryNamesAt: aResolvable do: [ :name| out nextPut: name ]].! ! !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-enumerating' stamp: 'GuillermoPolito 6/22/2012 12:21'! entriesAt: aResolvable ^ Array streamContents: [ :out | self entriesAt: aResolvable do: [ :entry | out nextPut: entry ] ]! ! !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: '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-enumerating' stamp: 'CamilloBruni 7/10/2012 15:44'! fileNamesAt: aResolvable ^ Array streamContents: [ :out | self fileNamesAt: aResolvable do: [ :path| out nextPut: path ]].! ! !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 1/19/2012 00:32'! filesAt: aResolvable ^ Array streamContents: [ :out | self filesAt: aResolvable do: [ :path| out nextPut: path ]].! ! !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: '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-testing' stamp: 'CamilloBruni 6/22/2012 17:57'! hasDirectories: aResolvable self entriesAt: aResolvable ifAbsent: [ ^ false ] do: [ :entry | entry isDirectory ifTrue: [ ^true ] ]. ^false! ! !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-testing' stamp: 'CamilloBruni 5/7/2012 01:19'! isCaseSensitive ^ self store isCaseSensitive! ! !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-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: '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: '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: '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: '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: '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 class instanceVariableNames: ''! !FileSystem class methodsFor: '*filesystem-disk' stamp: 'CamilloBruni 5/4/2012 19:19'! * aFileOrDirectoryName ^ self disk * aFileOrDirectoryName! ! !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-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: 'EstebanLorenzano 4/3/2012 13:13'! onDisk "This method provides compatibility with the original Filesystem interface" self deprecated: 'Use #disk' on: '3 April 2012' in: 'Pharo 1.4'. ^ self disk! ! !FileSystem class methodsFor: '*filesystem-disk' stamp: 'CamilloBruni 5/4/2012 20:54'! root ^ self disk root! ! !FileSystem class methodsFor: '*filesystem-disk' stamp: 'CamilloBruni 5/4/2012 20:53'! workingDirectory ^ self disk workingDirectory! ! !FileSystem class methodsFor: '*filesystem-memory' stamp: 'EstebanLorenzano 4/3/2012 13:13'! inMemory "This method provides compatibility with the original Filesystem interface" self deprecated: 'Use #memory' on: '3 April 2012' in: 'Pharo 1.4'. ^ self memory! ! !FileSystem class methodsFor: '*filesystem-memory' stamp: 'EstebanLorenzano 4/3/2012 09:36'! memory ^ self store: (MemoryStore new)! ! !FileSystem class methodsFor: '*filesystem-zip' stamp: 'EstebanLorenzano 4/3/2012 17:21'! inZip: aReference self deprecated: 'Use #zip:' on: '3 April 2012' in: 'Pharo 1.4'. ^ self zip: aReference ! ! !FileSystem class methodsFor: '*filesystem-zip' stamp: 'EstebanLorenzano 4/3/2012 17:20'! zip: aReference ^ self store: (ZipStore reference: aReference)! ! !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! ! !FileSystem class methodsFor: 'instance creation' stamp: 'cwp 2/18/2011 20:34'! store: aStore ^ self basicNew initializeWithStore: aStore; yourself! ! Object subclass: #FileSystemDirectoryEntry instanceVariableNames: 'reference creation modification isDirectory isSymlink size posixPermissions' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Core-Public'! !FileSystemDirectoryEntry commentStamp: 'cwp 11/18/2009 11:09' prior: 0! 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: 'accessing' stamp: 'StephaneDucasse 2/15/2010 17:59'! basename ^ reference basename! ! !FileSystemDirectoryEntry methodsFor: 'accessing' stamp: 'abc 5/11/2012 23:31'! creation ^ self creationTime ! ! !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'! creationTime "Return the creation date and time of the entry receiver." ^ creation! ! !FileSystemDirectoryEntry methodsFor: 'accessing' stamp: 'abc 5/11/2012 23:30'! modification ^ self modificationTime ! ! !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: 'CamilloBruni 7/10/2012 21:20'! modificationTime "Return the modification date and time of the entry receiver." ^ modification! ! !FileSystemDirectoryEntry methodsFor: 'accessing' stamp: 'EstebanLorenzano 7/3/2012 11:29'! permissions ^self posixPermissions ifNotNil: [ FileSystemPermission posixPermissions: self posixPermissions ]! ! !FileSystemDirectoryEntry methodsFor: 'accessing' stamp: 'EstebanLorenzano 6/22/2012 14:54'! posixPermissions ^posixPermissions! ! !FileSystemDirectoryEntry methodsFor: 'accessing' stamp: 'cwp 11/15/2009 21:54'! reference ^ reference! ! !FileSystemDirectoryEntry methodsFor: 'accessing' stamp: 'StephaneDucasse 1/27/2011 22:15'! size "Returns the receiver size" ^ size! ! !FileSystemDirectoryEntry methodsFor: 'converting' stamp: 'EstebanLorenzano 4/12/2012 14:28'! asFileReference ^ reference! ! !FileSystemDirectoryEntry methodsFor: 'converting' stamp: 'EstebanLorenzano 4/12/2012 14:30'! asReference self deprecated: 'Use #asFileReference instead' on: '12 April 2012' in: 'Pharo 1.4' . ^ self asFileReference! ! !FileSystemDirectoryEntry methodsFor: 'delegate' stamp: 'CamilloBruni 8/15/2011 17:02'! extension ^ reference extension! ! !FileSystemDirectoryEntry methodsFor: 'delegate' stamp: 'CamilloBruni 8/12/2011 20:33'! fullName ^ reference fullName! ! !FileSystemDirectoryEntry methodsFor: 'delegate' stamp: 'CamilloBruni 8/12/2011 20:56'! pathSegments ^ reference pathSegments! ! !FileSystemDirectoryEntry methodsFor: 'delegate' stamp: 'CamilloBruni 8/12/2011 20:32'! readStream ^ reference readStream! ! !FileSystemDirectoryEntry methodsFor: 'delegate' stamp: 'CamilloBruni 8/12/2011 20:33'! writeStream ^ reference writeStream! ! !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: 'printing' stamp: 'sd 2/11/2011 19:40'! printOn: aStream aStream nextPutAll: 'DirectoryEntry: '. reference ifNotNilDo: [:ref | aStream nextPutAll: reference printString].! ! !FileSystemDirectoryEntry methodsFor: 'testing' stamp: 'StephaneDucasse 1/27/2011 22:16'! isDirectory "Return whether the receiver is a directory" ^ isDirectory! ! !FileSystemDirectoryEntry methodsFor: 'testing' stamp: 'StephaneDucasse 1/27/2011 22:16'! isFile "Return whether the receiver is a file" ^ isDirectory not! ! !FileSystemDirectoryEntry methodsFor: 'testing' stamp: 'EstebanLorenzano 8/2/2012 15:32'! isSymlink ^isSymlink! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FileSystemDirectoryEntry class instanceVariableNames: ''! !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! ! Error subclass: #FileSystemError instanceVariableNames: 'reference' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Core-Kernel'! !FileSystemError commentStamp: 'cwp 11/18/2009 12:32' prior: 0! I am an abstract superclass for errors that may occur during filesystem operations.! !FileSystemError methodsFor: 'accessing' stamp: 'lr 7/13/2010 15:31'! reference ^ reference! ! !FileSystemError methodsFor: 'initialize-release' stamp: 'lr 8/16/2010 16:00'! initializeWithReference: aReference reference := aReference. messageText := aReference printString! ! !FileSystemError methodsFor: 'testing' stamp: 'lr 8/16/2010 16:00'! isResumable ^ true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FileSystemError class instanceVariableNames: ''! !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! ! Object subclass: #FileSystemGuide instanceVariableNames: 'visitor work' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Core-Implementation'! !FileSystemGuide commentStamp: 'cwp 11/18/2009 12:09' prior: 0! 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: 'as yet unclassified' stamp: 'CamilloBruni 8/12/2011 18:18'! pop ^ work removeLast! ! !FileSystemGuide methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 8/12/2011 18:18'! push: anObject work add: anObject! ! !FileSystemGuide methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 8/12/2011 18:20'! pushAll: aCollection aCollection do: [ :ea | self push: ea ]! ! !FileSystemGuide methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 8/12/2011 18:22'! top ^ work removeFirst! ! !FileSystemGuide methodsFor: 'initialize-release' 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: 'showing' stamp: 'cwp 10/29/2009 23:21'! show: aReference self subclassResponsibility! ! !FileSystemGuide methodsFor: 'showing' stamp: 'lr 7/13/2010 15:36'! whileNotDoneDo: aBlock [ work isEmpty ] whileFalse: [ aBlock value ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FileSystemGuide class instanceVariableNames: ''! !FileSystemGuide class methodsFor: 'instance creation' stamp: 'cwp 10/29/2009 19:27'! for: aVisitor ^ self basicNew initializeWithVisitor: aVisitor! ! !FileSystemGuide class methodsFor: 'instance creation' stamp: 'cwp 11/17/2009 11:58'! show: aReference to: aVisitor ^ (self for: aVisitor) show: aReference! ! Object subclass: #FileSystemHandle instanceVariableNames: 'reference writable' classVariableNames: 'Primitives' poolDictionaries: '' category: 'FileSystem-Core-Kernel'! !FileSystemHandle commentStamp: 'cwp 11/18/2009 11:11' prior: 0! 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: 'accessing' stamp: 'EstebanLorenzano 4/3/2012 13:02'! fileSystem ^ reference fileSystem ! ! !FileSystemHandle methodsFor: 'accessing' stamp: 'EstebanLorenzano 4/3/2012 13:03'! filesystem self deprecated: 'Use fileSystem' on: '3 April 2012' in: 'Pharo 1.4'. ^ self fileSystem ! ! !FileSystemHandle methodsFor: 'accessing' stamp: 'abc 5/11/2012 23:24'! fullName ^ reference fullName! ! !FileSystemHandle methodsFor: 'accessing' stamp: 'cwp 7/26/2009 12:51'! reference ^ reference! ! !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/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: '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/26/2009 12:50'! at: offset read: buffer startingAt: start count: count self subclassResponsibility! ! !FileSystemHandle methodsFor: 'public' stamp: 'cwp 7/26/2009 12:50'! at: offset write: buffer startingAt: start count: count self subclassResponsibility! ! !FileSystemHandle methodsFor: 'public' stamp: 'cwp 7/26/2009 12:50'! close self subclassResponsibility! ! !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:50'! flush self subclassResponsibility! ! !FileSystemHandle methodsFor: 'public' stamp: 'cwp 7/26/2009 12:50'! open self subclassResponsibility! ! !FileSystemHandle methodsFor: 'public' stamp: 'PavelKrivanek 11/23/2012 12:21'! readStream self subclassResponsibility! ! !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'! truncateTo: anInteger self subclassResponsibility! ! !FileSystemHandle methodsFor: 'public' stamp: 'PavelKrivanek 11/23/2012 12:21'! writeStream 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: '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 class instanceVariableNames: ''! !FileSystemHandle class methodsFor: 'instance creation' stamp: 'cwp 7/26/2009 12:52'! on: aReference writable: aBoolean ^ self new setReference: aReference writable: aBoolean! ! !FileSystemHandle class methodsFor: 'instance creation' stamp: 'cwp 7/26/2009 12:52'! open: aReference writable: aBoolean ^ (self on: aReference writable: aBoolean) open! ! TestCase subclass: #FileSystemHandleTest instanceVariableNames: 'filesystem handle reference' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Tests-Core'! !FileSystemHandleTest methodsFor: 'running' stamp: 'EstebanLorenzano 4/3/2012 11:43'! createFileSystem self subclassResponsibility ! ! !FileSystemHandleTest methodsFor: 'running' stamp: 'EstebanLorenzano 4/3/2012 11:42'! setUp filesystem := self createFileSystem. reference := filesystem * 'plonk'. handle := reference openWritable: true! ! !FileSystemHandleTest methodsFor: 'running' stamp: 'MarianoMartinezPeck 6/12/2012 12:46'! tearDown handle ensureClosed. reference ensureDeleted.! ! !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: '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: 'lr 4/13/2010 16:10'! testAtPutBinaryAscii self shouldnt: [ handle at: 1 put: 32 ] raise: Error. self shouldnt: [ handle at: 1 put: Character space ] raise: Error! ! !FileSystemHandleTest methodsFor: 'tests' stamp: 'lr 4/13/2010 16:07'! testAtWriteBinaryAscii self shouldnt: [ handle at: 1 write: #[32] startingAt: 1 count: 1 ] raise: Error. self shouldnt: [ handle at: 1 write: (String with: Character space) startingAt: 1 count: 1 ] raise: Error! ! !FileSystemHandleTest methodsFor: 'tests' stamp: 'cwp 7/26/2009 12:23'! testClose handle close. self deny: handle isOpen ! ! !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: 'CamilloBruni 6/23/2012 20:05'! testEnsureClosed filesystem := self createFileSystem. reference := filesystem * 'plonk'. handle := reference openWritable: true. handle ensureClosed. self deny: handle isOpen. handle ensureClosed. reference delete. handle reference exists ifTrue: [self error]. self shouldnt: [ handle ensureClosed ] raise: Error.! ! !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/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: '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 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/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/28/2009 22:40'! testWriteStream | stream | stream := handle writeStream. self assert: (stream respondsTo: #nextPut:)! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FileSystemHandleTest class instanceVariableNames: ''! !FileSystemHandleTest class methodsFor: 'testing' stamp: 'EstebanLorenzano 4/3/2012 09:38'! isAbstract ^ self name = #FileSystemHandleTest! ! !FileSystemHandleTest class methodsFor: 'testing' stamp: 'cwp 7/26/2009 12:46'! shouldInheritSelectors ^ true! ! Object subclass: #FileSystemPermission instanceVariableNames: 'posixPermission' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Core-Public'! !FileSystemPermission commentStamp: '' prior: 0! 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:10'! groupRead ^ self permissionBitAt: 6! ! !FileSystemPermission methodsFor: 'accessing' stamp: 'EstebanLorenzano 6/22/2012 15:11'! groupWrite ^ self permissionBitAt: 5! ! !FileSystemPermission methodsFor: 'accessing' stamp: 'EstebanLorenzano 6/22/2012 15:11'! otherExecute ^ self permissionBitAt: 1! ! !FileSystemPermission methodsFor: 'accessing' stamp: 'EstebanLorenzano 6/22/2012 15:11'! otherRead ^ self permissionBitAt: 3! ! !FileSystemPermission methodsFor: 'accessing' stamp: 'EstebanLorenzano 6/22/2012 15:11'! otherWrite ^ self permissionBitAt: 2! ! !FileSystemPermission methodsFor: 'accessing' stamp: 'EstebanLorenzano 6/22/2012 15:12'! ownerExecute ^ self permissionBitAt: 7! ! !FileSystemPermission methodsFor: 'accessing' stamp: 'EstebanLorenzano 6/22/2012 15:12'! ownerRead ^ self permissionBitAt: 9! ! !FileSystemPermission methodsFor: 'accessing' stamp: 'EstebanLorenzano 6/22/2012 15:12'! ownerWrite ^ self permissionBitAt: 8! ! !FileSystemPermission methodsFor: 'accessing' stamp: 'EstebanLorenzano 7/3/2012 11:28'! permissionBitAt: bitIndex ^ (posixPermission bitAt: bitIndex) == 1! ! !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: '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: 'testing' stamp: 'CamilloBruni 7/10/2012 21:32'! isReadable ^ self ownerRead! ! !FileSystemPermission methodsFor: 'testing' stamp: 'CamilloBruni 7/10/2012 21:33'! isWritable ^ self ownerWrite! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FileSystemPermission class instanceVariableNames: ''! !FileSystemPermission class methodsFor: 'instance creation' stamp: 'EstebanLorenzano 6/22/2012 15:02'! new self error: 'Should not be called. Use #posixPermission: instead'! ! !FileSystemPermission class methodsFor: 'instance creation' stamp: 'EstebanLorenzano 6/22/2012 15:01'! posixPermissions: aNumber ^self basicNew initialize: aNumber; yourself! ! Object subclass: #FileSystemResolver instanceVariableNames: 'next' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Core-Implementation'! !FileSystemResolver commentStamp: 'cwp 3/29/2011 17:04' prior: 0! 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: 'accessing' stamp: 'cwp 10/26/2009 20:53'! addResolver: aResolver next ifNil: [next := aResolver] ifNotNil: [next addResolver: aResolver]! ! !FileSystemResolver methodsFor: 'accessing' stamp: 'cwp 10/27/2009 10:28'! flushCaches self flushLocalCache. next ifNotNil: [next flushCaches]! ! !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/27/2009 11:18'! canResolve: aSymbol ^ self supportedOrigins includes: aSymbol! ! !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: 'EstebanLorenzano 4/12/2012 14:25'! resolveString: aString | decoded fs | decoded := (FilePath pathName: aString isEncoded: true) asSqueakPathName. fs := FileSystem disk. ^ FileReference fileSystem: fs path: (fs pathFromString: decoded)! ! !FileSystemResolver methodsFor: 'resolving' stamp: 'cwp 10/26/2009 20:06'! supportedOrigins ^ #()! ! !FileSystemResolver methodsFor: 'resolving' stamp: 'cwp 10/27/2009 09:26'! unknownOrigin: aSymbol ^ next ifNotNil: [next resolve: aSymbol]! ! TestCase subclass: #FileSystemResolverTest instanceVariableNames: 'resolver' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Tests-Core'! !FileSystemResolverTest methodsFor: 'asserting' stamp: 'EstebanLorenzano 4/12/2012 14:25'! assertOriginResolves: aSymbol | reference | reference := resolver resolve: aSymbol. self assert: (reference isKindOf: FileReference). self assert: reference isAbsolute. self assert: reference exists! ! !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 class instanceVariableNames: ''! !FileSystemResolverTest class methodsFor: 'testing' stamp: 'EstebanLorenzano 4/3/2012 09:40'! isAbstract ^ self name = #FileSystemResolverTest! ! Object subclass: #FileSystemStore instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Core-Kernel'! !FileSystemStore commentStamp: '' prior: 0! 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 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: '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: '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: 'abstract' stamp: 'EstebanLorenzano 8/2/2012 15:38'! basicIsSymlink: aNode ^self subclassResponsibility ! ! !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: '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: '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 7/10/2012 21:12'! basicSize: aNode "Used to get the size of the low-level representation (node / entry) " self subclassResponsibility ! ! !FileSystemStore methodsFor: 'abstract' stamp: 'cwp 2/19/2011 01:39'! close "Some kinds of filesystems need to open connections to external resources"! ! !FileSystemStore methodsFor: 'abstract' stamp: 'cwp 2/18/2011 23:59'! createDirectory: aPath self subclassResponsibility ! ! !FileSystemStore methodsFor: 'abstract' stamp: 'cwp 2/18/2011 13:25'! delete: aPath self subclassResponsibility ! ! !FileSystemStore methodsFor: 'abstract' 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: 'abstract' 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: 'abstract' stamp: 'cwp 2/18/2011 13:07'! directoryAt: aPath ifAbsent: absentBlock nodesDo: aBlock self subclassResponsibility ! ! !FileSystemStore methodsFor: 'abstract' stamp: 'cwp 2/18/2011 12:50'! nodeAt: aPath ifPresent: presentBlock ifAbsent: absentBlock 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: 'accessing' stamp: 'EstebanLorenzano 4/2/2012 11:42'! defaultWorkingDirectory ^ Path root! ! !FileSystemStore methodsFor: 'accessing' stamp: 'cwp 2/18/2011 17:19'! delimiter ^ self class delimiter! ! !FileSystemStore methodsFor: 'accessing' stamp: 'CamilloBruni 5/7/2012 01:20'! isCaseSensitive ^ self class isCaseSensitive! ! !FileSystemStore methodsFor: 'accessing' stamp: 'CamilloBruni 5/7/2012 01:13'! separator ^ self class separator! ! !FileSystemStore methodsFor: 'as yet unclassified' 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: '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: 'converting' stamp: 'cwp 2/28/2011 12:28'! printPath: aPath on: out "Use the unix convention by default, since it's the most common." aPath isAbsolute ifTrue: [ out nextPut: $/ ]. ^ aPath printOn: out delimiter: self delimiter! ! !FileSystemStore methodsFor: 'converting' stamp: 'CamilloBruni 1/19/2012 00:24'! stringFromPath: aPath ^ String streamContents: [ :out | self printPath: aPath on: out ]! ! !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: 'error signalling' stamp: 'CamilloBruni 9/5/2012 11:27'! signalDirectoryDoesNotExist: aPath ^ DirectoryDoesNotExist signalWith: aPath! ! !FileSystemStore methodsFor: 'error signalling' stamp: 'CamilloBruni 9/5/2012 11:27'! signalDirectoryExists: aPath ^ DirectoryExists signalWith: aPath! ! !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'! signalFileExists: aPath ^ FileExists 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 5/10/2012 16:01'! checkName: aString fixErrors: fixErrors ^ self subclassResponsibility! ! !FileSystemStore methodsFor: 'public' stamp: 'CamilloBruni 7/10/2012 20:56'! creationTime: aPath self nodeAt: aPath ifPresent: [ :entry | ^ self basicCreationTime: entry ] ifAbsent: [ ^ false ]. ! ! !FileSystemStore methodsFor: 'public' stamp: 'cwp 2/19/2011 00:00'! ensureDirectory: aPath (self isDirectory: aPath) ifTrue: [ ^ self ]. self ensureDirectory: aPath parent. self createDirectory: aPath! ! !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: 'cwp 2/18/2011 13:11'! exists: aPath self nodeAt: aPath ifPresent: [ :entry | ^ true ] ifAbsent: [ ^ false ]. ! ! !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: '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: 'public' stamp: 'CamilloBruni 5/9/2012 00:40'! isWritable: aPath self nodeAt: aPath ifPresent: [ :entry | ^ self basicIsWritable: entry ] ifAbsent: [ ^ false ]. ! ! !FileSystemStore methodsFor: 'public' stamp: 'CamilloBruni 5/9/2012 13:06'! mimeTypesAt: aPath ^ MIMEType forExtensionReturnMimeTypesOrNil: aPath extension! ! !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: 'PavelKrivanek 11/23/2012 12:21'! openFileStream: path writable: writable self subclassResponsibility! ! !FileSystemStore methodsFor: 'public' stamp: 'PavelKrivanek 7/12/2012 13:22'! permissions: aPath self nodeAt: aPath ifPresent: [ :entry | ^ FileSystemPermission posixPermissions: (self basicPosixPermissions: entry) ] ifAbsent: [ ^ false ]. ! ! !FileSystemStore methodsFor: 'public' stamp: 'CamilloBruni 7/10/2012 22:08'! size: aPath ^ self nodeAt: aPath ifPresent: [ :entry | ^ self basicSize: entry ] ifAbsent: [ ^ false ] ! ! !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: 'private' stamp: 'EstebanLorenzano 4/3/2012 13:28'! copy: sourcePath ifAbsent: absentBlock to: destinationPath ifPresent: presentBlock filesystem: aFilesystem self deprecated: 'Use #copy:ifAbsent:to:ifPresent:fileSystem:' on: '3 April 2012' in: 'Pharo 1.4'. ^self copy: sourcePath ifAbsent: absentBlock to: destinationPath ifPresent: presentBlock fileSystem: aFilesystem! ! !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: 'private' stamp: 'cwp 2/18/2011 12:28'! filename: aByteString matches: aByteString2 ^ aByteString = aByteString2! ! !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: 'private' stamp: 'EstebanLorenzano 4/3/2012 13:20'! rename: sourcePath ifAbsent: absentBlock to: destinationPath ifPresent: presentBlock filesystem: anFSFilesystem self deprecated: 'Use #rename:ifAbsent:to:ifPresent:filesystem:' on: '3 April 2012' in: 'Pharo 1.4'. ^ self rename: sourcePath ifAbsent: absentBlock to: destinationPath ifPresent: presentBlock fileSystem: anFSFilesystem.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FileSystemStore class instanceVariableNames: ''! !FileSystemStore class methodsFor: 'accessing' stamp: 'CamilloBruni 5/7/2012 01:10'! delimiter self shouldBeImplemented ! ! !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! ! TestCase subclass: #FileSystemTest instanceVariableNames: 'filesystem toDelete' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Tests-Core'! !FileSystemTest methodsFor: 'initialize-release' stamp: 'EstebanLorenzano 4/3/2012 13:04'! createFileSystem self subclassResponsibility ! ! !FileSystemTest methodsFor: 'initialize-release' stamp: 'cwp 10/10/2009 17:35'! delete: anObject toDelete add: (filesystem resolve: anObject)! ! !FileSystemTest methodsFor: 'initialize-release' stamp: 'EstebanLorenzano 4/3/2012 11:42'! setUp filesystem := self createFileSystem. toDelete := OrderedCollection new.! ! !FileSystemTest methodsFor: 'initialize-release' stamp: 'cwp 8/23/2009 23:09'! tearDown toDelete do: [:path | filesystem delete: path]! ! !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: '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: 'CamilloBruni 6/22/2012 20:24'! testChildrenAt | directory entries | directory := Path * 'plonk'. filesystem createDirectory: directory. filesystem createDirectory: directory / 'griffle'. filesystem createDirectory: directory / 'bint'. self delete: directory / 'griffle'. self delete: directory / 'bint'. self delete: 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: 'CamilloBruni 6/23/2012 20:00'! testCopy | out in contents | [ 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' ] ensure: [ filesystem delete: 'gooly'; delete: 'plonk' ]! ! !FileSystemTest methodsFor: 'tests' stamp: 'abc 5/11/2012 23:36'! testCopyDestExists | out | [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] ensure: [filesystem delete: 'gooly'; delete: 'plonk']! ! !FileSystemTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:41'! testCopySourceDoesntExist self should: [filesystem copy: 'plonk' to: 'griffle'] raise: FileDoesNotExist! ! !FileSystemTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testCreateDirectoryExists | path | path := Path * 'griffle'. self delete: path. filesystem createDirectory: path. self should: [filesystem createDirectory: path] raise: DirectoryExists. ! ! !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: 'cwp 7/20/2009 07:30'! testDefaultWorkingDirectory self assert: filesystem workingDirectory isRoot! ! !FileSystemTest methodsFor: 'tests' stamp: 'cwp 7/20/2009 07:30'! testDelimiter self assert: filesystem delimiter isCharacter! ! !FileSystemTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testDirectory | path | path := Path * 'plonk'. filesystem createDirectory: path. self assert: (filesystem exists: path). self assert: (filesystem isDirectory: path). self deny: (filesystem isFile: path). filesystem delete: path. self deny: (filesystem exists: path)! ! !FileSystemTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testEnsureDirectory | path | path := Path * 'plonk'. self delete: path. filesystem ensureDirectory: path. self assert: (filesystem isDirectory: path).! ! !FileSystemTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testEnsureDirectoryCreatesParent | path | path := Path * 'plonk' / 'griffle'. self delete: path. self delete: path parent. self shouldnt: [filesystem ensureDirectory: path] raise: FileSystemError. self assert: (filesystem isDirectory: (Path * 'plonk')). self assert: (filesystem isDirectory: path). ! ! !FileSystemTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testEnsureDirectoryExists | path | path := Path * 'plonk'. self delete: path. filesystem createDirectory: path. self shouldnt: [filesystem ensureDirectory: path] raise: FileSystemError. ! ! !FileSystemTest methodsFor: 'tests' stamp: 'CamilloBruni 6/22/2012 20:39'! testEntriesAt | directory entries | directory := Path * 'plonk'. filesystem createDirectory: directory. filesystem createDirectory: directory / 'griffle'. filesystem createDirectory: directory / 'bint'. self delete: directory / 'griffle'. self delete: directory / 'bint'. self delete: 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' stamp: 'CamilloBruni 7/10/2012 17:46'! testEntryAt | path now entry then | then := DateAndTime now - 1 asSeconds. path := Path * 'plonk'. filesystem createDirectory: path. self delete: path. entry := filesystem entryAt: path. now := (DateAndTime now + 1 asSeconds). self assert: entry isDirectory. self assert: entry reference = (filesystem referenceTo: path) asAbsolute. self assert: entry creationTime >= then. self assert: entry creationTime <= now. self assert: entry modificationTime >= then. self assert: entry modificationTime <= now.! ! !FileSystemTest methodsFor: 'tests' stamp: 'abc 5/11/2012 23:35'! testFile | path | path := Path * 'gooly'. (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' stamp: 'CamilloBruni 6/22/2012 21:52'! testFileNames | reference | #('test one' 'test with two') 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 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: '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' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testRootExists self assert: (filesystem exists: Path root)! ! !FileSystemTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testRootIsDirectory self assert: (filesystem isDirectory: Path root)! ! !FileSystemTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testRootIsNotAFile self deny: (filesystem isFile: Path root)! ! !FileSystemTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testSetRelativeWorkingDirectory self should: [filesystem workingDirectoryPath: (Path * 'plonk')] raise: Error ! ! !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/3/2012 13:06'! testWorking self assert: filesystem workingDirectory fileSystem = filesystem. self assert: filesystem workingDirectory path = filesystem workingDirectoryPath! ! !FileSystemTest methodsFor: 'tests-references' stamp: 'CamilloBruni 6/23/2012 20:00'! testReadStream | reference stream | self delete: (reference := filesystem workingDirectory / 'griffle'). self should: [ reference readStream ] raise: FileDoesNotExist. reference writeStreamDo: [ :ws | ws nextPutAll: 'griffle' ]. self shouldnt: [ stream := reference readStream ] raise: FileDoesNotExist. self assert: stream contents asString equals: 'griffle'. stream close! ! !FileSystemTest methodsFor: 'tests-references' stamp: 'EstebanLorenzano 4/2/2012 11:41'! testReadStreamDo | reference | self delete: (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 methodsFor: 'tests-references' stamp: 'sd 2/11/2011 18:21'! testReadStreamDoIfAbsent | reference | self delete: (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-references' stamp: 'sd 2/11/2011 18:21'! testReadStreamIfAbsent | reference stream | self delete: (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-references' stamp: 'sd 2/11/2011 18:21'! testWriteStream | reference stream | self delete: (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-references' stamp: 'sd 2/11/2011 18:21'! testWriteStreamDo | reference | self delete: (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-references' stamp: 'sd 2/11/2011 18:21'! testWriteStreamDoIfPresent | reference | self delete: (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: 'tests-references' stamp: 'sd 2/11/2011 18:21'! testWriteStreamIfPresent | reference stream | self delete: (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 class instanceVariableNames: ''! !FileSystemTest class methodsFor: 'accessing' stamp: 'EstebanLorenzano 4/3/2012 12:53'! packageNamesUnderTest ^ #('FileSystem')! ! !FileSystemTest class methodsFor: 'testing' stamp: 'EstebanLorenzano 4/3/2012 09:37'! isAbstract ^ self name = #FileSystemTest! ! !FileSystemTest class methodsFor: 'testing' stamp: 'cwp 7/20/2009 08:56'! shouldInheritSelectors ^ true ! ! TestCase subclass: #FileSystemTreeTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Tests-Core'! !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 instanceVariableNames: ''! !FileSystemTreeTest class methodsFor: 'testing' stamp: 'EstebanLorenzano 4/3/2012 11:38'! isAbstract ^ self name = #FileSystemTreeTest! ! Object subclass: #FileSystemVisitor instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Core-Implementation'! !FileSystemVisitor commentStamp: 'cwp 11/18/2009 12:25' prior: 0! 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'! visitDirectory: aReference ^ self visitReference: aReference! ! !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! ! Url subclass: #FileUrl instanceVariableNames: 'host path isAbsolute' classVariableNames: '' poolDictionaries: '' category: 'Network-Url'! !FileUrl commentStamp: 'gk 10/21/2005 10:58' prior: 0! 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: '*Gofer-Core' stamp: 'SeanDeNigris 8/26/2012 15:40'! mcRepositoryAsUser: usernameString withPassword: passwordString ^ MCDirectoryRepository new directory: self asFileReference.! ! !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: '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/10/2004 10:16'! host "Return the host name, either 'localhost', '', or a fully qualified domain name." ^host ifNil: ['']! ! !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: '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: '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: 'accessing' stamp: 'gk 2/10/2004 00:15'! path "Return an ordered collection of the path elements." ^path! ! !FileUrl methodsFor: 'accessing' stamp: 'gk 10/21/2005 11:11'! path: aCollection "Set the collection of path elements." path := aCollection! ! !FileUrl methodsFor: 'classification' stamp: 'gk 2/10/2004 10:34'! scheme ^self class schemeName! ! !FileUrl methodsFor: 'classification' stamp: 'gk 2/10/2004 10:34'! schemeName ^self class schemeName! ! !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: 'downloading' stamp: 'ls 8/4/1998 20:42'! hasContents ^true! ! !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: '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: '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: 'paths' stamp: 'nice 1/5/2010 15:59'! 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 encodeForHTTP ] ]! ! !FileUrl methodsFor: 'printing' stamp: 'fbs 2/2/2005 13:09'! 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 encodeForHTTP].! ! !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: 'private-initialization' stamp: 'gk 2/10/2004 13:05'! host: aHostString pathParts: aCollection isAbsolute: aBoolean host := aHostString. path := aCollection. isAbsolute := aBoolean! ! !FileUrl methodsFor: 'private-initialization' stamp: 'gk 2/12/2004 16:01'! 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 unescapePercents]. "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: 'private-initialization' stamp: 'gk 2/10/2004 13:04'! pathParts: aCollection isAbsolute: aBoolean ^self host: nil pathParts: aCollection isAbsolute: aBoolean! ! !FileUrl methodsFor: 'private-initialization' stamp: 'SvenVanCaekenberghe 1/8/2012 14:44'! 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 hasDriveLetter stream char i | bare := aString trimBoth. schemeName := Url 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: 'gk 2/12/2004 16:29'! privateInitializeFromText: pathString relativeTo: aUrl " should be a filesystem path. This url is adjusted to be aUrl + the path." | bare 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 unescapePercents ]. token = '..' ifTrue: [ newPath isEmpty ifFalse: [ newPath last = '..' ifFalse: [ newPath removeLast ] ] ]. "token = '.' do nothing" ]. path := newPath ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FileUrl class instanceVariableNames: ''! !FileUrl class methodsFor: 'constants' stamp: 'gk 2/10/2004 10:33'! schemeName ^'file'! ! !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! ! !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: '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 13:06'! pathParts: aCollectionOfPathParts isAbsolute: aBoolean "Create a FileUrl." ^self host: nil pathParts: aCollectionOfPathParts isAbsolute: aBoolean! ! ClassTestCase subclass: #FileUrlTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetworkTests-Url'! !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: 'MarcusDenker 5/7/2012 16:01'! testMatchingSchemesToSubclasses { { nil. GenericUrl }. "Assume HTTP by default (i.e. when no scheme is provided)" { 'isbn'. GenericUrl }. "Handle unknown Url types with GenericUrl" { 'http'. HttpUrl }. { 'https'. HttpsUrl }. { 'file'. FileUrl }. { 'mailto'. MailtoUrl }. { 'browser'. BrowserUrl } } do: [ :pair | | schemeString urlClassToUse | schemeString := pair first. urlClassToUse := pair second. self assert: ((Url urlClassForScheme: schemeString) = urlClassToUse) ].! ! FileStreamException subclass: #FileWriteError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Files-Kernel'! Object subclass: #FillStyle instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Balloon-Fills'! !FillStyle commentStamp: '' prior: 0! FillStyle is an abstract base class for fills in the BalloonEngine.! !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! ! !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: 'converting' stamp: 'Sd 11/2/2010 12:54'! asColor ^self subclassResponsibility ! ! !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 11/9/1998 13:54'! isBitmapFill ^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 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'! isSolidFill ^false! ! !FillStyle methodsFor: 'testing' stamp: 'ar 9/2/1999 14:28'! isTranslucent ^true "Since we don't know better"! ! !FillStyle methodsFor: 'testing' stamp: 'ar 10/26/2000 19:24'! isTransparent ^false! ! SimpleBorder subclass: #FillStyleBorder instanceVariableNames: 'fillStyle' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Borders'! !FillStyleBorder commentStamp: 'gvc 9/23/2008 11:56' prior: 0! BorderStyle supporting general (potentially composite) fillstyles. ! !FillStyleBorder methodsFor: 'accessing' stamp: 'gvc 6/24/2008 16:18'! fillStyle "Answer the value of fillStyle" ^fillStyle ifNil: [self color]! ! !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: '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: '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}! ! !FillStyleBorder methodsFor: 'testing' stamp: 'gvc 6/25/2008 12:11'! hasFillStyle "Answer true." ^true! ! TestCase subclass: #FillStyleTest instanceVariableNames: 'composite colorStyle' classVariableNames: '' poolDictionaries: '' category: 'Balloon-Fills-Tests'! !FillStyleTest commentStamp: '' prior: 0! A FillStyleTest is a test class for testing the behavior of FillStyle! !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! ! !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: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: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"! ! Model subclass: #FindReplaceService instanceVariableNames: 'findText replaceText caseSensitive entireWordsOnly wrapAround searchBackwards findStartIndex isRegex' classVariableNames: 'Singleton' poolDictionaries: '' category: 'Text-Edition'! !FindReplaceService methodsFor: 'accessing' stamp: 'AlainPlantec 11/12/2010 12:06'! caseSensitive ^ caseSensitive ifNil: [caseSensitive := TextEditor caseSensitiveFinds]! ! !FindReplaceService methodsFor: 'accessing' stamp: 'AlainPlantec 11/12/2010 21:22'! caseSensitive: aBoolean caseSensitive := aBoolean. self changed: #findPolicy! ! !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/10/2010 12:35'! entireWordsOnly ^ entireWordsOnly ifNil: [entireWordsOnly := false]! ! !FindReplaceService methodsFor: 'accessing' stamp: 'AlainPlantec 11/12/2010 21:22'! entireWordsOnly: aBoolean entireWordsOnly := aBoolean. self changed: #findPolicy! ! !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 methodsFor: 'accessing' stamp: 'AlainPlantec 11/17/2010 15:55'! findText ^ (findText ifNil: [findText := '' asText. findText]) asString! ! !FindReplaceService methodsFor: 'accessing' stamp: 'AlainPlantec 11/17/2010 15:49'! findText: aStringOrText findText := aStringOrText asText. self changed: #findPolicy! ! !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: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/12/2010 08:19'! findText: aStringOrText isRegex: aBoolean entireWordsOnly: forEntireWordsOnly self isRegex: aBoolean. self findText: aStringOrText. self entireWordsOnly: forEntireWordsOnly! ! !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:35'! isRegex ^ isRegex ifNil: [isRegex := false]! ! !FindReplaceService methodsFor: 'accessing' stamp: 'AlainPlantec 11/12/2010 21:23'! isRegex: aBoolean isRegex := aBoolean. self changed: #findPolicy ! ! !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/10/2010 12:47'! replaceText ^ replaceText ifNil: [replaceText := '']! ! !FindReplaceService methodsFor: 'accessing' stamp: 'AlainPlantec 11/16/2010 08:34'! replaceText: aStringOrText replaceText := aStringOrText asString. self changed: #findPolicy ! ! !FindReplaceService methodsFor: 'accessing' stamp: 'AlainPlantec 11/10/2010 12:35'! searchBackwards ^ searchBackwards ifNil: [searchBackwards := false]! ! !FindReplaceService methodsFor: 'accessing' stamp: 'AlainPlantec 11/12/2010 21:23'! searchBackwards: aBoolean searchBackwards := aBoolean. self changed: #findPolicy ! ! !FindReplaceService methodsFor: 'accessing' stamp: 'AlainPlantec 11/17/2010 15:59'! selectionRegexString ^ self convertedFindString ! ! !FindReplaceService methodsFor: 'accessing' stamp: 'AlainPlantec 11/10/2010 12:35'! wrapAround ^ wrapAround ifNil: [wrapAround := true]! ! !FindReplaceService methodsFor: 'accessing' stamp: 'AlainPlantec 11/12/2010 21:24'! wrapAround: aBoolean wrapAround := aBoolean. self changed: #findPolicy ! ! !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: '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: '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: '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 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: '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 class instanceVariableNames: ''! !FindReplaceService class methodsFor: 'accessing' stamp: 'AlainPlantec 11/12/2010 21:07'! default ^ EditorFindReplaceDialogWindow singleton state ! ! Object subclass: #Finder instanceVariableNames: 'searchingString selectedMethod selectedClass packagesSelection currentSearchMode environment resultDictionary useRegEx' classVariableNames: '' poolDictionaries: '' category: 'Tools-Finder'! !Finder commentStamp: 'BenjaminVanRyseghem 9/15/2010 11:17' prior: 0! 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: 'accessing' stamp: 'sd 4/21/2011 15:49'! currentSearchMode "Getter" "I shoud answer a Symbol in : - #Selectors - #Classes - #Source - #Examples" ^ currentSearchMode! ! !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:50'! environment: aCollection environment := aCollection! ! !Finder methodsFor: 'accessing' stamp: 'sd 4/21/2011 15:56'! packagesSelection "I should be a selection of classes" ^packagesSelection! ! !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 "I should answer a dictionary" ^resultDictionary! ! !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: 'accessing' stamp: 'sd 4/21/2011 15:55'! searchingString ^searchingString! ! !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: 'accessing' stamp: 'bvr 9/19/2010 18:27'! searchingStringSilently: aString searchingString := aString. ! ! !Finder methodsFor: 'accessing' stamp: 'sd 4/21/2011 15:55'! selectedClass ^selectedClass! ! !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: 'accessing' stamp: 'sd 4/21/2011 15:55'! selectedMethod "I should answer a CompiledMethod" ^selectedMethod! ! !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: 'CamilloBruni 10/10/2012 13:58'! 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 item selector. class := path first item 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: '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: 'accessing' stamp: 'sd 4/21/2011 15:51'! useRegEx: aBoolean useRegEx := aBoolean.! ! !Finder methodsFor: 'checkbox' stamp: 'BenjaminVanRyseghem 5/14/2012 13:45'! isClassNamesSymbol "answer if the current mode is Classes" ^self currentSearchMode = #Classes! ! !Finder methodsFor: 'checkbox' stamp: 'SeanDeNigris 6/25/2012 15:06'! isExamplesSymbol "Answer if the current mode is Examples" ^self currentSearchMode = #Examples! ! !Finder methodsFor: 'checkbox' stamp: 'BenjaminVanRyseghem 5/14/2012 13:49'! isPragmasSymbol "answer if the current mode is Pragmas" ^self currentSearchMode = #Pragmas! ! !Finder methodsFor: 'checkbox' stamp: 'BenjaminVanRyseghem 9/15/2010 23:23'! isSelectorsSymbol "answer if the current mode is Selectors" ^self currentSearchMode = #Selectors! ! !Finder methodsFor: 'checkbox' stamp: 'sd 4/21/2011 15:50'! isSourceSymbol "answer if the current mode is Source" ^self currentSearchMode = #Source! ! !Finder methodsFor: 'display' stamp: 'FernandoOlivero 5/30/2011 09:59'! open ^ (self uiClass on: self) open! ! !Finder methodsFor: 'initialize-release' stamp: 'sd 4/21/2011 15:49'! defaultEnvironment ^ Smalltalk globals allClassesAndTraits.! ! !Finder methodsFor: 'initialize-release' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! defaultPackagesSelection ^ self environment! ! !Finder methodsFor: 'initialize-release' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! defaultString ^''! ! !Finder methodsFor: 'initialize-release' 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: 'initialize-release' stamp: 'sd 4/21/2011 15:52'! uiClass "Answer the class used to create UI" ^FinderUI! ! !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: 'private' stamp: 'CamilloBruni 10/10/2012 11:15'! constructDictionary "I construct the adequate dictionary regarding the search mode" | symbol | self searchingString isEmpty ifTrue: [ ^ self resultDictionary: Dictionary new]. [ :job| job title: 'Searching...'. symbol := self currentSearchMode. 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' stamp: 'sd 4/21/2011 15:49'! disableUseRegEx "send a disable useRegEx dropbox event" ^ self triggerEvent: #disableUseRegEx! ! !Finder methodsFor: 'private' stamp: 'sd 4/21/2011 15:49'! enableUseRegEx "send a enable useRegEx dropbox event" ^ self triggerEvent: #enableUseRegEx! ! !Finder methodsFor: 'private' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! findSelector: aString "Answer the selector of aString." | example tokens | example := aString. tokens := Scanner new scanTokens: example. 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: '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: '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: '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: 'private' stamp: 'CamilloBruni 10/9/2012 20:47'! sourceRegexSearch: aSearchString | regex | regex := aSearchString asRegex. ^ self methodSearch: [ :method | regex search: method sourceCode ]! ! !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' stamp: 'CamilloBruni 10/9/2012 20:47'! sourceStringSearch: aSearchString ^ self methodSearch: [ :method | method sourceCode includesSubstring: aSearchString caseSensitive: false ]! ! !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: '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: 'private-class' stamp: 'CamilloBruni 10/10/2012 13:56'! constructClassNamesDictionary "Construct the dictionary in the case I'm searching in class names" | result listOfClasses listOfAssociations | listOfClasses := self computeListOfClasses: self searchingString. result := Dictionary new. listOfClasses do: [:each | result at: each put: (each methodDict keys sort: [:a :b | a < b])]. self resultDictionary: result.! ! !Finder methodsFor: 'private-example' stamp: 'CamilloBruni 10/10/2012 14:05'! 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: [^#()]. data := aString. "delete trailing period. This should be fixed in the Parser!!" data := data trimRight: [ :char| char isSeparator or: [ char = $. ]]. methodFinder := MethodFinder new. data := methodFinder cleanInputs: data. "remove common mistakes" [dataObjects := self class evaluatorClass evaluate: '{', data, '}'] on: SyntaxErrorNotification do: [:e | self inform: 'Syntax Error: ', e errorMessage. self contents: (e errorCode allButFirst allButLast). ^ #() ]. "#( data1 data2 result )" statements := (self class evaluatorClass new parse: 'zort ' , data in: Object notifying: nil) body statements select: [:each | (each isKindOf: ReturnNode) not]. dataStrings := statements collect:[:node | String streamContents: [:strm | (node isMessage) ifTrue: [strm nextPut: $(]. node shortPrintOn: strm. (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-example' stamp: 'sd 4/21/2011 15:48'! 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) not ifTrue: [ | key value receiver receiverString| 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: '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-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: '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: '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: '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 class instanceVariableNames: ''! !Finder class methodsFor: 'menu' stamp: 'BenjaminVanRyseghem 3/20/2011 01:29'! finderMenuOn: aBuilder "I build a menu" (aBuilder item: #Finder) action: [self open]; order: 0; parent: #Tools; help: 'Looking for something ?'; icon: self icon! ! !Finder class methodsFor: 'menu' stamp: 'BenjaminVanRyseghem 3/18/2011 11:30'! icon "My menu icon" ^ FinderUI icon! ! !Finder class methodsFor: 'menu' stamp: 'AlainPlantec 2/14/2011 21:25'! open ^ self new open! ! !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 ! ! FinderNode subclass: #FinderClassNode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tools-Finder'! !FinderClassNode commentStamp: '' prior: 0! A FinderClassNode is a node used by the FinderUI's tree representing a Class! !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: '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: '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: '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 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! ! !FinderClassNode methodsFor: 'private' stamp: 'BenjaminVanRyseghem 1/7/2012 18:11'! browseHierarchy self systemNavigation browseHierarchy: self item! ! !FinderClassNode methodsFor: 'private' stamp: 'BenjaminVanRyseghem 1/7/2012 18:11'! browseReferences self systemNavigation browseAllCallsOnClass: self item.! ! FinderNode subclass: #FinderMethodNode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tools-Finder'! !FinderMethodNode commentStamp: '' prior: 0! A FinderMethodNode is a node used by the FinderUI's tree representing a Method! !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: '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: 'events handling' stamp: 'BenjaminVanRyseghem 2/26/2011 12:49'! addInspectMenuItem: menu self hasParentNode ifTrue: [ ^ super addInspectMenuItem: menu ].! ! !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: '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: '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! ! !FinderMethodNode methodsFor: 'private' stamp: 'MarcusDenker 7/12/2012 18:00'! browseImplementors SystemNavigation new browseAllImplementorsOf: self item.! ! !FinderMethodNode methodsFor: 'private' stamp: 'MarcusDenker 7/12/2012 18:00'! browseSenders SystemNavigation new browseAllCallsOn: self item.! ! !FinderMethodNode methodsFor: 'private' stamp: 'CamilloBruni 2/21/2011 16:12'! inspectItem self hasParentNode ifTrue: [ (self parentNode item methodDict at: self item) inspect ].! ! !FinderMethodNode methodsFor: 'private' stamp: 'BenjaminVanRyseghem 6/22/2012 14:42'! isSingle ^ false! ! MorphTreeNodeModel subclass: #FinderNode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tools-Finder'! !FinderNode commentStamp: '' prior: 0! 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:44'! keyStroke: anEvent (anEvent controlKeyPressed or: [ anEvent commandKeyPressed ]) ifFalse: [ ^ false ]. anEvent keyCharacter == $b ifTrue: [ ^ self browse ]. anEvent keyCharacter == $i ifTrue: [ ^ self 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: 'testing' stamp: 'CamilloBruni 2/21/2011 15:47'! hasParentNode ^ self parentNode isNil not! ! !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! ! !FinderNode methodsFor: 'private' stamp: 'BenjaminVanRyseghem 6/22/2012 15:06'! displayString ^ self item asString! ! !FinderNode methodsFor: 'private' stamp: 'CamilloBruni 2/21/2011 15:29'! doubleClick self browse! ! !FinderNode methodsFor: 'private' stamp: 'CamilloBruni 2/21/2011 16:05'! inspectItem self item inspect! ! AbstractNautilusPlugin subclass: #FinderPlugin instanceVariableNames: 'finder finderui' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Plugin'! !FinderPlugin commentStamp: '' prior: 0! I show the finder bar within Nautilus! !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 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 class instanceVariableNames: ''! !FinderPlugin class methodsFor: 'as yet unclassified' stamp: 'DamienCassou 4/27/2012 19:19'! defaultPosition ^ #top! ! !FinderPlugin class methodsFor: 'as yet unclassified' stamp: 'DamienCassou 4/27/2012 19:21'! description "Use class comment as a description for the plugin" ^ self comment! ! FinderNode subclass: #FinderPragmaNode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tools-Finder'! !FinderPragmaNode commentStamp: '' prior: 0! A FinderPragmaNode is a Node used to render a pragma in the Finder Tree! !FinderPragmaNode methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/21/2012 08:52'! childNodeClassFromItem: anItem ^ FinderMethodNode ! ! !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: '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: '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'! browse! ! !FinderPragmaNode methodsFor: 'private' stamp: 'BenjaminVanRyseghem 2/21/2012 08:29'! browseClass! ! !FinderPragmaNode methodsFor: 'private' stamp: 'BenjaminVanRyseghem 2/21/2012 08:29'! browseHierarchy! ! !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'! 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).! ! FinderMethodNode subclass: #FinderSingleMethodNode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tools-Finder'! !FinderSingleMethodNode commentStamp: '' prior: 0! A FinderSingleMethodNode is a node used to display a selector implemented only once in the system! !FinderSingleMethodNode methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/22/2012 14:48'! childrenItems ^ #()! ! !FinderSingleMethodNode methodsFor: 'as yet unclassified' stamp: 'BenjaminVanRyseghem 6/22/2012 15:10'! displayString ^ self item selector, ' (',self item methodClass name,')'! ! !FinderSingleMethodNode methodsFor: 'private' stamp: 'BenjaminVanRyseghem 6/22/2012 14:43'! isSingle ^ true! ! MorphTreeModel subclass: #FinderUI instanceVariableNames: 'finder forceSearch searchingTextArea sourceTextArea useRegExCheckbox' classVariableNames: 'Icon SearchedTextList' poolDictionaries: '' category: 'Tools-Finder'! !FinderUI commentStamp: '' prior: 0! 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: '*Polymorph-TaskbarIcons' stamp: 'BenjaminVanRyseghem 3/18/2011 11:29'! taskbarIcon ^ self class icon! ! !FinderUI methodsFor: '*Shout-Styling' stamp: 'AlainPlantec 8/26/2011 23:56'! shoutAboutToStyle: aPluggableShoutMorphOrView aPluggableShoutMorphOrView classOrMetaClass: self selectedClass. self selectedClass isNil ifTrue: [ ^ false]. self selectedMethod isNil ifTrue: [^ false]. ^ true! ! !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: '*necompletion' stamp: 'SeanDeNigris 6/24/2012 09:19'! isCodeCompletionAllowed ^ true.! ! !FinderUI methodsFor: '*necompletion' stamp: 'SeanDeNigris 6/24/2012 09:20'! selectedClassOrMetaClass ^ self selectedClass.! ! !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: 'accessing' stamp: 'BenjaminVanRyseghem 9/14/2010 17:44'! currentSearchMode ^self finder currentSearchMode! ! !FinderUI methodsFor: 'accessing' stamp: 'bvr 9/19/2010 18:27'! currentSearchMode: aSymbol self finder searchingStringSilently: self searchingTextArea contentMorph textMorph text asString. self searchingTextArea contentMorph textMorph hasUnacceptedEdits:false. self finder currentSearchMode: aSymbol. .! ! !FinderUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/13/2010 16:12'! environment ^ self finder environment.! ! !FinderUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/13/2010 16:02'! finder ^finder! ! !FinderUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/13/2010 16:03'! finder: aFinder finder := aFinder! ! !FinderUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/2/2011 16:41'! forceSearch ^ forceSearch ifNil: [forceSearch := false].! ! !FinderUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/14/2010 14:25'! searchedTextList ^SearchedTextList ifNil: [ SearchedTextList := OrderedCollection new]! ! !FinderUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/16/2010 14:55'! searchedTextList: aCollection SearchedTextList := aCollection! ! !FinderUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 13:42'! searchedTextListMaxSize ^self class searchedTextListMaxSize! ! !FinderUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/18/2010 16:39'! searchedTextListMaxSize: anInteger [self searchedTextList size > anInteger] whileTrue: [ self searchedTextList removeLast]. self changed: #searchedTextList.! ! !FinderUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/13/2010 16:06'! searchingString ^self finder searchingString! ! !FinderUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/23/2011 15:27'! searchingString: aString ^self finder searchingString: aString! ! !FinderUI methodsFor: 'accessing' stamp: 'AlainPlantec 2/13/2011 21:48'! searchingTextArea ^searchingTextArea ifNil: [self buildSearchingTextArea]! ! !FinderUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/13/2010 16:11'! selectedClass ^ self finder selectedClass! ! !FinderUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/13/2010 16:13'! selectedMethod ^ self finder selectedMethod! ! !FinderUI methodsFor: 'accessing' stamp: 'AlainPlantec 10/8/2011 13:48'! selection: aSelection super selection: aSelection. self finder selection: aSelection! ! !FinderUI methodsFor: 'accessing' stamp: 'AlainPlantec 2/13/2011 21:41'! sourceTextArea ^sourceTextArea ifNil: [self buildSourceTextArea]! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 9/17/2010 01:57'! allClassesButtonAction self finder packagesSelection: self environment.! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'AlainPlantec 2/13/2011 22:31'! allClassesButtonLabel ^ 'All Packages'! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! allClassesButtonState ^false! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 3/3/2011 13:28'! browseButtonAction self selectedNode browse.! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! browseButtonLabel ^'Browse'! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 3/3/2011 13:29'! browseButtonState ^self selectedClass isNil or: [self selectedMethod isNil]! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 9/16/2010 01:16'! environmentButtonAction self openPackageChooser! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'AlainPlantec 2/13/2011 22:48'! environmentButtonLabel ^ 'Choose Packages'! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! environmentButtonState ^false.! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! hierarchyButtonAction self hierarchy.! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! hierarchyButtonLabel ^'Hierarchy'! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! hierarchyButtonState ^self selectedClass isNil.! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! implementorsButtonAction self implementors.! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! implementorsButtonLabel ^'Implementors'! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! implementorsButtonState ^self selectedMethod isNil | self isClassNamesSymbol.! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! inheritanceButtonAction self inheritance.! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! inheritanceButtonLabel ^'Inheritance'! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! inheritanceButtonState ^self selectedClass isNil | self isClassNamesSymbol.! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 2/17/2011 11:20'! searchButtonAction forceSearch := true. self searchingTextArea contentMorph acceptTextInModel.! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! searchButtonLabel ^'Search'! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! searchButtonState ^false.! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! sendersButtonAction self senders.! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! sendersButtonLabel ^'Senders'! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! sendersButtonState ^self selectedMethod isNil | self isClassNamesSymbol.! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 2/25/2011 17:07'! updateList "I update the list of my tree" self changed: #rootNodes.! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! versionsButtonAction self versions.! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! versionsButtonLabel ^'Versions'! ! !FinderUI methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! versionsButtonState ^self selectedClass isNil | self isClassNamesSymbol.! ! !FinderUI methodsFor: 'checkbox' stamp: 'BenjaminVanRyseghem 9/15/2010 01:47'! disableUseRegEx useRegExCheckbox isSelected ifTrue: [ useRegExCheckbox toggleSelected]. useRegExCheckbox enabled: false. ! ! !FinderUI methodsFor: 'checkbox' stamp: 'BenjaminVanRyseghem 9/15/2010 01:41'! enableUseRegEx useRegExCheckbox enabled: true; updateEnabled! ! !FinderUI methodsFor: 'display' stamp: 'BenjaminVanRyseghem 9/15/2010 02:47'! defaultWindowLabel ^'Finder'.! ! !FinderUI methodsFor: 'display' stamp: 'AlainPlantec 2/13/2011 21:17'! initialExtent ^700 @ 500! ! !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: 'do it requirements' stamp: 'BenjaminVanRyseghem 4/14/2011 11:47'! doItContext ^ nil! ! !FinderUI methodsFor: 'do it requirements' stamp: 'MarcusDenker 6/21/2011 16:33'! doItReceiver ^ self selectedClass ifNotNil: [:selectedClass | selectedClass theNonMetaClass].! ! !FinderUI methodsFor: 'events handling' stamp: 'BenjaminVanRyseghem 2/25/2011 16:48'! doubleClick self selectedNode doubleClick! ! !FinderUI methodsFor: 'events handling' stamp: 'StephaneDucasse 3/12/2011 15:07'! keyStroke: event self selectedNode ifNotNil: [:node | node keyStroke: event]! ! !FinderUI methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 2/21/2012 10:04'! initialize "Initialization code for FinderUI" super initialize. finder := nil. forceSearch := nil. searchingTextArea := nil. sourceTextArea := nil. useRegExCheckbox := nil. wrapBlockOrSelector := [: i | i asString ].! ! !FinderUI methodsFor: 'items creation' stamp: 'StephaneDucasse 12/19/2012 16:41'! addAllItems: aWindow | container toolbar height btnFont btnToolbar cst | toolbar := self buildSearchModeToolBar: aWindow. height := toolbar minExtent y. cst := 15. aWindow addMorph: toolbar fullFrame: ( (0 @ 0 corner: 1 @ 0) asLayoutFrame bottomOffset: height). aWindow addMorph: self buildPackagesTree buildContents fullFrame: ((0@0 corner: 1@0.58) asLayoutFrame topOffset: height). btnFont := StandardFonts buttonFont. btnToolbar := self buildBrowseToolBar: aWindow. aWindow addMorph: btnToolbar fullFrame: ((0@0.58 corner: 1@0.58) asLayoutFrame bottomOffset: (btnFont height +cst)). aWindow addMorph: self sourceTextArea fullFrame: ((0@0.58 corner: 1@1) asLayoutFrame topOffset: btnFont height +cst) ! ! !FinderUI methodsFor: 'items creation' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! buildAllClassesButton ^ PluggableButtonMorph on: self getState: #allClassesButtonState action: #allClassesButtonAction label: #allClassesButtonLabel! ! !FinderUI methodsFor: 'items creation' stamp: 'BenjaminVanRyseghem 8/30/2010 3:44'! buildAllTextArea self buildSearchingTextArea. self buildSourceTextArea.! ! !FinderUI methodsFor: 'items creation' stamp: 'BenjaminVanRyseghem 9/15/2010 02:03'! buildBrowseButton ^ (PluggableButtonMorph on: self getState: #browseButtonState action: #browseButtonAction label: #browseButtonLabel) hResizing: #spaceFill! ! !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 8/30/2010 3:44'! buildEnvironmentButton ^ (PluggableButtonMorph on: self getState: #environmentButtonState action: #environmentButtonAction label: #environmentButtonLabel) beSticky! ! !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: 'items creation' stamp: 'BenjaminVanRyseghem 9/15/2010 02:04'! buildImplementorsButton ^ (PluggableButtonMorph on: self getState: #implementorsButtonState action: #implementorsButtonAction label: #implementorsButtonLabel) hResizing: #spaceFill! ! !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: 'items creation' stamp: 'AlainPlantec 10/8/2011 14:20'! buildPackagesTree ^ self defaultTreeMorph! ! !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: 'items creation' stamp: 'BenjaminVanRyseghem 2/17/2011 11:06'! buildSearchButton ^ (PluggableButtonMorph on: self getState: #searchButtonState action: #searchButtonAction label: #searchButtonLabel) hResizing: #shrinkWrap! ! !FinderUI methodsFor: 'items creation' stamp: 'FernandoOlivero 4/12/2011 09:45'! buildSearchModeDropListIn: aWindow ^(self theme newDropListIn: aWindow for:self list: #searchModesList getSelected: #currentSearchMode setSelected: #currentSearchMode: getEnabled: nil useIndex: false help: self searchModeHelpText) hResizing: #rigid; width: 120; yourself ! ! !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: '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: 'items creation' stamp: 'BenjaminVanRyseghem 9/15/2010 02:04'! buildSendersButton ^ (PluggableButtonMorph on: self getState: #sendersButtonState action: #sendersButtonAction label: #sendersButtonLabel) hResizing: #spaceFill! ! !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: 'items creation' stamp: 'BenjaminVanRyseghem 9/15/2010 02:04'! buildVersionsButton ^ (PluggableButtonMorph on: self getState: #versionsButtonState action: #versionsButtonAction label: #versionsButtonLabel) hResizing: #spaceFill! ! !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 2/13/2011 21:44'! useRegExCheckbox ^ useRegExCheckbox ifNil: [self buildRegExChooser] ! ! !FinderUI methodsFor: 'mode list' stamp: 'BenjaminVanRyseghem 5/14/2012 13:45'! isClassNamesSymbol ^self finder isClassNamesSymbol! ! !FinderUI methodsFor: 'mode list' stamp: 'SeanDeNigris 6/25/2012 15:05'! isExamplesSymbol ^self finder isExamplesSymbol! ! !FinderUI methodsFor: 'mode list' stamp: 'BenjaminVanRyseghem 5/14/2012 13:49'! isPragmasSymbol ^self finder isPragmasSymbol! ! !FinderUI methodsFor: 'mode list' stamp: 'BenjaminVanRyseghem 9/15/2010 00:10'! isSelectorsSymbol ^self finder isSelectorsSymbol! ! !FinderUI methodsFor: 'mode list' stamp: 'BenjaminVanRyseghem 9/14/2010 23:54'! isSourceSymbol ^self finder isSourceSymbol! ! !FinderUI methodsFor: 'mode list' stamp: 'SeanDeNigris 6/25/2012 19:20'! searchModesList ^#(Selectors Classes Source Pragmas Examples)! ! !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: 't - accessing' stamp: 'BenjaminVanRyseghem 2/26/2011 12:53'! menu: menu shifted: b ^ self selectedNode menu: menu shifted: b ! ! !FinderUI methodsFor: 't - accessing' stamp: 'SeanDeNigris 6/25/2012 19:20'! 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: [FinderMethodNode] forPragmasDo: [FinderPragmaNode]! ! !FinderUI methodsFor: 't - accessing' stamp: 'BenjaminVanRyseghem 6/22/2012 15:09'! rootNodeFromItem: anItem | node | node := super rootNodeFromItem: anItem. node class = FinderSingleMethodNode ifTrue: [ | item | item := (self resultDictionary at: anItem) first >> anItem. node item: item ]. ^ node! ! !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: 'text areas behavior' stamp: 'BenjaminVanRyseghem 9/17/2010 02:50'! collectFromPackages: aCollection self packagesSelection: (self environment select: [:each | aCollection includes: each category ])! ! !FinderUI methodsFor: 'text areas behavior' stamp: 'MarcusDenker 8/23/2011 13:49'! compileSource: aString notifying: aController | association 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: '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: 'text areas behavior' stamp: 'SeanDeNigris 6/25/2012 15:05'! sourceCode ^ self selectedClass isNil ifTrue: [ self isExamplesSymbol ifTrue: [ self class methodFinderExplanation ] ifFalse: [ self defaultExplanation]] ifFalse:[ self selectedMethod isNil ifTrue: [ self buildDescriptionOf: self selectedClass] ifFalse:[ | method | method := self isExamplesSymbol ifTrue: [self finder findSelector: self selectedMethod] ifFalse: [self selectedMethod]. (self selectedClass >> method) sourceCode]]! ! !FinderUI methodsFor: 'text areas behavior' stamp: 'BenjaminVanRyseghem 5/16/2011 13:38'! updateSourceCode self changed: #sourceCode.! ! !FinderUI methodsFor: 'tree behavior' stamp: 'BenjaminVanRyseghem 9/14/2010 16:35'! resultDictionary ^self finder resultDictionary ! ! !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: 'BenjaminVanRyseghem 5/16/2011 13:42'! autoSelection | aString firstIndex interval string size | (self searchingString isEmpty or: [ self useRegEx] ) ifTrue: [^ 0 to:0 ]. self isSourceSymbol ifFalse: [^ 0 to: 0]. aString := sourceTextArea text asString asLowercase. aString = self defaultExplanation asLowercase ifTrue: [ ^ 0 to: 0]. string := self searchingString asLowercase. (string includes: $*) ifTrue: [| list lastIndex| list := string subStrings: '*'. firstIndex := aString findString: list first. lastIndex := (aString findString: list last startingAt: firstIndex) + list last size - 1. interval := firstIndex to: lastIndex] ifFalse: [| index | firstIndex := aString findString: string. size := string size. interval := firstIndex to: (firstIndex + size - 1)]. ^ firstIndex = 0 ifTrue: [ 0 to:0 ] ifFalse: [interval]! ! !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. 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: 'initialize-release' stamp: 'AlainPlantec 2/13/2011 22:20'! initialize searchedTextListMaxSize := 15! ! !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: 'settings' stamp: 'BenjaminVanRyseghem 12/16/2010 15:41'! finderUISettingsOn: aBuilder (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]! ! AbstractFont subclass: #FixedFaceFont instanceVariableNames: 'baseFont substitutionCharacter displaySelector' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Fonts'! !FixedFaceFont commentStamp: 'tak 12/22/2004 01:45' prior: 0! 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: 'ar 1/5/2003 16:58'! ascent ^baseFont ascent! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:57'! baseFont ^baseFont! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:57'! baseFont: aFont baseFont := aFont! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:59'! baseKern ^baseFont baseKern! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'tak 12/22/2004 02:01'! characterFormAt: character ^ baseFont characterFormAt: substitutionCharacter! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 17:00'! descent ^baseFont descent! ! !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: 'nk 8/31/2004 09:25'! familyName ^baseFont familyName, '-pw'! ! !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: 'ar 1/5/2003 16:57'! height ^baseFont height! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:26'! lineGrid ^baseFont lineGrid! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'tak 12/20/2004 10:51'! maxAscii ^ SmallInteger maxVal! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'ar 1/5/2003 16:59'! passwordCharacter ^$*! ! !FixedFaceFont methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:28'! pointSize ^baseFont pointSize! ! !FixedFaceFont methodsFor: 'caching' stamp: 'nk 3/15/2004 18:48'! releaseCachedState baseFont releaseCachedState.! ! !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: '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: '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: '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: '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 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: '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: '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: 'ar 1/5/2003 17:00'! installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor ^baseFont installOn: aDisplayContext foregroundColor: foregroundColor backgroundColor: backgroundColor! ! !FixedFaceFont methodsFor: 'initialization' stamp: 'yo 1/7/2005 11:59'! errorFont displaySelector := #displayErrorOn:length:at:kern:baselineY:. substitutionCharacter := $?.! ! !FixedFaceFont methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:54'! initialize super initialize. baseFont := TextStyle defaultFont. self passwordFont! ! !FixedFaceFont methodsFor: 'initialization' stamp: 'yo 1/7/2005 11:59'! passwordFont displaySelector := #displayPasswordOn:length:at:kern:baselineY:. substitutionCharacter := $*! ! !FixedFaceFont methodsFor: 'measuring' stamp: 'tak 12/20/2004 18:05'! widthOf: aCharacter ^ baseFont widthOf: substitutionCharacter! ! !FixedFaceFont methodsFor: 'private' stamp: 'yo 1/11/2005 18:54'! glyphInfoOf: aCharacter into: glyphInfoArray ^ baseFont glyphInfoOf: substitutionCharacter into: glyphInfoArray. ! ! Number variableWordSubclass: #Float instanceVariableNames: '' classVariableNames: 'E Epsilon Halfpi Infinity Ln10 Ln2 MaxVal MaxValLn MinValLogBase2 NaN NegativeInfinity NegativeZero Pi RadiansPerDegree Sqrt2 ThreePi Twopi' poolDictionaries: '' category: 'Kernel-Numbers'! !Float commentStamp: 'VeronicaUquillas 6/11/2010 14:51' prior: 0! 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: '*Fuel' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^aGeneralMapper visitHookPrimitive: self! ! !Float methodsFor: '*Fuel' stamp: 'MartinDias 12/30/2011 10:55'! serializeOn: anEncoder anEncoder encodeUint32: (self at: 1); encodeUint32: (self at: 2).! ! !Float methodsFor: '*Tools-Inspector' stamp: 'SvenVanCaekenberghe 11/26/2012 14:23'! inspectorClass ^ FloatInspector! ! !Float methodsFor: 'accessing' stamp: 'eem 4/19/2009 18:03'! at: index ^self basicAt: index! ! !Float methodsFor: 'accessing' stamp: 'eem 4/19/2009 18:03'! at: index put: value ^self basicAt: index put: value! ! !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: '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: '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: '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: '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: '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: '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: '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: '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: '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: # ^ aNumber adaptToFloat: self andCompare: #<=! ! !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: '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: '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: '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: '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: 'comparing'! ~= 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: '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: 'converting' stamp: 'di 11/6/1998 13:38'! adaptToFraction: rcvr andSend: selector "If I am involved in arithmetic with a Fraction, convert it to a Float." ^ rcvr asFloat perform: selector with: self! ! !Float methodsFor: 'converting' stamp: 'nice 1/4/2009 20:31'! adaptToInteger: rcvr andCompare: selector "If I am involved in comparison with an Integer, 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: [ self fractionPart = 0.0 ifFalse: [^false]]. selector == #~= ifTrue: [ self fractionPart = 0.0 ifFalse: [^true]]. ^ rcvr perform: selector with: self asTrueFraction! ! !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: '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: '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: 'converting'! asFloat "Answer the receiver itself." ^self! ! !Float methodsFor: 'converting' stamp: 'sma 5/3/2000 21:46'! asFraction ^ self asTrueFraction ! ! !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 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: 'converting'! degreesToRadians "Answer the receiver in radians. Assumes the receiver is in degrees." ^self * RadiansPerDegree! ! !Float methodsFor: 'converting'! radiansToDegrees "Answer the receiver in degrees. Assumes the receiver is in radians." ^self / RadiansPerDegree! ! !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: 'copying'! deepCopy ^self copy! ! !Float methodsFor: 'copying' stamp: 'nice 10/4/2009 23:16'! shallowCopy ^self - 0.0! ! !Float methodsFor: 'copying' stamp: 'pmm 3/13/2010 11:30'! veryDeepCopyWith: deepCopier "Return self. Do not record me." ^ self shallowCopy! ! !Float methodsFor: 'mathematical functions'! arcCos "Answer the angle in radians." ^ Halfpi - self arcSin! ! !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: 'mathematical functions'! 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: '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: '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: 'mathematical functions'! cos "Answer the cosine of the receiver taken as an angle in radians." ^ (self + Halfpi) sin! ! !Float methodsFor: 'mathematical functions' stamp: 'nice 11/1/2010 11:56'! degreeCos "Take care of exceptional values" self isFinite ifTrue: [^super degreeCos]. ^self degreesToRadians cos! ! !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'! 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: '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: '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'! log "Answer the base 10 logarithm of the receiver." ^ self ln / Ln10! ! !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: '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: '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: 'mathematical functions' stamp: 'laza 12/21/1999 12:15'! safeArcCos "Answer the angle in radians." (self between: -1.0 and: 1.0) ifTrue: [^ self arcCos] ifFalse: [^ self sign arcCos]! ! !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'! 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: '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: 'mathematical functions'! tan "Answer the tangent of the receiver taken as an angle in radians." ^ self sin / self cos! ! !Float methodsFor: 'mathematical functions'! 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: 'printing' stamp: 'StephaneDucasse 10/16/2011 18:10'! 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. mMinus := 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. mMinus := 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: '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: '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: '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: '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: '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: '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 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: '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: 'testing' stamp: 'bf 8/20/1999 12:56'! hasContentsInExplorer ^false! ! !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: 'testing'! isFloat ^ true! ! !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: '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: 'testing' stamp: 'tao 10/10/97 16:39'! isNaN "simple, byte-order independent test for Not-a-Number" ^ self ~= self! ! !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: 'testing' stamp: 'StephaneDucasse 10/16/2011 18:14'! isSelfEvaluating ^true! ! !Float methodsFor: 'testing'! isZero ^self = 0.0! ! !Float methodsFor: 'truncation and round off'! 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: 'truncation and round off'! 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: 'truncation and round off'! integerPart "Answer a Float whose value is the receiver's truncated value." ^self - self fractionPart! ! !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: '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: '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: '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: 'truncation and round off' stamp: 'tao 4/19/98 13:14'! significand ^ self timesTwoPower: (self exponent negated)! ! !Float methodsFor: 'truncation and round off' stamp: 'nice 3/23/2008 16:03'! significandAsInteger | exp sig | exp := self exponent. sig := (((self at: 1) bitAnd: 16r000FFFFF) bitShift: 32) bitOr: (self at: 2). (exp > -1023 and: [self ~= 0.0]) ifTrue: [sig := sig bitOr: (1 bitShift: 52)]. ^ sig.! ! !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: '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: '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: '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 class instanceVariableNames: ''! !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: '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: 'nice 6/11/2009 12:29'! denormalized "Answer whether implementation supports denormalized numbers (also known as gradual underflow)." ^true! ! !Float class methodsFor: 'constants'! e "Answer the constant, E." ^E! ! !Float class methodsFor: 'constants' stamp: 'nice 6/8/2009 15:42'! emax "Answer exponent of maximal representable value" ^1023! ! !Float class methodsFor: 'constants' stamp: 'nice 6/8/2009 15:43'! emin "Answer exponent of minimal normalized representable value" ^-1022! ! !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:20'! fmax "Answer the maximum finite floating point value representable." ^MaxVal! ! !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:22'! fminDenormalized "Answer the minimum denormalized value representable." ^1.0 timesTwoPower: MinValLogBase2! ! !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: 'sw 10/8/1999 22:59'! halfPi ^ Halfpi! ! !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: '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: 'tao 4/23/98 11:38'! nan "Answer the canonical value used to represent Not-A-Number" ^ NaN! ! !Float class methodsFor: 'constants' stamp: 'tao 4/23/98 12:05'! negativeZero ^ NegativeZero! ! !Float class methodsFor: 'constants' stamp: 'GabrielOmarCotelli 5/25/2009 15:42'! one ^1.0! ! !Float class methodsFor: 'constants'! pi "Answer the constant, Pi." ^Pi! ! !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: 'yo 6/17/2004 17:44'! threePi ^ ThreePi ! ! !Float class methodsFor: 'constants' stamp: 'yo 6/17/2004 17:41'! twoPi ^ Twopi ! ! !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: 'instance creation'! readFrom: aStream "Answer a new Float as described on the stream, aStream." ^(super readFrom: aStream) asFloat! ! !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! ! ArrayedCollection variableWordSubclass: #FloatArray instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Native'! !FloatArray commentStamp: '' prior: 0! FloatArrays store 32bit IEEE floating point numbers.! !FloatArray methodsFor: '*Collections-arithmetic' stamp: 'GuillermoPolito 2/18/2011 07:23'! * anObject ^self copy *= anObject! ! !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: '*Collections-arithmetic' stamp: 'GuillermoPolito 2/18/2011 07:23'! + anObject ^self copy += anObject! ! !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: '*Collections-arithmetic' stamp: 'StephaneDucasse 12/24/2011 12:04'! - anObject ^self shallowCopy -= anObject! ! !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: '*Collections-arithmetic' stamp: 'GuillermoPolito 2/18/2011 07:22'! / anObject ^self copy /= anObject! ! !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: '*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: '*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: 'laza 3/24/2000 13:07'! 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: '*Collections-arithmetic' stamp: 'GuillermoPolito 2/18/2011 07:23'! negated ^self copy *= -1! ! !FloatArray methodsFor: 'accessing' stamp: 'ar 2/2/2001 15:47'! at: index ^Float fromIEEE32Bit: (self basicAt: index)! ! !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: '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: '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: 'converting' stamp: 'ar 9/14/1998 23:46'! asFloatArray ^self! ! !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: '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: '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: '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'! primMulArray: 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'! 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'! 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'! primSubScalar: scalarValue 1 to: self size do:[:i| self at: i put: (self at: i) - scalarValue].! ! !FloatArray methodsFor: 'primitives-plugin' stamp: 'jcg 6/12/2003 17:54'! sum ^ super sum! ! !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! ! CollectionRootTest subclass: #FloatArrayTest uses: TCreationWithTest + TSequencedStructuralEqualityTest + TSequencedConcatenationTest + TSetArithmetic + TAsStringCommaAndDelimiterSequenceableTest + TPrintOnSequencedTest + TEmptyTest + TBeginsEndsWith + TCloneTest + TConvertTest - {#testAsByteArray. #integerCollectionWithoutEqualElements} + TConvertAsSortedTest + TConvertAsSetForMultiplinessIdentityTest - {#testAsIdentitySetWithEqualsElements. #testAsIdentitySetWithIdentityEqualsElements} + TCopyPartOfSequenceable + TCopyPartOfSequenceableForMultipliness + TCopySequenceableSameContents + TCopySequenceableWithOrWithoutSpecificElements + TCopySequenceableWithReplacement + TCopyTest + TIncludesWithIdentityCheckTest - {#testIdentityIncludesNonSpecificComportement} + TIndexAccess - {#testIdentityIndexOf. #testIdentityIndexOfIAbsent} + TIndexAccessForMultipliness - {#testIdentityIndexOfIAbsentDuplicate. #testIdentityIndexOfDuplicate} + TIterateSequencedReadableTest + TPutTest + TPutBasicTest + TReplacementSequencedTest + TSequencedElementAccessTest + TSortTest + TSubCollectionAccess instanceVariableNames: 'nonEmpty5ElementsNoDuplicate empty elementNotIn elementTwiceIn collectionWithEqualElements nonEmpty1Element collectionWithSameAtEndAndBegining collectionWith1TimeSubcollection collectionWith2TimeSubcollection collectionNotIncluded nonEmptySubcollection elementInNonEmpty replacementCollectionSameSize sortedCollection' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Arrayed'! !FloatArrayTest commentStamp: 'nice 5/30/2006 01:24' prior: 0! These tests are used to assert that FloatArrayPlugin has same results as Float asIEEE32BitWord! !FloatArrayTest methodsFor: '*Collections-arithmetic-testing' 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: 'as yet unclassified'! 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: 'as yet unclassified'! testStreamContentsProtocol | result index | result:= self collectionClass << [ :s| s nextPutAll: self firstCollection; nextPutAll: self secondCollection ]. self assert: result equals: self firstCollection, self secondCollection.! ! !FloatArrayTest methodsFor: 'as yet unclassified'! 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: '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 16:23'! anIndex " return an index in nonEmpty bounds" ^ 2! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:50'! anotherElementNotIn " return an element different of 'elementNotIn' not included in 'nonEmpty' " ^ elementNotIn ! ! !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: '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:24'! anotherValue " return a value ( not eual to 'aValue' ) to put into nonEmpty " ^ elementInNonEmpty ! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 14:56'! collection ^ nonEmpty5ElementsNoDuplicate ! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 11:45'! collectionClass ^ FloatArray! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:55'! collectionMoreThan1NoDuplicates " return a collection of size > 1 without equal elements" ^ nonEmpty5ElementsNoDuplicate ! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 12:05'! collectionMoreThan5Elements " return a collection including at least 5 elements" ^ nonEmpty5ElementsNoDuplicate ! ! !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: '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: '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: 'requirements'! 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: '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: '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: 'requirements'! 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: '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: '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: 'requirements' stamp: 'delaunay 5/14/2009 15:02'! collectionWithSortableElements " return a collection elements that can be sorte ( understanding message ' < ' or ' > ')" ^ nonEmpty5ElementsNoDuplicate ! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'CamilloBruni 9/9/2011 12:11'! collectionWithoutEqualElements " return a collection not including equal elements " ^ nonEmpty5ElementsNoDuplicate ! ! !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: 'requirements' stamp: 'delaunay 5/14/2009 16:35'! elementInForElementAccessing " return an element inculded in 'moreThan4Elements'" ^ elementInNonEmpty ! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:02'! elementInForIndexAccessing " return an element included in 'collectionMoreThan1NoDuplicates' " ^ elementInNonEmpty .! ! !FloatArrayTest methodsFor: 'requirements'! elementInForReplacement " return an element included in 'nonEmpty' " ^ self nonEmpty anyOne.! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 15:50'! elementNotIn "return an element not included in 'nonEmpty' " ^ elementNotIn ! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 16:35'! elementNotInForElementAccessing " return an element not included in 'moreThan4Elements' " ^ elementNotIn ! ! !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 15:45'! elementToAdd " return an element of type 'nonEmpy' elements'type' not yet included in nonEmpty" ^ elementNotIn ! ! !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: 'requirements' stamp: 'delaunay 5/14/2009 10:45'! empty ^ empty ! ! !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: 'requirements' stamp: 'delaunay 5/14/2009 16:26'! firstIndex " return an index between 'nonEmpty' bounds that is < to 'second index' " ^2! ! !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 15:26'! indexInForCollectionWithoutDuplicates " return an index between 'collectionWithoutEqualsElements' bounds" ^ 2.! ! !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:44'! moreThan3Elements " return a collection including atLeast 3 elements" ^ nonEmpty5ElementsNoDuplicate ! ! !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:26'! newElement "return an element that will be put in the collection in place of another" ^ elementNotIn ! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 10:45'! nonEmpty ^ nonEmpty5ElementsNoDuplicate ! ! !FloatArrayTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 14:57'! nonEmpty1Element " return a collection of size 1 including one element" ^ nonEmpty1Element ! ! !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: '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: 'requirements' stamp: 'delaunay 5/14/2009 15:37'! replacementCollection " return a collection that will be used to replace 'oldSubcollection' in ' collectionWith1TimeSubcollection' " ^ collectionWithSameAtEndAndBegining ! ! !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 14:55'! secondCollection " return a collection that will be the second part of the concatenation" ^ collectionWithEqualElements ! ! !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: 'requirements' stamp: 'delaunay 5/14/2009 10:55'! sizeCollection "Answers a collection not empty" ^ nonEmpty5ElementsNoDuplicate ! ! !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: '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: 'requirements' stamp: 'delaunay 5/14/2009 16:37'! unsortedCollection " retur a collection that is not yat sorted" ^nonEmpty5ElementsNoDuplicate ! ! !FloatArrayTest methodsFor: 'requirements'! 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: 'requirements' stamp: 'delaunay 5/14/2009 15:04'! withEqualElements ^ collectionWithEqualElements ! ! !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: 'test - creation'! testOfSize "self debug: #testOfSize" | aCol | aCol := self collectionClass ofSize: 3. self assert: (aCol size = 3). ! ! !FloatArrayTest methodsFor: 'test - creation'! testWith "self debug: #testWith" | aCol anElement | anElement := self collectionMoreThan5Elements anyOne. aCol := self collectionClass with: anElement. self assert: (aCol includes: anElement).! ! !FloatArrayTest methodsFor: 'test - creation'! 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: 'test - creation'! 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: 'test - creation'! 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: 'test - creation'! 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: 'test - creation'! 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: 'test - equality'! testEqualSign "self debug: #testEqualSign" self deny: (self empty = self nonEmpty).! ! !FloatArrayTest methodsFor: 'test - equality'! 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: 'test - equality'! 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: 'test - equality'! testEqualSignOfIdenticalCollectionObjects "self debug: #testEqualSignOfIdenticalCollectionObjects" self assert: (self empty = self empty). self assert: (self nonEmpty = self nonEmpty). ! ! !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: '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 - as identity set'! 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 - as set tests'! testAsSetWithEqualsElements | result | result := self withEqualElements asSet. self withEqualElements do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. self assert: result class = Set! ! !FloatArrayTest methodsFor: 'tests - as sorted collection' stamp: 'hfm 4/2/2010 13:37'! 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: 'tests - as sorted collection'! 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 - as sorted collection'! 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 - at put'! testAtPut "self debug: #testAtPut" self nonEmpty at: self anIndex put: self aValue. self assert: (self nonEmpty at: self anIndex) = self aValue. ! ! !FloatArrayTest methodsFor: 'tests - at put'! testAtPutOutOfBounds "self debug: #testAtPutOutOfBounds" self should: [self empty at: self anIndex put: self aValue] raise: Error ! ! !FloatArrayTest methodsFor: 'tests - at put'! 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 - begins ends with'! 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 - begins ends with'! testsBeginsWithEmpty self deny: (self nonEmpty beginsWith:(self empty)). self deny: (self empty beginsWith:(self nonEmpty )). ! ! !FloatArrayTest methodsFor: 'tests - begins ends with'! 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 - begins ends with'! testsEndsWithEmpty self deny: (self nonEmpty endsWith: self empty). self deny: (self empty endsWith: self nonEmpty). ! ! !FloatArrayTest methodsFor: 'tests - comma and delimiter'! testAsCommaStringEmpty self assert: self empty asCommaString = ''. self assert: self empty asCommaStringAnd = ''. ! ! !FloatArrayTest methodsFor: 'tests - comma and delimiter'! 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 - comma and delimiter'! 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 - comma and delimiter'! testAsStringOnDelimiterEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim. self assert: emptyStream contents = ''. ! ! !FloatArrayTest methodsFor: 'tests - comma and delimiter'! testAsStringOnDelimiterLastEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim last:'and'. self assert: emptyStream contents = ''. ! ! !FloatArrayTest methodsFor: 'tests - comma and delimiter'! 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 - comma and delimiter'! 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 - comma and delimiter'! 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: 'tests - comma and delimiter'! 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 - concatenation'! 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 - concatenation'! 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 - converting'! 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 - converting'! 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 - converting'! assertSameContents: aCollection whenConvertedTo: aClass | result | result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass. self assert: result size = aCollection size! ! !FloatArrayTest methodsFor: 'tests - converting'! testAsArray "self debug: #testAsArray3" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Array! ! !FloatArrayTest methodsFor: 'tests - converting'! testAsBag self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! ! !FloatArrayTest methodsFor: 'tests - converting'! testAsIdentitySet "test with a collection without equal elements :" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: IdentitySet. ! ! !FloatArrayTest methodsFor: 'tests - converting'! testAsOrderedCollection self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! ! !FloatArrayTest methodsFor: 'tests - converting'! testAsSet | | "test with a collection without equal elements :" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Set. ! ! !FloatArrayTest methodsFor: 'tests - copy'! 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 - copy'! 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 - copy'! 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 - copy'! 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 - copy'! 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 - copy'! 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 - copy'! 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: 'tests - copy'! 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 - copy'! 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'! 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 - copy'! 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 - copy - clone'! testCopyCreatesNewObject "self debug: #testCopyCreatesNewObject" | copy | copy := self nonEmpty copy. self deny: self nonEmpty == copy. ! ! !FloatArrayTest methodsFor: 'tests - copy - clone'! testCopyEmpty "self debug: #testCopyEmpty" | copy | copy := self empty copy. self assert: copy isEmpty.! ! !FloatArrayTest methodsFor: 'tests - copy - clone'! 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 - copying part of sequenceable'! 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 - copying part of sequenceable'! testCopyAfterEmpty | result | result := self empty copyAfter: self collectionWithoutEqualElements first. self assert: result isEmpty. ! ! !FloatArrayTest methodsFor: 'tests - copying part of sequenceable'! 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 - copying part of sequenceable'! testCopyAfterLastEmpty | result | result := self empty copyAfterLast: self collectionWithoutEqualElements first. self assert: result isEmpty.! ! !FloatArrayTest methodsFor: 'tests - copying part of sequenceable'! testCopyEmptyMethod | result | result := self collectionWithoutEqualElements copyEmpty . self assert: result isEmpty . self assert: result class= self nonEmpty class.! ! !FloatArrayTest methodsFor: 'tests - copying part of sequenceable'! 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 - copying part of sequenceable'! 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: 'tests - copying part of sequenceable'! testCopyUpToEmpty | result | result := self empty copyUpTo: self collectionWithoutEqualElements first. self assert: result isEmpty. ! ! !FloatArrayTest methodsFor: 'tests - copying part of sequenceable'! 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 - copying part of sequenceable'! testCopyUpToLastEmpty | result | result := self empty copyUpToLast: self collectionWithoutEqualElements first. self assert: result isEmpty.! ! !FloatArrayTest methodsFor: 'tests - copying part of sequenceable for multipliness'! 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: 'tests - copying part of sequenceable for multipliness'! 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 - copying part of sequenceable for multipliness'! 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 - copying part of sequenceable for multipliness'! 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 - copying same contents'! 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: 'tests - copying same contents'! 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 - copying same contents'! 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 - copying same contents'! testShallowCopyEmpty | result | result := self empty shallowCopy . self assert: result isEmpty .! ! !FloatArrayTest methodsFor: 'tests - copying same contents'! 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 - copying with or without'! 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: 'tests - copying with or without'! 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 - copying with or without'! 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 - copying with or without'! 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 - copying with or without'! 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: 'tests - copying with or without'! 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: 'tests - copying with replacement'! firstIndexesOf: subCollection 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: subCollection) ifTrue: [ result add: currentIndex. 1 to: subCollection size do: [:i | tmp := tmp copyWithoutFirst. currentIndex := currentIndex + 1] ] ifFalse: [ tmp := tmp copyWithoutFirst. currentIndex := currentIndex +1. ] ]. ^ result. ! ! !FloatArrayTest methodsFor: 'tests - copying with replacement'! 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 - copying with replacement'! 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 shouldnt: [self collectionWith2TimeSubcollection ]raise: Error. 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 " specific comportement for the begining of the collection :" ifTrue: [ 1 to: ((firstIndexesOfOccurrence at: i) - 1 ) do: [ :j | self assert: (result at: i) = (self collectionWith2TimeSubcollection at: i) ] ] " between parts till the end : " 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)) ] ] ]. "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: 'tests - copying with replacement'! 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 with replacement'! 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 - element accessing'! 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 - element accessing'! 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 - element accessing'! 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: 'tests - element accessing'! 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 - element accessing'! 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: 'tests - element accessing'! 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 - element accessing'! testAtLastError "self debug: #testAtLast" self should: [ self moreThan4Elements atLast: self moreThan4Elements size + 1 ] raise: Error! ! !FloatArrayTest methodsFor: 'tests - element accessing'! 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 - element accessing'! 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: 'tests - element accessing'! 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 - element accessing'! testAtRandom | result | result := self nonEmpty atRandom . self assert: (self nonEmpty includes: result).! ! !FloatArrayTest methodsFor: 'tests - element accessing'! 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 - element accessing'! 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 - element accessing'! 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 - element accessing'! 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: 'tests - element accessing'! testLast "self debug: #testLast" self assert: self moreThan4Elements last = (self moreThan4Elements at: self moreThan4Elements size)! ! !FloatArrayTest methodsFor: 'tests - element accessing'! testMiddle "self debug: #testMiddle" self assert: self moreThan4Elements middle = (self moreThan4Elements at: self moreThan4Elements size // 2 + 1)! ! !FloatArrayTest methodsFor: 'tests - empty'! testIfEmpty self nonEmpty ifEmpty: [ self assert: false] . self empty ifEmpty: [ self assert: true] . ! ! !FloatArrayTest methodsFor: 'tests - empty'! testIfEmptyifNotEmpty self assert: (self empty ifEmpty: [true] ifNotEmpty: [false]). self assert: (self nonEmpty ifEmpty: [false] ifNotEmpty: [true]). ! ! !FloatArrayTest methodsFor: 'tests - empty'! testIfEmptyifNotEmptyDo "self debug #testIfEmptyifNotEmptyDo" self assert: (self empty ifEmpty: [true] ifNotEmptyDo: [:s | false]). self assert: (self nonEmpty ifEmpty: [false] ifNotEmptyDo: [:s | true]). self assert: (self nonEmpty ifEmpty: [false] ifNotEmptyDo: [:s | s]) == self nonEmpty.! ! !FloatArrayTest methodsFor: 'tests - empty'! testIfNotEmpty self empty ifNotEmpty: [self assert: false]. self nonEmpty ifNotEmpty: [self assert: true]. self assert: (self nonEmpty ifNotEmpty: [:s | s ]) = self nonEmpty ! ! !FloatArrayTest methodsFor: 'tests - empty'! testIfNotEmptyDo self empty ifNotEmptyDo: [:s | self assert: false]. self assert: (self nonEmpty ifNotEmptyDo: [:s | s]) == self nonEmpty ! ! !FloatArrayTest methodsFor: 'tests - empty'! testIfNotEmptyDoifNotEmpty self assert: (self empty ifNotEmptyDo: [:s | false] ifEmpty: [true]). self assert: (self nonEmpty ifNotEmptyDo: [:s | s] ifEmpty: [false]) == self nonEmpty! ! !FloatArrayTest methodsFor: 'tests - empty'! testIfNotEmptyifEmpty self assert: (self empty ifNotEmpty: [false] ifEmpty: [true]). self assert: (self nonEmpty ifNotEmpty: [true] ifEmpty: [false]). ! ! !FloatArrayTest methodsFor: 'tests - empty'! testIsEmpty self assert: (self empty isEmpty). self deny: (self nonEmpty isEmpty).! ! !FloatArrayTest methodsFor: 'tests - empty'! testIsEmptyOrNil self assert: (self empty isEmptyOrNil). self deny: (self nonEmpty isEmptyOrNil).! ! !FloatArrayTest methodsFor: 'tests - empty'! testNotEmpty self assert: (self nonEmpty notEmpty). self deny: (self empty notEmpty).! ! !FloatArrayTest methodsFor: 'tests - equality'! 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 - equality'! 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 - equality'! 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 - equality'! testHasEqualElementsOfIdenticalCollectionObjects "self debug: #testHasEqualElementsOfIdenticalCollectionObjects" self assert: (self empty hasEqualElements: self empty). self assert: (self nonEmpty hasEqualElements: self nonEmpty). ! ! !FloatArrayTest methodsFor: 'tests - fixture'! howMany: subCollection in: collection " return an integer representing how many time 'subCollection' appears in 'collection' " | tmp nTime | tmp:= collection. nTime:= 0. [tmp isEmpty ]whileFalse: [ (tmp beginsWith: subCollection) ifTrue: [ nTime := nTime + 1. 1 to: subCollection size do: [:i | tmp := tmp copyWithoutFirst.] ] ifFalse: [tmp := tmp copyWithoutFirst.] ]. ^ nTime. ! ! !FloatArrayTest methodsFor: 'tests - fixture'! test0CopyTest self shouldnt: [ self empty ]raise: Error. self assert: self empty size = 0. self shouldnt: [ self nonEmpty ]raise: Error. self assert: (self nonEmpty size = 0) not. self shouldnt: [ self collectionWithElementsToRemove ]raise: Error. self assert: (self collectionWithElementsToRemove size = 0) not. self collectionWithElementsToRemove do: [:each | self assert: ( self nonEmpty includes: each)]. self shouldnt: [ self elementToAdd ]raise: Error. self deny: (self nonEmpty includes: self elementToAdd ). self shouldnt: [ self collectionNotIncluded ]raise: Error. self collectionNotIncluded do: [ :each | self deny: (self nonEmpty includes: each) ]! ! !FloatArrayTest methodsFor: 'tests - fixture'! test0FixtureAsSetForIdentityMultiplinessTest "a collection (of elements for which copy is not identical ) without equal elements:" | anElement res | self shouldnt: [ self elementsCopyNonIdenticalWithoutEqualElements ]raise: Error. 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: 'tests - fixture'! test0FixtureAsStringCommaAndDelimiterTest self shouldnt: [self nonEmpty] raise:Error . self deny: self nonEmpty isEmpty. self shouldnt: [self empty] raise:Error . self assert: self empty isEmpty. self shouldnt: [self nonEmpty1Element ] raise:Error . self assert: self nonEmpty1Element size=1.! ! !FloatArrayTest methodsFor: 'tests - fixture'! test0FixtureBeginsEndsWithTest self shouldnt: [self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self assert: self nonEmpty size>1. self shouldnt: [self empty ] raise: Error. self assert: self empty isEmpty.! ! !FloatArrayTest methodsFor: 'tests - fixture'! test0FixtureCloneTest self shouldnt: [ self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self empty ] raise: Error. self assert: self empty isEmpty. ! ! !FloatArrayTest methodsFor: 'tests - fixture'! test0FixtureConverAsSortedTest self shouldnt: [self collectionWithSortableElements ] raise: Error. self deny: self collectionWithSortableElements isEmpty .! ! !FloatArrayTest methodsFor: 'tests - fixture'! test0FixtureCopyPartOfForMultipliness self shouldnt: [self collectionWithSameAtEndAndBegining ] raise: Error. 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 - fixture'! test0FixtureCopyPartOfSequenceableTest self shouldnt: [self collectionWithoutEqualElements ] raise: Error. self collectionWithoutEqualElements do: [:each | self assert: (self collectionWithoutEqualElements occurrencesOf: each)=1]. self shouldnt: [self indexInForCollectionWithoutDuplicates ] raise: Error. self assert: self indexInForCollectionWithoutDuplicates >0 & self indexInForCollectionWithoutDuplicates < self collectionWithoutEqualElements size. self shouldnt: [self empty] raise: Error. self assert: self empty isEmpty .! ! !FloatArrayTest methodsFor: 'tests - fixture'! test0FixtureCopySameContentsTest self shouldnt: [self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [self empty ] raise: Error. self assert: self empty isEmpty. ! ! !FloatArrayTest methodsFor: 'tests - fixture'! test0FixtureCopyWithOrWithoutSpecificElementsTest self shouldnt: [self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty . self shouldnt: [self indexInNonEmpty ] raise: Error. self assert: self indexInNonEmpty > 0. self assert: self indexInNonEmpty <= self nonEmpty size.! ! !FloatArrayTest methodsFor: 'tests - fixture'! test0FixtureCopyWithReplacementTest self shouldnt: [self replacementCollection ]raise: Error. self shouldnt: [self oldSubCollection] raise: Error. self shouldnt: [self collectionWith1TimeSubcollection ]raise: Error. self assert: (self howMany: self oldSubCollection in: self collectionWith1TimeSubcollection ) = 1. ! ! !FloatArrayTest methodsFor: 'tests - fixture'! test0FixtureCreationWithTest self shouldnt: [ self collectionMoreThan5Elements ] raise: Error. self assert: self collectionMoreThan5Elements size >= 5.! ! !FloatArrayTest methodsFor: 'tests - fixture'! test0FixtureEmptyTest self shouldnt: [ self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self empty ] raise: Error. self assert: self empty isEmpty.! ! !FloatArrayTest methodsFor: 'tests - fixture'! test0FixtureIncludeTest | anElementIn | self shouldnt: [ self nonEmpty ]raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self elementNotIn ]raise: Error. anElementIn := true. self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self shouldnt: [ self anotherElementNotIn ]raise: Error. anElementIn := true. self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self shouldnt: [ self empty ] raise: Error. self assert: self empty isEmpty. ! ! !FloatArrayTest methodsFor: 'tests - fixture'! test0FixtureIncludeWithIdentityTest | anElement | self shouldnt: [ self collectionWithCopyNonIdentical ]raise: Error. anElement := self collectionWithCopyNonIdentical anyOne. self deny: anElement == anElement copy.! ! !FloatArrayTest methodsFor: 'tests - fixture'! test0FixtureIndexAccessFotMultipliness self shouldnt: [ self collectionWithSameAtEndAndBegining ] raise: Error. 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 - fixture'! test0FixtureIndexAccessTest | res collection element | self shouldnt: [ self collectionMoreThan1NoDuplicates ] raise: Error. 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 shouldnt: [ self elementInForIndexAccessing ] raise: Error. self assert: ( (collection := self collectionMoreThan1NoDuplicates )includes: (element:= self elementInForIndexAccessing)). self shouldnt: [ self elementNotInForIndexAccessing ] raise: Error. self deny: (self collectionMoreThan1NoDuplicates includes: self elementNotInForIndexAccessing)! ! !FloatArrayTest methodsFor: 'tests - fixture'! test0FixtureIterateSequencedReadableTest | res | self shouldnt: self nonEmptyMoreThan1Element raise: Error. self assert: self nonEmptyMoreThan1Element size > 1. self shouldnt: self empty raise: Error. 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: 'tests - fixture'! test0FixturePrintTest self shouldnt: [self nonEmpty ] raise: Error.! ! !FloatArrayTest methodsFor: 'tests - fixture'! test0FixturePutOneOrMoreElementsTest self shouldnt: self aValue raise: Error. self shouldnt: self indexArray raise: Error. 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 shouldnt: self empty raise: Error. self assert: self empty isEmpty . self shouldnt: self nonEmpty raise: Error. self deny: self nonEmpty isEmpty.! ! !FloatArrayTest methodsFor: 'tests - fixture'! test0FixturePutTest self shouldnt: self aValue raise: Error. self shouldnt: self anotherValue raise: Error. self shouldnt: self anIndex raise: Error. self nonEmpty isDictionary ifFalse:[self assert: (self anIndex >=1 & self anIndex <= self nonEmpty size).]. self shouldnt: self empty raise: Error. self assert: self empty isEmpty . self shouldnt: self nonEmpty raise: Error. self deny: self nonEmpty isEmpty.! ! !FloatArrayTest methodsFor: 'tests - fixture'! test0FixtureSequencedConcatenationTest self shouldnt: self empty raise: Exception. self assert: self empty isEmpty. self shouldnt: self firstCollection raise: Exception. self shouldnt: self secondCollection raise: Exception! ! !FloatArrayTest methodsFor: 'tests - fixture'! test0FixtureSequencedElementAccessTest self shouldnt: [ self moreThan4Elements ] raise: Error. self assert: self moreThan4Elements size >= 4. self shouldnt: [ self subCollectionNotIn ] raise: Error. self subCollectionNotIn detect: [ :each | (self moreThan4Elements includes: each) not ] ifNone: [ self assert: false ]. self shouldnt: [ self elementNotInForElementAccessing ] raise: Error. self deny: (self moreThan4Elements includes: self elementNotInForElementAccessing). self shouldnt: [ self elementInForElementAccessing ] raise: Error. self assert: (self moreThan4Elements includes: self elementInForElementAccessing)! ! !FloatArrayTest methodsFor: 'tests - fixture'! test0FixtureSetAritmeticTest self shouldnt: [ self collection ] raise: Error. self deny: self collection isEmpty. self shouldnt: [ self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self anotherElementOrAssociationNotIn ] raise: Error. self collection isDictionary ifTrue: [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ] ifFalse: [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ]. self shouldnt: [ self collectionClass ] raise: Error! ! !FloatArrayTest methodsFor: 'tests - fixture'! test0FixtureSubcollectionAccessTest self shouldnt: [ self moreThan3Elements ] raise: Error. self assert: self moreThan3Elements size > 2! ! !FloatArrayTest methodsFor: 'tests - fixture'! test0FixtureTConvertAsSetForMultiplinessTest "a collection with equal elements:" | res | self shouldnt: [ self withEqualElements] raise: Error. res := true. self withEqualElements detect: [ :each | (self withEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = true. ! ! !FloatArrayTest methodsFor: 'tests - fixture'! test0FixtureTConvertTest "a collection of number without equal elements:" | res | self shouldnt: [ self collectionWithoutEqualElements ]raise: Error. res := true. self collectionWithoutEqualElements detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false. ! ! !FloatArrayTest methodsFor: 'tests - fixture'! test0SortingArrayedTest | tmp sorted | " an unsorted collection of number " self shouldnt: [ self unsortedCollection ]raise: Error. 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 shouldnt: [ self sortedInAscendingOrderCollection ]raise: Error. self sortedInAscendingOrderCollection do:[:each | each isNumber]. tmp:= self sortedInAscendingOrderCollection at:1. self sortedInAscendingOrderCollection do: [: each | self assert: (each>= tmp). tmp:=each] ! ! !FloatArrayTest methodsFor: 'tests - fixture'! test0TSequencedStructuralEqualityTest self shouldnt: [self nonEmpty at: 1] raise: Error. "Ensures #nonEmpty is sequenceable"! ! !FloatArrayTest methodsFor: 'tests - fixture'! test0TStructuralEqualityTest self shouldnt: [self empty] raise: Error. self shouldnt: [self nonEmpty] raise: Error. self assert: self empty isEmpty. self deny: self nonEmpty isEmpty.! ! !FloatArrayTest methodsFor: 'tests - fixture'! testOFixtureReplacementSequencedTest self shouldnt: self nonEmpty raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: self elementInForReplacement raise: Error. self assert: (self nonEmpty includes: self elementInForReplacement ) . self shouldnt: self newElement raise: Error. self shouldnt: self firstIndex raise: Error. self assert: (self firstIndex >= 1 & self firstIndex <= self nonEmpty size). self shouldnt: self secondIndex raise: Error. self assert: (self secondIndex >= 1 & self secondIndex <= self nonEmpty size). self assert: self firstIndex <=self secondIndex . self shouldnt: self replacementCollection raise: Error. self shouldnt: self replacementCollectionSameSize raise: Error. self assert: (self secondIndex - self firstIndex +1)= self replacementCollectionSameSize size ! ! !FloatArrayTest methodsFor: 'tests - includes'! testIncludesAllNoneThere "self debug: #testIncludesAllOfNoneThere'" self deny: (self empty includesAll: self nonEmpty ). self deny: (self nonEmpty includesAll: { self elementNotIn. self anotherElementNotIn })! ! !FloatArrayTest methodsFor: 'tests - includes'! 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: 'tests - includes'! testIncludesAnyNoneThere "self debug: #testIncludesAnyOfNoneThere'" self deny: (self nonEmpty includesAny: self empty). self deny: (self nonEmpty includesAny: { self elementNotIn. self anotherElementNotIn })! ! !FloatArrayTest methodsFor: 'tests - includes'! 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: 'tests - includes'! testIncludesElementIsThere "self debug: #testIncludesElementIsThere" self assert: (self nonEmpty includes: self nonEmpty anyOne).! ! !FloatArrayTest methodsFor: 'tests - including with identity'! 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 - index access'! 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: 'tests - index access'! 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 - index access'! 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: 'tests - index access'! 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 - index access'! 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: 'tests - index access'! 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 - index access'! 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 - index access'! 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'! 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 - index accessing for multipliness'! 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 - index accessing for multipliness'! 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 - index accessing for multipliness'! 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 - index accessing for multipliness'! 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 - index accessing for multipliness'! 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 - index accessing for multipliness'! 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 - iterate on sequenced reable collections'! 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: 'tests - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! testDo! ! !FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testFindFirst | element result | element := self nonEmptyMoreThan1Element at:1. result:=self nonEmptyMoreThan1Element findFirst: [:each | each =element]. self assert: result=1. ! ! !FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! testFindFirstNotIn | result | result:=self empty findFirst: [:each | true]. self assert: result=0. ! ! !FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! testFindLastNotIn | result | result:=self empty findFirst: [:each | true]. self assert: result=0. ! ! !FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! testKeysAndValuesDoEmpty | result | result:= OrderedCollection new. self empty keysAndValuesDo: [:i :value| result add: (value+i)]. self assert: result isEmpty .! ! !FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! 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: 'tests - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! testReverseDoEmpty | result | result:= OrderedCollection new. self empty reverseDo: [: each | result add: each]. self assert: result isEmpty .! ! !FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! testWithCollectError self should: [self nonEmptyMoreThan1Element with: self empty collect:[:a :b | ]] raise: Error.! ! !FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 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: 'tests - iterate on sequenced reable collections'! testWithDoError self should: [self nonEmptyMoreThan1Element with: self empty do:[:a :b | ]] raise: Error.! ! !FloatArrayTest methodsFor: 'tests - iterate on sequenced reable collections'! 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: 'tests - iterate on sequenced reable collections'! 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 - printing'! 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 - printing'! 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 - printing'! 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 - printing'! 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 - printing'! 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 - printing'! 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 - puting with indexes'! testAtAllIndexesPut self nonEmpty atAllPut: self aValue. self nonEmpty do:[ :each| self assert: each = self aValue]. ! ! !FloatArrayTest methodsFor: 'tests - puting with indexes'! testAtAllPut | | self nonEmpty atAll: self indexArray put: self aValue.. self indexArray do: [:i | self assert: (self nonEmpty at: i)=self aValue ]. ! ! !FloatArrayTest methodsFor: 'tests - puting with indexes'! 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 - puting with indexes'! 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: 'tests - puting with indexes'! 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: 'tests - puting with indexes'! 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 - puting with indexes' stamp: 'GuillermoPolito 5/24/2010 14:31'! 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 - replacing'! 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 - replacing'! 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: 'tests - replacing'! 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 - set arithmetic'! 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 - set arithmetic'! numberOfSimilarElementsInIntersection ^ self collection occurrencesOf: self anotherElementOrAssociationIn! ! !FloatArrayTest methodsFor: 'tests - set arithmetic'! 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 - set arithmetic'! 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 - set arithmetic'! 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 = 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 = separateCol! ! !FloatArrayTest methodsFor: 'tests - set arithmetic'! 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: 'tests - set arithmetic'! 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 - set arithmetic'! 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 - set arithmetic'! 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: 'tests - set arithmetic'! 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 - set arithmetic'! testUnionOfEmpties "self debug: #testUnionOfEmpties" self assert: (self empty union: self empty) isEmpty. ! ! !FloatArrayTest methodsFor: 'tests - sorting'! testIsSorted self assert: self sortedInAscendingOrderCollection isSorted. self deny: self unsortedCollection isSorted! ! !FloatArrayTest methodsFor: 'tests - sorting'! testIsSortedBy self assert: (self sortedInAscendingOrderCollection isSortedBy: [:a :b | ab]). ! ! !FloatArrayTest methodsFor: 'tests - sorting'! testSort | result tmp | result := self unsortedCollection sort. tmp := result at: 1. result do: [:each | self assert: each>=tmp. tmp:= each. ].! ! !FloatArrayTest methodsFor: 'tests - sorting'! 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 - sorting'! testSorted | result tmp | result := self unsortedCollection sorted. tmp := result at: 1. result do: [:each | self assert: each>=tmp. tmp:= each. ].! ! !FloatArrayTest methodsFor: 'tests - sorting'! 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: 'tests - subcollections access'! 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 - subcollections access'! 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 - subcollections access'! 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 - subcollections access'! 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 - subcollections access'! 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: 'tests - subcollections access'! 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 class uses: TCreationWithTest classTrait + TSequencedStructuralEqualityTest classTrait + TSequencedConcatenationTest classTrait + TSetArithmetic classTrait + TAsStringCommaAndDelimiterSequenceableTest classTrait + TPrintOnSequencedTest classTrait + TEmptyTest classTrait + TBeginsEndsWith classTrait + TCloneTest classTrait + TConvertTest classTrait + TConvertAsSortedTest classTrait + TConvertAsSetForMultiplinessIdentityTest classTrait + TCopyPartOfSequenceable classTrait + TCopyPartOfSequenceableForMultipliness classTrait + TCopySequenceableSameContents classTrait + TCopySequenceableWithOrWithoutSpecificElements classTrait + TCopySequenceableWithReplacement classTrait + TCopyTest classTrait + TIncludesWithIdentityCheckTest classTrait + TIndexAccess classTrait + TIndexAccessForMultipliness classTrait + TIterateSequencedReadableTest classTrait + TPutTest classTrait + TPutBasicTest classTrait + TReplacementSequencedTest classTrait + TSequencedElementAccessTest classTrait + TSortTest classTrait + TSubCollectionAccess classTrait instanceVariableNames: ''! Inspector subclass: #FloatInspector instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tools-Inspector'! !FloatInspector commentStamp: '' prior: 0! I am FloatInspector. I am an Inspector. 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)! !FloatInspector methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 11/26/2012 15:50'! elements "Return the list of elements or aspects about Floats that we want to show. Note that each of these should name a Float method." ^ #( sign significand exponent )! ! !FloatInspector methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 11/26/2012 14:32'! fieldList "Answer the super field list plus our custom elements." ^ super fieldList , self elements! ! !FloatInspector methodsFor: 'selecting' stamp: 'SvenVanCaekenberghe 11/26/2012 15:50'! numberOfFixedFields "Overridden to take into account the two word indexable fields of Float" ^ super numberOfFixedFields + 2! ! !FloatInspector methodsFor: 'selecting' stamp: 'SvenVanCaekenberghe 11/26/2012 15:48'! replaceSelectionValue: anObject "The receiver has a list of variables of its inspected object. One of these is selected. The value of the selected variable is set to the value, anObject." selectionIndex <= self numberOfFixedFields ifTrue: [ ^ super replaceSelectionValue: anObject ] "My own fields are readonly"! ! !FloatInspector methodsFor: 'selecting' stamp: 'SvenVanCaekenberghe 11/26/2012 14:23'! selection "The receiver has a list of variables of its inspected object. One of these is selected. Answer the value of the selected variable." ^ self selectionIndex <= self numberOfFixedFields ifTrue: [ super selection ] ifFalse: [ object perform: (self elements at: self selectionIndex - self numberOfFixedFields) ]! ! DynamicVariable subclass: #FloatPrintPolicy instanceVariableNames: 'default' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Numbers'! !FloatPrintPolicy commentStamp: '' prior: 0! 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: 'accessing' stamp: 'SvenVanCaekenberghe 2/8/2013 11:20'! default ^ default! ! !FloatPrintPolicy methodsFor: 'initialize-release' stamp: 'SvenVanCaekenberghe 2/8/2013 11:20'! initialize default := ExactFloatPrintPolicy new! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FloatPrintPolicy class instanceVariableNames: ''! !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! ! ClassTestCase subclass: #FloatTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Numbers'! !FloatTest commentStamp: 'fbs 3/8/2004 22:13' prior: 0! 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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: 'as yet unclassified' 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: '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: '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: '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: '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: '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: '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: 'printing' stamp: 'nice 3/27/2011 19:04'! testPrintPaddedWithTo "This bug was reported in http://lists.gforge.inria.fr/pipermail/pharo-users/2011-February/001569.html. 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: '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: '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: 'test - 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: 'test - 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: 'test - mathematical functions' stamp: 'nice 10/31/2010 21:50'! testDegreeCos self shouldnt: [ 45.0 degreeCos] raise: Error. "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: 'test - 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: 'test - mathematical functions' stamp: 'nice 10/31/2010 21:51'! testDegreeSin self shouldnt: [ 45.0 degreeSin] raise: Error. "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: 'test - 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: 'test - 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: 'testing' 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: 'testing' stamp: 'jb 7/1/2011 10:52'! 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 evaluatorClass evaluate: Float halfPi storeString) = Float halfPi. self assert: (self class evaluatorClass evaluate: Float halfPi negated storeString) = Float halfPi negated. self assert: (self class evaluatorClass evaluate: Float infinity storeString) = Float infinity. self assert: (self class evaluatorClass evaluate: Float infinity negated storeString) = Float infinity negated. self assert: (self class evaluatorClass evaluate: Float nan storeString) isNaN.! ! !FloatTest methodsFor: 'testing - 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: 'testing - 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: 'testing - 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: 'testing - 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: 'testing - 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: 'testing - 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: 'testing - 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: 'testing - 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: 'testing - 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: 'testing - 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: 'testing - 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: 'testing - 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: 'testing - 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: 'testing - 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: 'testing - 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: 'testing 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: 'testing 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: 'testing 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: 'testing 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' stamp: 'nice 6/11/2009 01:36'! testHash self assert: (2 = 2.0) ==> (2 hash = 2.0 hash). self assert: (1/2 = 0.5) ==> ((1/2) hash = 0.5 hash). self shouldnt: [Float nan hash] raise: Error. self shouldnt: [Float infinity hash] raise: Error.! ! !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 - mathematical functions' stamp: 'jmv 10/13/2011 09:06'! testRaisedTo " FloatTest new testRaisedTo " self should: [ -1.23 raisedTo: 1/4 ] raise: ArithmeticError! ! !FloatTest methodsFor: 'zero behavior' stamp: 'md 4/16/2003 15:02'! testIsZero self assert: 0.0 isZero. self deny: 0.1 isZero.! ! !FloatTest methodsFor: '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: 'zero behavior' stamp: 'nice 8/21/2010 22:30'! testNegativeZeroSign self assert: Float negativeZero sign = -1! ! !FloatTest methodsFor: '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: '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! ! ArithmeticError subclass: #FloatingPointException instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Exceptions'! !FloatingPointException commentStamp: 'SvenVanCaekenberghe 4/21/2011 12:39' prior: 0! 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.! Model subclass: #FontChooser instanceVariableNames: 'title selectedFontIndex fontList fontListStrings target getSelector setSelector pointSize fontStyleList selectedFontStyleIndex weightValue slantValue stretchValue pointSizeList' classVariableNames: '' poolDictionaries: '' category: 'FreeType-UI'! !FontChooser commentStamp: 'StephaneDucasse 1/1/2010 18:00' prior: 0! I'm an object holding information to choose a font from a list of fonts.! !FontChooser methodsFor: 'accessing' stamp: 'AlainPlantec 1/7/2010 22:05'! categoryList ^OrderedCollection new addAll: (TextStyle actualTextStyles keysSortedSafely); yourself.! ! !FontChooser methodsFor: 'accessing' stamp: 'HenrikSperreJohansen 12/8/2009 23:41'! fontList ^fontList ifNil:[self refreshFontList]. ! ! !FontChooser methodsFor: 'accessing' stamp: 'HenrikSperreJohansen 12/8/2009 23:51'! fontListStrings (fontListStrings isNil or: [fontList size ~= fontListStrings size]) ifTrue: [ fontListStrings := self fontList collect:[:each | each familyName]]. ^fontListStrings! ! !FontChooser methodsFor: 'accessing' stamp: 'tween 8/19/2007 16:22'! fontStyleList | family | family := self selectedFontFamily. family ifNotNil:[^fontStyleList := family members asSortedCollection]. ^#()! ! !FontChooser methodsFor: 'accessing' stamp: 'tween 8/17/2007 00:15'! fontStyleListStrings "names of simulated styles are enclosed in parenthesis" ^self fontStyleList collect: [:fontFamilyMember | | s | s := fontFamilyMember styleName. fontFamilyMember simulated ifTrue:[s := '(', s, ')']. s]! ! !FontChooser methodsFor: 'accessing' stamp: 'tween 8/4/2007 13:44'! getSelector "Answer the value of getSelector" ^ getSelector! ! !FontChooser methodsFor: 'accessing' stamp: 'tween 8/4/2007 20:16'! getSelector: aSelectorSymbolOrFont "Set the value of getSelector" getSelector := aSelectorSymbolOrFont! ! !FontChooser methodsFor: 'accessing' stamp: 'tween 8/4/2007 15:23'! pointSize ^pointSize ifNil: [pointSize := 10.0]! ! !FontChooser methodsFor: 'accessing' stamp: 'tween 8/4/2007 17:34'! pointSize: aNumber pointSize := aNumber. self changed: #pointSize! ! !FontChooser methodsFor: 'accessing' stamp: 'CamilloBruni 5/26/2012 13:09'! pointSizeList ^pointSizeList ifNil:[ pointSizeList := (1 to: 256) collect: [:each | each asString padLeftTo: 3 ]]! ! !FontChooser methodsFor: 'accessing' stamp: 'tween 8/4/2007 13:44'! setSelector: anObject "Set the value of setSelector" setSelector := anObject! ! !FontChooser methodsFor: 'accessing' stamp: 'tween 8/4/2007 13:44'! target "Answer the value of target" ^ target! ! !FontChooser methodsFor: 'accessing' stamp: 'tween 8/4/2007 13:44'! target: anObject "Set the value of target" target := anObject! ! !FontChooser methodsFor: 'accessing' stamp: 'tween 8/4/2007 13:44'! title: anObject "Set the value of title" title := anObject! ! !FontChooser methodsFor: 'accessing' stamp: 'tween 8/4/2007 10:27'! windowTitle ^ title translated! ! !FontChooser methodsFor: 'action' stamp: 'BenjaminVanRyseghem 12/20/2012 13:38'! apply | font | target ifNotNil:[ setSelector ifNotNil:[ font := self selectedFont. font ifNotNil:[ target perform: setSelector with: font]]].! ! !FontChooser methodsFor: 'action' stamp: 'HenrikSperreJohansen 12/8/2009 23:41'! refreshFontList ^fontList := LogicalFontManager current allFamilies! ! !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 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: 'action' stamp: 'HenrikSperreJohansen 12/9/2009 00:08'! updateFontList FreeTypeFontProvider current updateFromSystem. self refreshFontList! ! !FontChooser methodsFor: 'initialize-release' stamp: 'tween 8/4/2007 10:27'! initialize super initialize. title := 'Choose A Font'.! ! !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: 'selected' stamp: 'tween 8/16/2007 22:42'! selectedFontFamily | | ^self fontList at: self selectedFontIndex ifAbsent:[nil]. ! ! !FontChooser methodsFor: 'selected' stamp: 'tween 8/28/2007 00:20'! 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: 'selected' stamp: 'tween 8/28/2007 00:11'! 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 changed: #selectedFontIndex. self changed: #selectedFontStyleIndex.! ! !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 12:07'! selectedFontStyleIndex: anIndex | familyMember | anIndex = 0 ifTrue: [^self]. selectedFontStyleIndex := anIndex. familyMember := self fontStyleList at: anIndex. self setStyleValuesFrom: familyMember. self changed: #selectedFontStyleIndex! ! !FontChooser methodsFor: 'selected' stamp: 'tween 8/27/2007 23:12'! selectedPointSize ^self selectedFont pointSize! ! !FontChooser methodsFor: 'selected' stamp: 'CamilloBruni 5/26/2012 13:10'! selectedPointSizeIndex ^self pointSizeList indexOf: (pointSize reduce asString padLeftTo: 3)! ! !FontChooser methodsFor: 'selected' stamp: 'SvenVanCaekenberghe 1/8/2012 14:44'! selectedPointSizeIndex: anIndex anIndex = 0 ifTrue: [^self]. pointSize := (self pointSizeList at: anIndex) trimBoth asNumber. self changed: #pointSize! ! !FontChooser methodsFor: 'selected' stamp: 'CamilloBruni 5/26/2012 13:10'! 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 changed: #pointSizeList]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FontChooser class instanceVariableNames: ''! !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! ! !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 ! ! StandardWindow subclass: #FontChooserMorph instanceVariableNames: 'mainPanel fontPreviewPanel okButton cancelButton applyButton updateButton result pointSizeMorph fontListStylePanel styleList pointSizeList' classVariableNames: '' poolDictionaries: '' category: 'FreeType-UI'! !FontChooserMorph commentStamp: 'StephaneDucasse 1/1/2010 18:02' prior: 0! I'm the UI of a font chooser. ! !FontChooserMorph methodsFor: 'accessing' stamp: 'GaryChambers 6/20/2011 13:28'! 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: 'accessing' stamp: 'GaryChambers 6/20/2011 13:29'! 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: 'accessing' stamp: 'GaryChambers 6/20/2011 13:20'! fontPreviewPanel ^fontPreviewPanel ifNil: [ fontPreviewPanel := self newScrollPaneFor: self newFontPreviewInnerPanel ]! ! !FontChooserMorph methodsFor: 'accessing' stamp: 'MarcusDenker 1/24/2010 11:09'! newFontList | answer fon max | answer := PluggableListMorph on: self model list: #fontListStrings selected: #selectedFontIndex changeSelected: #selectedFontIndex:. fon := answer font. max := 20. model fontList do:[:each | max := max max: (fon widthOfStringOrText: each familyName)]. answer color: Color white; borderInset; vResizing: #spaceFill; hResizing: #spaceFill; "hResizing: #rigid;" width: max + answer scrollBarThickness + (fon widthOfStringOrText: ' '). self when: #fontsUpdated send: #verifyContents to: answer. ^answer! ! !FontChooserMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 1/1/2010 18:05'! newFontPointSizeField | answer | answer := (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. ^answer! ! !FontChooserMorph methodsFor: 'accessing' stamp: 'tween 8/27/2007 13:14'! newFontPointSizeLabel ^StringMorph contents: 'Point size:' translated.! ! !FontChooserMorph methodsFor: 'accessing' stamp: 'MarcusDenker 1/24/2010 11:06'! newFontStyleList | answer fon max | answer := PluggableListMorph on: self model list: #fontStyleListStrings selected: #selectedFontStyleIndex changeSelected: #selectedFontStyleIndex:. fon := answer font. max := fon widthOfStringOrText: 'Condensed Extra Bold Oblique' "long, but not the longest". model fontStyleList do:[:fontFamilyMember | max := max max: (fon widthOfStringOrText: fontFamilyMember styleName)]. answer color: Color white; borderInset; vResizing: #spaceFill; hResizing: #spaceFill; "hResizing: #rigid;" width: max + answer scrollBarThickness + (fon widthOfStringOrText: ' '). ^answer! ! !FontChooserMorph methodsFor: 'accessing' stamp: 'MarcusDenker 1/24/2010 11:06'! newPointSizeList | answer | answer := PluggableListMorph on: self model list: #pointSizeList selected: #selectedPointSizeIndex changeSelected: #selectedPointSizeIndex:. answer color: Color white; borderInset; vResizing: #spaceFill; hResizing: #spaceFill. ^answer! ! !FontChooserMorph methodsFor: 'accessing' stamp: 'GaryChambers 6/20/2011 13:29'! okButton ^okButton ifNil: [ okButton := (self newButtonFor: self action: #okButtonClicked label: 'OK' translated help: 'Click here to close this dialog, and accept your selection' translated) hResizing: #spaceFill]! ! !FontChooserMorph methodsFor: 'accessing' stamp: 'tween 8/4/2007 17:33'! pointSizeString ^model pointSize asString! ! !FontChooserMorph methodsFor: 'accessing' stamp: 'GaryChambers 6/20/2011 13:59'! previewText "Answer the preview text based on current font." | sample i c f | f := model selectedFont. f isNil ifTrue: [ ^'' ]. sample := String new writeStream. f isSymbolFont ifFalse: [ sample nextPutAll: 'the quick brown fox jumps over the lazy dog' ;cr; nextPutAll: 'THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG.'; cr ]. i := 0. 33 to: 255 do: [:ci | sample nextPut: (c:=Character value: ci). i := i + 1. (('@Z`z' includes:c) or: [ i = 30 ]) ifTrue: [ i :=0. sample cr ] ]. ^sample contents! ! !FontChooserMorph methodsFor: 'accessing' stamp: 'tween 8/4/2007 20:28'! result ^result! ! !FontChooserMorph methodsFor: 'accessing' stamp: 'GaryChambers 6/20/2011 13:29'! updateButton ^updateButton ifNil: [ updateButton := (self newButtonFor: self action: #updateButtonClicked label: 'Update' translated help: 'Click here to rescan Font Folder and update the font list' translated) hResizing: #spaceFill]! ! !FontChooserMorph methodsFor: 'actions' stamp: 'tween 8/4/2007 20:28'! apply result := model selectedFont. model apply! ! !FontChooserMorph methodsFor: 'actions' stamp: 'tween 8/4/2007 13:49'! applyButtonClicked self apply. ! ! !FontChooserMorph methodsFor: 'actions' stamp: 'tween 8/4/2007 20:27'! cancelButtonClicked result :=nil. self delete ! ! !FontChooserMorph methodsFor: 'actions' stamp: 'tween 8/4/2007 20:25'! delete model := nil. super delete ! ! !FontChooserMorph methodsFor: 'actions' stamp: 'tween 8/4/2007 13:37'! okButtonClicked self apply. self delete ! ! !FontChooserMorph methodsFor: 'actions' stamp: 'tween 8/4/2007 22:47'! pointSizeSlider: aNumber (aNumber < 1 or:[ aNumber > 1024]) ifTrue:[^self]. pointSizeMorph ifNotNil:[ pointSizeMorph setText: aNumber asString asText; hasUnacceptedEdits: false]. model pointSize: aNumber! ! !FontChooserMorph methodsFor: 'actions' stamp: 'SvenVanCaekenberghe 1/8/2012 14:44'! pointSizeString: aText | s n| s := aText asString trimBoth. s isEmpty ifTrue:[^self]. (s detect:[:c | c isDigit not and:[c ~= $.]] ifNone:[]) ifNotNil:[^self]. [n := s asNumber asFloat] on: Error do:[:e | ^self]. (n < 1 or:[ n > 1024]) ifTrue:[^self]. pointSizeMorph ifNotNil:[pointSizeMorph hasUnacceptedEdits: false]. model pointSize: n! ! !FontChooserMorph methodsFor: 'actions' stamp: 'tween 8/28/2007 00:02'! update: aSymbol super update: aSymbol. aSymbol == #selectedFontIndex ifTrue: [ styleList ifNotNil:[styleList updateList]. pointSizeList ifNotNil:[pointSizeList updateList]. self updatePreview]. aSymbol == #selectedFontStyleIndex ifTrue: [ self updatePreview]. aSymbol == #pointSize ifTrue: [ pointSizeList ifNotNil:[pointSizeList selectionIndex: model selectedPointSizeIndex]. self updatePreview]. aSymbol == #pointSizeList ifTrue: [ pointSizeList ifNotNil:[pointSizeList updateList]. self updatePreview].! ! !FontChooserMorph methodsFor: 'actions' stamp: 'RobRothwell 12/15/2008 23:01'! updateButtonClicked self updateFontList. ! ! !FontChooserMorph methodsFor: 'actions' stamp: 'HenrikSperreJohansen 12/9/2009 00:01'! updateFontList model updateFontList. self triggerEvent: #fontsUpdated.! ! !FontChooserMorph methodsFor: 'actions' stamp: 'GaryChambers 6/20/2011 13:20'! updatePreview Cursor wait showWhile: [ self fontPreviewPanel scrollTarget: self newFontPreviewInnerPanel ]! ! !FontChooserMorph methodsFor: 'initialize-release' stamp: 'GaryChambers 6/20/2011 13:49'! initializeLabelArea super initializeLabelArea. self removeCollapseBox; removeExpandBox; removeMenuBox! ! !FontChooserMorph methodsFor: 'initialize-release' stamp: 'tween 8/27/2007 23:29'! initializeWithModel: aFontChooser self model: aFontChooser; clipSubmorphs: true; setLabel: self model windowTitle; name: 'FontChooser'. self updatePreview! ! !FontChooserMorph methodsFor: 'interface building' stamp: 'IgorStasenko 12/20/2012 14:55'! createWindow "Create the package loader window." | buttonBar buttonBarOffset | buttonBar := self newRow: { self applyButton. self okButton. self cancelButton. self updateButton}. buttonBar cellInset: 8@0. buttonBarOffset := buttonBar minExtent y negated - (2 * ProportionalSplitterMorph splitterWidth). self addMorph: (self newFontList borderWidth: 0) frame: (0.0 @ 0.0 corner: 0.5 @ 0.4). self addMorph: ((styleList := self newFontStyleList) borderWidth: 0) frame: (0.5 @ 0.0 corner: 0.9 @ 0.4). self addMorph: (pointSizeList := self newPointSizeList borderWidth:0) frame: (0.9 @ 0.0 corner: 1.0 @ 0.4). self addMorph: self fontPreviewPanel fullFrame: ((0 @ 0.4 corner: 1 @1) asLayoutFrame bottomOffset: buttonBarOffset). self addMorph: buttonBar fullFrame: ((0 @1 corner: 1@1) asLayoutFrame topOffset: buttonBarOffset)! ! !FontChooserMorph methodsFor: 'interface building' stamp: 'GaryChambers 6/20/2011 14:01'! newFontPreviewInnerPanel "Answer a morph for the preview text." |textMorph| textMorph := (self newText: self previewText) margins: 4. ^self model selectedFont ifNil: [ textMorph ] ifNotNil: [:f | textMorph beAllFont: f ]! ! !FontChooserMorph methodsFor: 'interface building' stamp: 'tween 8/27/2007 13:13'! newFontSizePanel ^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 newFontEmphasisBoldButton; addMorphBack: self newFontEmphasisItalicButton;" addMorphBack: self newFontPointSizeLabel; addMorphBack: (pointSizeMorph := self newFontPointSizeField) ! ! !FontChooserMorph methodsFor: 'interface building' stamp: 'MarcusDenker 11/13/2012 15:11'! open ^self createWindow openAsIsIn: self currentWorld! ! !FontChooserMorph methodsFor: 'interface building' stamp: 'pavel.krivanek 3/4/2009 10:42'! pangrams ^ 'the quick brown fox jumps over the lazy dog THE QUICK BROWN FOX JUMPS OVER THE LAZY DOG. Bulgarian [ all letters ] –ü–æ–¥ —é–∂–Ω–æ –¥—ä—Ä–≤–æ, —Ü—ä—Ñ—Ç—è—â–æ –≤ —Å–∏–Ω—å–æ, –±—è–≥–∞—à–µ –º–∞–ª–∫–æ –ø—É—Ö–∫–∞–≤–æ –∑–∞–π—á–µ. Czech [ all characters with diacritics ] P≈ô√≠li≈° ≈ælu≈•ouƒçk√Ω k≈Ø≈à √∫pƒõl ƒè√°belsk√© √≥dy. P≈ò√çLI≈† ≈ΩLU≈§OUƒåK√ù K≈Æ≈á √öPƒöL ƒé√ÅBELSK√â √ìDY. Chinese [ practically impossible ] ˶ñÈáéÁÑ°ÈôꪣԺåÁ™ó§ñÊúâËó秩 ÂæÆÈ¢®ËøéÂÆ¢Ôºå˪üË™û‰º¥Ëå∂ Danish [ all letters ] Quizdeltagerne spiste jordb√¶r med fl√∏de, mens cirkusklovnen Walther spillede p√• xylofon. Dutch [ all letters (and not including accents) ] Pa''s wijze lynx bezag vroom het fikse aquaduct. Esperanto [ all characters specific to Esperanto ] Eƒ•o≈ùanƒùo ƒâiuƒµa≈≠de. Estonian [ not all letters ] See v√§ike m√∂lder j√µuab rongile h√ºpata Finnish [ not all letters ] Viekas kettu punaturkki laiskan koiran takaa kurkki. French [ all letters, including diacritics exceptcircumflex¬†and¬†cedilla ] Voix ambigu√´ d''un c≈ìur qui au z√©phyr pr√©f√®re les jattes de kiwis. French [ all letters, but no diacritics ] Portez ce vieux whisky au juge blond qui fume. German [ all letters (including umlauts and √ü) ] Zw√∂lf Boxk√§mpfer jagen Viktor quer √ºber den gro√üen Sylter Deich Greek [ not all letters ] ŒòŒ≠ŒªŒµŒπ Œ±œÅŒµœÑŒÆ Œ∫Œ±Œπ œÑœåŒªŒºŒ∑ Œ∑ ŒµŒªŒµœÖŒ∏ŒµœÅŒØŒ±. (ŒëŒΩŒ¥œÅŒ≠Œ±œÇ ŒöŒ¨ŒªŒ≤ŒøœÇ) Hebrew [ all letters, but with no distinction between regular and final forms. ] ◊ì◊í ◊°◊ß◊®◊ü ◊©◊ò ◊ú◊ï ◊ë◊ô◊ù ◊ñ◊ö ◊ê◊ö ◊ú◊§◊™◊¢ ◊§◊í◊© ◊ó◊ë◊ï◊®◊î ◊†◊ó◊û◊ì◊î ◊©◊¶◊¶◊î ◊õ◊ö. Hungarian [ without digraphs, which are considered letters of their own ] Egy h≈±tlen vej√©t f√ºl√∂ncs√≠p≈ë, d√ºh√∂s mexik√≥i √∫r Wessel√©nyin√©l m√°zol Quit√≥ban. Italian [ all letters (without foreign characters j,k,w,x,y) ] Ma la volpe, col suo balzo, ha raggiunto il quieto Fido. Japanese [ all non-voiced hiragana except „Çì ] „ÅÑ„Çç„ÅØ„Å´„Ū„Å∏„Å® „Å°„Çä„Ũ„Çã„Çí „Çè„Åã„Çà„Åü„Çå„Åù „ŧ„Å≠„Å™„Çâ„ÇÄ „ÅÜ„Çê„ÅÆ„Åä„Åè„ÇÑ„Åæ „Åë„ŵ„Åì„Åà„Ŷ „ÅÇ„Åï„Åç„ÇÜ„ÇÅ„Åø„Åó „Çë„Å≤„ÇÇ„Åõ„Åô Korean [ uses all consonants but not all vowels ] Îã§ÎûåÏ•ê Ìóå Ï≥áÎ∞îÌÄ¥Ïóê ÌÉÄÍ≥†Ìåå Latvian [ not all letters ] SarkanƒÅs j≈´rasc≈´ci≈Üas peld pa j≈´ru. Norwegian (bokm√•l) [ not all letters ] En god stil m√• f√∏rst og fremst v√¶re klar. Den m√• v√¶re passende. Aristoteles. Portuguese [ not all letters ] A r√°pida raposa castanha salta por cima do c√£o lento. Brazilian Portuguese [ not all letters ] A ligeira raposa marrom ataca o c√£o pregui√ßoso. Brazilian Portuguese [ all letters ] Zebras caolhas de Java querem passar fax para mo√ßas gigantes de New York Polish [ all letters ] PchnƒÖƒá w tƒô ≈Ç√≥d≈∫ je≈ºa lub o≈õm skrzy≈Ñ fig Romanian [ not all letters ] Agera vulpe maronie sare peste c√¢inele cel lene≈ü. Russian [ all letters ] –°—ä–µ—à—å –µ—â—ë —ç—Ç–∏—Ö –º—è–≥–∫–∏—Ö —Ñ—Ä–∞–Ω—Ü—É–∑—Å–∫–∏—Ö –±—É–ª–æ–∫ –¥–∞ –≤—ã–ø–µ–π –∂–µ —á–∞—é Serbian (Cyrillic alphabet) [ all letters ] –ß–µ—à—õ–µ —Üe—í–µ—ö–µ –º—Äe–∂–∞—Å—Ç–∏–º —ü–∞–∫–æ–º –ø–æ–±–æ—ô—à–∞–≤–∞ —Ñ–µ—Ä—Ç–∏–ª–∏–∑–∞—Ü–∏—ò—É –≥–µ–Ω—Å–∫–∏—Ö —Ö–∏–±—Ä–∏–¥–∞. Serbian (Latin alphabet) [ all letters ] ƒåe≈°ƒáe ceƒëenje mre≈æastim d≈æakom pobolj≈°ava fertilizaciju genskih hibrida. Slovak [ all letters ] K≈ïdeƒæ ≈°≈•astn√Ωch ƒèatƒæov uƒç√≠ pri √∫st√≠ V√°hu mƒ∫kveho ko≈àa obhr√Ωza≈• k√¥ru a ≈æra≈• ƒçerstv√© m√§so. Slovene [ all letters ] V ko≈æu≈°ƒçku hudobnega fanta stopiclja mizar in kliƒçe 0619872345. Spanish [ all letters ] 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. Swedish [ except Q, X and Z ] Flygande b√§ckasiner s√∂ka hwila p√• mjuka tuvor Thai [ except ‡∏¶ ] ‡πć∏õ‡πá‡∏ô‡∏°‡∏ô‡∏∏‡∏©‡∏¢‡πå‡∏™‡∏∏‡∏î‡∏õ‡∏£‡∏∞‡πć∏™‡∏£‡∏¥‡∏ê‡πć∏•‡∏¥‡∏®‡∏ч∏∏‡∏ì‡∏чπà‡∏≤ ‡∏Ň∏߇πà‡∏≤‡∏ö‡∏£‡∏£‡∏î‡∏≤‡∏ù‡∏π‡∏á‡∏™‡∏±‡∏ï‡∏߇πå‡πć∏î‡∏£‡∏±‡∏à‡∏â‡∏≤‡∏ô ‡∏à‡∏á‡∏ù‡πà‡∏≤‡∏ü‡∏±‡∏ô‡∏û‡∏±‡∏í‡∏ô‡∏≤‡∏߇∏¥‡∏ä‡∏≤‡∏Ň∏≤‡∏£ ‡∏≠‡∏¢‡πà‡∏≤‡∏•‡πâ‡∏≤‡∏á‡∏ú‡∏•‡∏≤‡∏ç‡∏§‡πÖ‡πć∏LJπà‡∏ô‡∏܇πà‡∏≤‡∏ö‡∏µ‡∏ë‡∏≤‡πɇ∏ч∏£ ‡πч∏°‡πà‡∏ñ‡∏∑‡∏≠‡πLJ∏ó‡∏©‡πLJ∏Ň∏£‡∏ò‡πŇ∏ä‡πà‡∏á‡∏ã‡∏±‡∏î‡∏Ƈ∏∂‡∏î‡∏Ƈ∏±‡∏î‡∏î‡πà‡∏≤ ‡∏´‡∏±‡∏î‡∏≠‡∏†‡∏±‡∏¢‡πć∏´‡∏°‡∏∑‡∏≠‡∏ô‡∏Ň∏µ‡∏¨‡∏≤‡∏≠‡∏±‡∏ä‡∏å‡∏≤‡∏™‡∏±‡∏¢ ‡∏õ‡∏è‡∏¥‡∏ö‡∏±‡∏ï‡∏¥‡∏õ‡∏£‡∏∞‡∏û‡∏§‡∏ï‡∏¥‡∏Ň∏é‡∏Ň∏≥‡∏´‡∏ô‡∏î‡πɇ∏à ‡∏û‡∏π‡∏î‡∏à‡∏≤‡πɇ∏´‡πâ‡∏à‡πä‡∏∞ ‡πÜ ‡∏à‡πã‡∏≤ ‡πÜ ‡∏ô‡πà‡∏≤‡∏ü‡∏±‡∏á‡πć∏≠‡∏¢‡∏Ø Turkish [ all letters ] Pijamalƒ± hasta, yaƒüƒ±z ≈üof√∂re √ßabucak g√ºvendi' ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FontChooserMorph class instanceVariableNames: ''! !FontChooserMorph class methodsFor: 'instance creation' stamp: 'tween 8/4/2007 10:24'! withModel: aFontChooser ^self new initializeWithModel: aFontChooser; yourself.! ! Object subclass: #FontFamilyAbstract instanceVariableNames: 'familyName members' classVariableNames: '' poolDictionaries: '' category: 'FreeType-FontManager'! !FontFamilyAbstract methodsFor: 'accessing' stamp: 'tween 8/18/2007 13:46'! familyName "Answer the value of familyName" ^ familyName! ! !FontFamilyAbstract methodsFor: 'accessing' stamp: 'tween 8/18/2007 13:46'! familyName: anObject "Set the value of familyName" familyName := anObject! ! !FontFamilyAbstract methodsFor: 'accessing' stamp: 'tween 8/18/2007 13:47'! members "Answer the value of members" ^ members! ! !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. ! ! !FontFamilyAbstract methodsFor: 'printing' stamp: 'tween 9/7/2007 19:36'! printOn: aStream aStream nextPutAll: self class name asString; nextPut: $ ; nextPutAll: self familyName printString! ! Object subclass: #FontFamilyMemberAbstract instanceVariableNames: 'family styleName' classVariableNames: '' poolDictionaries: '' category: 'FreeType-FontManager'! !FontFamilyMemberAbstract methodsFor: 'accessing' stamp: 'tween 8/25/2007 14:22'! family ^family! ! !FontFamilyMemberAbstract methodsFor: 'accessing' stamp: 'tween 8/25/2007 14:22'! family: aFontFamily family := aFontFamily! ! !FontFamilyMemberAbstract methodsFor: 'accessing' stamp: 'tween 9/8/2007 13:24'! slantValue self subclassResponsibility! ! !FontFamilyMemberAbstract methodsFor: 'accessing' stamp: 'tween 9/8/2007 13:24'! stretchValue self subclassResponsibility! ! !FontFamilyMemberAbstract methodsFor: 'accessing' stamp: 'tween 8/18/2007 13:41'! styleName "Answer the value of styleName" ^ styleName! ! !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: 'comparing' stamp: 'tween 8/18/2007 13:42'! closenessVector ^self closenessVectorForStretch: self stretchValue slant: self slantValue weight: self weightValue! ! !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: '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 ! ! !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! ! Object subclass: #FontProviderAbstract instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FreeType-FontManager'! !FontProviderAbstract commentStamp: 'tween 3/14/2007 22:59' prior: 0! 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! ! Object subclass: #FontSet instanceVariableNames: '' classVariableNames: '' poolDictionaries: 'TextConstants' category: 'Graphics-Fonts'! !FontSet commentStamp: '' prior: 0! 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 instanceVariableNames: ''! !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: '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: '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: '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: '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: '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: '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: '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: '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: 'private' stamp: 'sma 12/29/1999 12:58'! fontCategory ^ 'Graphics-Fonts' asSymbol! ! !FontSet class methodsFor: 'private' stamp: 'RAA 6/20/2000 13:29'! fontName self flag: #bob. "temporary hack until I figure out what's happening here" (self name beginsWith: superclass name) ifFalse: [^self name]. ^ (self name copyFrom: superclass name size + 1 to: self name size) asSymbol! ! !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! ! Notification subclass: #FontSubstitutionDuringLoading instanceVariableNames: 'familyName pixelSize' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Fonts'! !FontSubstitutionDuringLoading commentStamp: '' prior: 0! signaled by font loading code when reading a DiskProxy that calls for a missing font.! !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 "Answer the value of familyName" ^ familyName! ! !FontSubstitutionDuringLoading methodsFor: 'accessing' stamp: 'nk 11/8/2004 15:01'! familyName: anObject "Set the value of familyName" familyName := anObject! ! !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: 'nk 11/8/2004 16:55'! printOn: aStream super printOn: aStream. aStream nextPut: $(; nextPutAll: familyName; nextPut: $-; print: pixelSize; nextPut: $).! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FontSubstitutionDuringLoading class instanceVariableNames: ''! !FontSubstitutionDuringLoading class methodsFor: 'instance creation' stamp: 'nk 11/8/2004 15:07'! forFamilyName: aName pixelSize: aSize ^(self new) familyName: aName; pixelSize: aSize; yourself.! ! TestCase subclass: #FontTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Multilingual'! !FontTest commentStamp: 'tak 3/11/2005 14:31' prior: 0! I am mainly a test for fallback font. FontTest buildSuite run! !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: 'testing' 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"! ! !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)! ! SharedPool subclass: #FooSharedPool instanceVariableNames: '' classVariableNames: 'FooValue1' poolDictionaries: '' category: 'Tests-System'! !FooSharedPool commentStamp: 'NicoPaez 10/17/2010 14:44' prior: 0! Just a class for testing.! DisplayMedium subclass: #Form instanceVariableNames: 'bits width height depth offset' classVariableNames: 'FloodFillTolerance' poolDictionaries: '' category: 'Graphics-Display Objects'! !Form commentStamp: 'ls 1/4/2004 17:16' prior: 0! 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: '*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: '*Graphics-Files' stamp: 'ar 6/16/2002 17:53'! writeBMPfileNamed: fName "Display writeBMPfileNamed: 'display.bmp'" BMPReadWriter putForm: self onFileNamed: fName! ! !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: '*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: '*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: '*Morphic' stamp: 'ar 11/7/1999 20:29'! asMorph ^ImageMorph new image: self! ! !Form methodsFor: '*Morphic' stamp: 'PavelKrivanek 11/18/2012 20:37'! defaultCanvasClass "Return the default canvas used for drawing onto the receiver" ^ FormCanvas! ! !Form methodsFor: '*Morphic' stamp: 'AlainPlantec 12/10/2009 11:07'! floodFillTolerance ^ self class floodFillTolerance! ! !Form methodsFor: '*Morphic' 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: '*Morphic' stamp: 'ar 7/8/2006 21:01'! iconOrThumbnailOfSize: aNumberOrPoint "Answer an appropiate form to represent the receiver" ^ self scaledIntoFormOfSize: aNumberOrPoint! ! !Form methodsFor: '*Morphic' 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: '*Morphic-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: '*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: '*Polymorph-Widgets-Themes' stamp: 'AlainPlantec 5/13/2011 09:15'! setAsBackground "Set this form as a background image." | world | world := self currentWorld. world backgroundMorph: ((UITheme current builder newAlphaImage: self help: nil) autoSize: false; layout: #scaled; lock) ! ! !Form methodsFor: 'accessing'! bits "Answer the receiver's Bitmap containing its bits." ^ bits! ! !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: 'accessing'! bits: aBitmap "Reset the Bitmap containing the receiver's bits." bits := aBitmap! ! !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: 'accessing' stamp: 'ar 5/17/2001 15:45'! depth ^ depth < 0 ifTrue:[0-depth] ifFalse:[depth]! ! !Form methodsFor: 'accessing' stamp: 'StephaneDucasse 10/20/2011 15:45'! depth: bitsPerPixel (bitsPerPixel > 32 or: [(bitsPerPixel bitAnd: bitsPerPixel-1) ~= 0]) ifTrue: [Halt halt: 'bitsPerPixel must be 1, 2, 4, 8, 16 or 32']. depth := bitsPerPixel! ! !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: 'accessing'! extent ^ width @ height! ! !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: '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: '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: 'accessing'! height ^ height! ! !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: 'accessing' stamp: 'ar 2/16/2000 22:00'! offset ^offset ifNil:[0@0]! ! !Form methodsFor: 'accessing'! offset: aPoint offset := aPoint! ! !Form methodsFor: 'accessing'! size "Should no longer be used -- use bitsSize instead. length of variable part of instance." ^ super size! ! !Form methodsFor: 'accessing'! width ^ width! ! !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: '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: 'analyzing'! 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: 'analyzing' stamp: 'ar 5/17/2001 15:40'! 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 current 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 current 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: 'analyzing' stamp: 'ar 5/17/2001 15:42'! primCountBits "Count the non-zero pixels of this form." self depth > 8 ifTrue: [^(self asFormOfDepth: 8) primCountBits]. ^ (BitBlt current toForm: self) fillColor: (Bitmap with: 0); destRect: (0@0 extent: width@height); combinationRule: 32; copyBits! ! !Form methodsFor: 'analyzing' stamp: 'ar 5/17/2001 15:37'! 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 current toForm: slice) sourceForm: self; combinationRule: Form over; destX: 0 destY: 0 width: width height: 1; colorMap: cm. countBlt := (BitBlt current 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: '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: 'analyzing' stamp: 'ar 5/28/2000 12:09'! 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 current 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: 'analyzing' stamp: 'ar 5/28/2000 12:09'! 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 current 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 current 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: 'analyzing' stamp: 'ar 5/28/2000 12:09'! 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 current 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 current 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: 'bordering' stamp: 'ar 5/17/2001 15:42'! borderFormOfWidth: borderWidth sharpCorners: sharpen "Smear this form around and then subtract the original to produce an outline. If sharpen is true, then cause right angles to be outlined by right angles (takes an additional diagonal smears ANDed with both horizontal and vertical smears)." | smearForm bigForm smearPort all cornerForm cornerPort nbrs | self depth > 1 ifTrue: [self halt]. "Only meaningful for B/W forms." bigForm := self deepCopy. all := bigForm boundingBox. smearForm := Form extent: self extent. smearPort := BitBlt current toForm: smearForm. sharpen ifTrue: [cornerForm := Form extent: self extent. cornerPort := BitBlt current toForm: cornerForm]. nbrs := (0@0) fourNeighbors. 1 to: borderWidth do: [:i | "Iterate to get several layers of 'skin'" nbrs do: [:d | "Smear the self in 4 directions to grow each layer of skin" smearPort copyForm: bigForm to: d rule: Form under]. sharpen ifTrue: ["Special treatment to smear sharp corners" nbrs with: ((2 to: 5) collect: [:i2 | nbrs atWrap: i2]) do: [:d1 :d2 | "Copy corner points diagonally" cornerPort copyForm: bigForm to: d1+d2 rule: Form over. "But only preserve if there were dots on either side" cornerPort copyForm: bigForm to: d1+d1+d2 rule: Form and. cornerPort copyForm: bigForm to: d1+d2+d2 rule: Form and. smearPort copyForm: cornerForm to: 0@0 rule: Form under]. ]. bigForm copy: all from: 0@0 in: smearForm rule: Form over. ]. "Now erase the original shape to obtain the outline" bigForm copy: all from: 0@0 in: self rule: Form erase. ^ bigForm! ! !Form methodsFor: 'bordering'! 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: 'bordering'! 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: 'bordering'! 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: 'bordering' stamp: 'ar 5/28/2000 12:07'! 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 current 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: 'bordering' stamp: 'di 10/21/2001 09:39'! shapeBorder: aColor width: borderWidth "A simplified version for shapes surrounded by transparency (as SketchMorphs). Note also this returns a new form that may be larger, and does not affect the original." | shapeForm borderForm newForm | newForm := Form extent: self extent + (borderWidth*2) depth: self depth. newForm fillColor: Color transparent. self displayOn: newForm at: (0@0) + borderWidth. "First identify the shape in question as a B/W form" shapeForm := (newForm makeBWForm: Color transparent) reverse. "Now find the border of that shape" borderForm := shapeForm borderFormOfWidth: borderWidth sharpCorners: false. "Finally use that shape as a mask to paint the border with color" ^ newForm fillShape: borderForm fillColor: aColor! ! !Form methodsFor: 'bordering'! shapeBorder: aColor width: borderWidth interiorPoint: interiorPoint sharpCorners: sharpen internal: internal "Identify the shape (region of identical color) at interiorPoint, and then add an outline of width=borderWidth and color=aColor. If sharpen is true, then cause right angles to be outlined by right angles. If internal is true, then produce a border that lies within the identified shape. Thus one can put an internal border around the whole background, thus effecting a normal border around every other foreground image." | shapeForm borderForm interiorColor | "First identify the shape in question as a B/W form" interiorColor := self colorAt: interiorPoint. shapeForm := (self makeBWForm: interiorColor) reverse findShapeAroundSeedBlock: [:form | form pixelValueAt: interiorPoint put: 1]. "Reverse the image to grow the outline inward" internal ifTrue: [shapeForm reverse]. "Now find the border fo that shape" borderForm := shapeForm borderFormOfWidth: borderWidth sharpCorners: sharpen. "Finally use that shape as a mask to paint the border with color" self fillShape: borderForm fillColor: aColor! ! !Form methodsFor: 'color mapping' stamp: 'ar 5/15/2001 16:16'! balancedPatternFor: aColor "Return the pixel word for representing the given color on the receiver" self hasNonStandardPalette ifTrue:[^self bitPatternFor: aColor] ifFalse:[^aColor balancedPatternForDepth: self depth]! ! !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: '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: '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: '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: '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: 'color mapping'! 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: 'color mapping' stamp: 'ar 5/17/2001 15:40'! 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 current toForm: self) sourceForm: self; sourceOrigin: 0@0; combinationRule: Form over; destX: 0 destY: 0 width: width height: height; colorMap: map; copyBits. ! ! !Form methodsFor: 'color mapping' stamp: 'ar 5/17/2001 15:38'! 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 current toForm: self) sourceForm: self; sourceOrigin: 0@0; combinationRule: Form over; destX: 0 destY: 0 width: width height: height; colorMap: map; copyBits. ! ! !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: '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: '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: '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: '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: '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: '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: 'converting' stamp: 'MarcusDenker 4/10/2011 10:14'! asCursorForm ^ Form newFrom: self! ! !Form methodsFor: 'converting' stamp: 'ar 4/30/2008 12:20'! asFormOfDepth: d | newForm | d = self depth ifTrue:[^self]. newForm := Form extent: self extent depth: d. (BitBlt current 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: 'converting' stamp: 'ar 5/17/2001 15:39'! 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 current 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 current 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: 'converting' stamp: 'ar 2/7/2004 18:16'! asSourceForm ^self! ! !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: '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: 'converting' stamp: 'marcus.denker 9/14/2008 21:16'! 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 isNil ifTrue: [c := Color colorFromPixelValue: i - 1 depth: tallyDepth] ifFalse: [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: '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: 'converting' stamp: 'StephaneDucasse 3/27/2010 21:30'! darker "Answer a darker variant of this form." ^ self darker: 0.16! ! !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: '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: '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: 'converting' stamp: 'StephaneDucasse 3/27/2010 21:38'! lighter "Answer a lighter variant of this form" ^ self lighter: 0.16! ! !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: '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: 'copying' stamp: 'RAA 9/28/1999 11:20'! blankCopyOf: aRectangle scaledBy: scale ^ self class extent: (aRectangle extent * scale) truncated depth: depth! ! !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: '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: 'copying' stamp: 'ar 5/28/2000 12:08'! copyBits: sourceForm at: destOrigin translucent: factor "Make up a BitBlt table and copy the bits with the given colorMap." (BitBlt current 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: 'ar 5/28/2000 12:08'! copyBits: sourceRect from: sourceForm at: destOrigin clippingBox: clipRect rule: rule fillColor: aForm "Make up a BitBlt table and copy the bits." (BitBlt current destForm: self sourceForm: sourceForm fillColor: aForm combinationRule: rule destOrigin: destOrigin sourceOrigin: sourceRect origin extent: sourceRect extent clipRect: clipRect) copyBits! ! !Form methodsFor: 'copying' stamp: 'ar 5/28/2000 12:08'! 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 current destForm: self sourceForm: sourceForm fillColor: aForm combinationRule: rule destOrigin: destOrigin sourceOrigin: sourceRect origin extent: sourceRect extent clipRect: clipRect) colorMap: map) copyBits! ! !Form methodsFor: 'copying' stamp: 'ar 5/28/2000 12:08'! copyBits: sourceRect from: sourceForm at: destOrigin colorMap: map "Make up a BitBlt table and copy the bits with the given colorMap." ((BitBlt current 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: 'copying'! 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: 'copying' stamp: 'ar 5/28/2000 12:08'! copy: destRectangle from: sourcePt in: sourceForm rule: rule "Make up a BitBlt table and copy the bits." (BitBlt current toForm: self) copy: destRectangle from: sourcePt in: sourceForm fillColor: nil rule: rule! ! !Form methodsFor: 'copying'! copy: sourceRectangle from: sourceForm to: destPt rule: rule ^ self copy: (destPt extent: sourceRectangle extent) from: sourceRectangle topLeft in: sourceForm rule: rule! ! !Form methodsFor: 'copying' stamp: 'jm 2/27/98 09:35'! deepCopy ^ self shallowCopy bits: bits copy; offset: offset copy ! ! !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: 'display box access'! boundingBox ^ Rectangle origin: 0 @ 0 corner: width @ height! ! !Form methodsFor: 'display box access'! computeBoundingBox ^ Rectangle origin: 0 @ 0 corner: width @ height! ! !Form methodsFor: 'displaying'! displayOnPort: port at: location port copyForm: self to: location rule: Form over! ! !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: 'displaying' stamp: 'Pavelkrivanek 10/23/2010 18:32'! displayResourceFormOn: aForm "a special display method for blowing up resource thumbnails" | engine tx cmap blitter | 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: '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: 'displaying' stamp: 'ar 5/28/2000 12:08'! 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 current 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: 'displaying' stamp: 'ar 5/28/2000 12:08'! paintBits: sourceForm at: destOrigin translucent: factor "Make up a BitBlt table and copy the bits with the given colorMap." (BitBlt current 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: '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: 'filein/out' 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: '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: '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: '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: '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: '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: '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: 'filein/out'! store32To24HexBitsOn:aStream ^self storeBits:20 to:0 on:aStream.! ! !Form methodsFor: 'filein/out'! storeBits:startBit to:stopBit on:aStream bits storeBits:startBit to:stopBit on:aStream.! ! !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: 'filein/out'! storeHexBitsOn:aStream ^self storeBits:28 to:0 on:aStream.! ! !Form methodsFor: 'filein/out'! storeOn: aStream self storeOn: aStream base: 10! ! !Form methodsFor: 'filein/out'! 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: '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: '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: 'filein/out' stamp: 'mu 8/17/2003 00:35'! writeBitsOn: file bits writeOn: file! ! !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: '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: '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: '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: '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: 'filling' stamp: 'di 10/17/2001 10:09'! eraseShape: bwForm "use bwForm as a mask to clear all pixels where bwForm has 1's" ((BitBlt current 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: 'filling'! 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: 'filling' stamp: 'ar 5/17/2001 15:38'! 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 current 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'! 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: 'filling' stamp: 'ar 5/28/2000 12:08'! 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 current toForm: self) copy: aRectangle from: 0@0 in: nil fillColor: aForm rule: anInteger! ! !Form methodsFor: 'filling' stamp: 'nice 3/5/2010 22:32'! 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 depth > 1 ifTrue: [self halt]. "Only meaningful for B/W forms." all := self boundingBox. smearForm := Form extent: self extent. smearPort := BitBlt current 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: 'filling' stamp: 'ar 5/14/2001 23:46'! floodFill2: aColor at: interiorPoint "Fill the shape (4-connected) at interiorPoint. The algorithm is based on Paul Heckbert's 'A Seed Fill Algorithm', Graphic Gems I, Academic Press, 1990. NOTE: This is a less optimized variant for flood filling which is precisely along the lines of Heckbert's algorithm. For almost all cases #floodFill:at: will be faster (see the comment there) but this method is left in both as reference and as a fallback if such a strange case is encountered in reality." | peeker poker stack old new x y top x1 x2 dy left goRight | peeker := BitBlt current bitPeekerFromForm: self. poker := BitBlt current bitPokerToForm: self. stack := OrderedCollection new: 50. "read old pixel value" old := peeker pixelAt: interiorPoint. "compute new value" new := self pixelValueFor: aColor. old = new ifTrue:[^self]. "no point, is there?!!" x := interiorPoint x. y := interiorPoint y. (y >= 0 and:[y < height]) ifTrue:[ stack addLast: {y. x. x. 1}. "y, left, right, dy" stack addLast: {y+1. x. x. -1}]. [stack isEmpty] whileFalse:[ top := stack removeLast. y := top at: 1. x1 := top at: 2. x2 := top at: 3. dy := top at: 4. y := y + dy. "Segment of scanline (y-dy) for x1 <= x <= x2 was previously filled. Now explore adjacent pixels in scanline y." x := x1. [x >= 0 and:[(peeker pixelAt: x@y) = old]] whileTrue:[ poker pixelAt: x@y put: new. x := x - 1]. goRight := x < x1. left := x+1. (left < x1 and:[y-dy >= 0 and:[y-dy < height]]) ifTrue:[stack addLast: {y. left. x1-1. 0-dy}]. goRight ifTrue:[x := x1 + 1]. [ goRight ifTrue:[ [x < width and:[(peeker pixelAt: x@y) = old]] whileTrue:[ poker pixelAt: x@y put: new. x := x + 1]. (y+dy >= 0 and:[y+dy < height]) ifTrue:[stack addLast: {y. left. x-1. dy}]. (x > (x2+1) and:[y-dy >= 0 and:[y-dy >= 0]]) ifTrue:[stack addLast: {y. x2+1. x-1. 0-dy}]]. [(x := x + 1) <= x2 and:[(peeker pixelAt: x@y) ~= old]] whileTrue. left := x. goRight := true. x <= x2] whileTrue. ]. ! ! !Form methodsFor: 'filling' stamp: 'di 10/20/2001 10:09'! floodFillMapFrom: sourceForm to: scanlineForm mappingColorsWithin: dist to: centerPixVal "This is a helper routine for floodFill. It's written for clarity (scanning the entire map using colors) rather than speed (which would require hacking rgb components in the nieghborhood of centerPixVal. Note that some day a better proximity metric would be (h s v) where tolerance could be reduced in hue." | colorMap centerColor | scanlineForm depth = 32 ifFalse: [self error: 'depth 32 assumed']. "First get a modifiable identity map" colorMap := (Color cachedColormapFrom: sourceForm depth to: scanlineForm depth) copy. centerColor := Color colorFromPixelValue: (centerPixVal bitOr: 16rFFe6) depth: scanlineForm depth. "Now replace all entries that are close to the centerColor" 1 to: colorMap size do: [:i | ((Color colorFromPixelValue: ((colorMap at: i) bitOr: 16rFFe6) depth: scanlineForm depth) diff: centerColor) <= dist ifTrue: [colorMap at: i put: centerPixVal]]. ^ colorMap! ! !Form methodsFor: 'filling' stamp: 'di 10/17/2001 10:10'! shapeFill: aColor interiorPoint: interiorPoint "Identify the shape (region of identical color) at interiorPoint, and then fill that shape with the new color, aColor : modified di's original method such that it returns the bwForm, for potential use by the caller" | bwForm interiorPixVal map ppd color ind | self depth = 1 ifTrue: [^ self shapeFill: aColor seedBlock: [:form | form pixelValueAt: interiorPoint put: 1]]. "First map this form into a B/W form with 0's in the interior region." "bwForm := self makeBWForm: interiorColor." "won't work for two whites" interiorPixVal := self pixelValueAt: interiorPoint. bwForm := Form extent: self extent. map := Bitmap new: (1 bitShift: (self depth min: 12)). "Not calling newColorMap. All non-foreground go to 0. Length is 2 to 4096." ppd := self depth. "256 long color map in depth 8 is not one of the following cases" 3 to: 5 do: [:bitsPerColor | (2 raisedTo: bitsPerColor*3) = map size ifTrue: [ppd := bitsPerColor*3]]. "ready for longer maps than 512" ppd <= 8 ifTrue: [map at: interiorPixVal+1 put: 1] ifFalse: [interiorPixVal = 0 ifFalse: [color := Color colorFromPixelValue: interiorPixVal depth: self depth. ind := color pixelValueForDepth: ppd. map at: ind+1 put: 1] ifTrue: [map at: 1 put: 1]]. bwForm copyBits: self boundingBox from: self at: 0@0 colorMap: map. bwForm reverse. "Make interior region be 0's" "Now fill the interior region and return that shape" bwForm := bwForm findShapeAroundSeedBlock: [:form | form pixelValueAt: interiorPoint put: 1]. "Finally use that shape as a mask to flood the region with color" self eraseShape: bwForm. self fillShape: bwForm fillColor: aColor. ^ bwForm! ! !Form methodsFor: 'filling' stamp: 'ar 5/17/2001 15:38'! shapeFill: aColor seedBlock: seedBlock self depth > 1 ifTrue: [self error: 'This call only meaningful for B/W forms']. (self findShapeAroundSeedBlock: seedBlock) displayOn: self at: 0@0 clippingBox: self boundingBox rule: Form under fillColor: aColor ! ! !Form methodsFor: 'image manipulation' stamp: 'ar 5/17/2001 15:40'! 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 current 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: 'image manipulation' stamp: 'ar 5/28/2000 12:09'! smear: dir distance: dist "Smear any black pixels in this form in the direction dir in Log N steps" | skew bb | bb := BitBlt current 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: '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: '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: '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: '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: 'initialization'! 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: 'initialization' stamp: 'ar 5/28/2000 18:45'! shutDown "The system is going down. Try to preserve some space" self hibernate! ! !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: '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: '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: '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: '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: '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: 'other' stamp: 'RAA 1/30/2002 16:42'! relativeTextAnchorPosition ^nil "so forms can be in TextAnchors"! ! !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: '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: '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: 'pixel access' stamp: 'ar 5/28/2000 12:08'! 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 current bitPeekerFromForm: self) pixelAt: aPoint ! ! !Form methodsFor: 'pixel access' stamp: 'ar 5/28/2000 12:08'! pixelValueAt: aPoint put: pixelValue "Store the given raw pixel value at the given point. Typical clients use colorAt:put: to store a color. " (BitBlt current bitPokerToForm: self) pixelAt: aPoint put: pixelValue. ! ! !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: 'resources' stamp: 'ar 2/27/2001 14:56'! resourceTag ^'FORM'! ! !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: '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: '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: 'scaling, rotation' stamp: 'tpr 9/28/2004 17:00'! magnifyBy: scale "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." ^ self magnify: self boundingBox by: scale smoothing: (scale < 1 ifTrue: [2] ifFalse: [1])! ! !Form methodsFor: 'scaling, rotation'! 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: 'scaling, rotation'! 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: '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: '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: '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: '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: 'scaling, rotation'! shrink: aRectangle by: scale | scalePt | scalePt := scale asPoint. ^ self magnify: aRectangle by: (1.0 / scalePt x asFloat) @ (1.0 / scalePt y asFloat)! ! !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: '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: '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: '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: 'testing' stamp: 'ar 5/28/2000 15:04'! isDisplayScreen ^false! ! !Form methodsFor: 'testing' stamp: 'ar 5/27/2000 16:54'! isExternalForm ^false! ! !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: 'testing' stamp: 'ar 10/30/2000 23:23'! isForm ^true! ! !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: 'testing' stamp: 'RAA 8/14/2000 10:00'! isStatic ^false! ! !Form methodsFor: 'testing' stamp: 'ar 2/10/2004 17:18'! isTranslucent "Answer whether this form may be translucent" ^self depth = 32! ! !Form methodsFor: 'testing' stamp: 'JuanVuletich 10/12/2010 12:44'! mightBeTranslucent "Answer whether this form may be translucent" ^self depth = 32! ! !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: '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: '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: 'transitions'! 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: 'transitions'! 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: '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: '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: 'transitions' stamp: 'Jb 11/19/2010 15:43'! 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 pix returnPix| 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: '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: '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: '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: '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: '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: '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: '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: '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: '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: 'private'! 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: '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: '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: '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: '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 class instanceVariableNames: ''! !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' 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: '*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: '*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: '*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: '*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: '*Graphics-Files-FileRegistry' stamp: 'MarcusDenker 3/23/2011 18:28'! services ^ Array with: self serviceOpenImageInWindow with: self serviceImageAsBackground ! ! !Form class methodsFor: '*Graphics-Files-FileRegistry' stamp: 'GabrielOmarCotelli 6/4/2009 20:42'! setBackgroundFromImageFileNamed: aFileName (self fromFileNamed: aFileName) setAsBackground! ! !Form class methodsFor: '*Morphic' stamp: 'AlainPlantec 12/10/2009 11:00'! floodFillTolerance ^ FloodFillTolerance ifNil: [FloodFillTolerance := 0.0]! ! !Form class methodsFor: 'initialization' stamp: 'GabrielOmarCotelli 6/4/2009 20:34'! unload FileServices unregisterFileReader: self ! ! !Form class methodsFor: 'initialize-release' stamp: 'GabrielOmarCotelli 6/4/2009 20:34'! initialize FileServices registerFileReader: self! ! !Form class methodsFor: 'instance creation' stamp: 'ar 5/28/2000 12:07'! 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 current 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: '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: '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: '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: '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: '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: '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: '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: 'instance creation'! 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'! 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: '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: '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: '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: 'mode constants'! and "Answer the integer denoting the logical 'and' combination rule." ^1! ! !Form class methodsFor: 'mode constants'! blend "Answer the integer denoting BitBlt's alpha blend combination rule." ^24! ! !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: 'mode constants'! erase "Answer the integer denoting mode erase." ^4! ! !Form class methodsFor: 'mode constants'! erase1bitShape "Answer the integer denoting mode erase." ^ 26! ! !Form class methodsFor: 'mode constants'! oldErase1bitShape "Answer the integer denoting mode erase." ^ 17! ! !Form class methodsFor: 'mode constants'! oldPaint "Answer the integer denoting the 'paint' combination rule." ^16! ! !Form class methodsFor: 'mode constants'! over "Answer the integer denoting mode over." ^3! ! !Form class methodsFor: 'mode constants'! paint "Answer the integer denoting the 'paint' combination rule." ^25! ! !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! ! !Form class methodsFor: 'mode constants'! reverse "Answer the integer denoting mode reverse." ^6! ! !Form class methodsFor: 'mode constants'! under "Answer the integer denoting mode under." ^7! ! !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: '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].! ! Canvas subclass: #FormCanvas instanceVariableNames: 'origin clipRect form port' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Support'! !FormCanvas commentStamp: '' prior: 0! 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-Balloon' stamp: 'ar 11/11/1998 22:57'! asBalloonCanvas ^(BalloonCanvas on: form) setOrigin: origin clipRect: clipRect! ! !FormCanvas methodsFor: '*Morphic-Balloon' stamp: 'gvc 3/16/2009 13:36'! balloonFillRectangle: aRectangle fillStyle: aFillStyle self asBalloonCanvas fillRectangle: aRectangle basicFillStyle: aFillStyle! ! !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: 'accessing' stamp: 'ar 6/22/1999 14:06'! clipRect "Return the currently active clipping rectangle" ^ clipRect translateBy: origin negated! ! !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'! depth ^ form depth ! ! !FormCanvas methodsFor: 'accessing'! extent ^ form extent! ! !FormCanvas methodsFor: 'accessing'! form ^ form! ! !FormCanvas methodsFor: 'accessing' stamp: 'ar 6/22/1999 14:10'! origin "Return the current origin for drawing operations" ^ origin! ! !FormCanvas methodsFor: 'as yet unclassified' stamp: 'BenjaminVanRyseghem 5/3/2012 16:47'! encryptedParagraph: para bounds: bounds color: c | scanner | self setPaintColor: c. scanner := (port clippedBy: (bounds translateBy: origin)) encryptedDisplayScannerFor: para foreground: c background: Color transparent ignoreColorChanges: false. para displayOn: (self copyClipRect: bounds) using: scanner at: origin+ bounds topLeft. ! ! !FormCanvas methodsFor: 'copying' stamp: 'ar 6/17/1999 02:51'! copyClipRect: aRectangle ^ self copyOrigin: origin clipRect: (aRectangle translateBy: origin) ! ! !FormCanvas methodsFor: 'copying' stamp: 'ar 6/17/1999 02:52'! copyOffset: aPoint ^ self copyOrigin: origin + aPoint clipRect: clipRect! ! !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: '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: '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: '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: '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: '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' 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-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-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: '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: '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: '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: '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: '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-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-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: '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: '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-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: '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-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: '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: '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-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-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: '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-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: '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: '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: '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: 'other'! flushDisplay Display deferUpdates: false; forceDisplayUpdate.! ! !FormCanvas methodsFor: 'other' stamp: 'StephaneDucasse 2/9/2011 14:51'! forceToScreen: rect ^Display forceToScreen: rect. ! ! !FormCanvas methodsFor: 'other'! showAt: pt ^ form displayAt: pt! ! !FormCanvas methodsFor: 'other' stamp: 'ar 5/28/2000 12:09'! showAt: pt invalidRects: updateRects | blt | blt := (BitBlt current toForm: Display) sourceForm: form; combinationRule: Form over. updateRects do: [:rect | blt sourceRect: rect; destOrigin: rect topLeft + pt; copyBits]! ! !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: 'printing' stamp: 'ar 5/28/2000 17:07'! printOn: aStream super printOn: aStream. aStream nextPutAll:' on: '; print: form.! ! !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: '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: '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: 'RAA 12/17/2000 13:24'! privateClipRect ^clipRect! ! !FormCanvas methodsFor: 'private' stamp: 'RAA 12/17/2000 13:25'! privatePort ^port! ! !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: '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: '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: 'private' stamp: 'IgorStasenko 7/18/2011 18:15'! 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 := Color translucentMaskFor: fillColor alpha depth: self depth. patternWord := form pixelWordFor: fillColor. port fillPattern: (screen collect: [:maskWord | maskWord bitAnd: patternWord]). port combinationRule: Form paint. ! ! !FormCanvas methodsFor: 'private' stamp: 'MarcusDenker 3/24/2012 21:31'! setForm: aForm self reset. form := aForm. port := GrafPort toForm: form. ! ! !FormCanvas methodsFor: 'private' stamp: 'ar 6/22/1999 14:06'! setOrigin: aPoint clipRect: aRectangle origin := aPoint. clipRect := aRectangle. port clipRect: aRectangle. ! ! !FormCanvas methodsFor: 'private' stamp: 'IgorStasenko 7/18/2011 18:16'! 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 := Color translucentMaskFor: paintColor alpha depth: self depth. patternWord := form pixelWordFor: paintColor. port fillPattern: (screen collect: [:maskWord | maskWord bitAnd: patternWord]). port combinationRule: Form paint ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FormCanvas class instanceVariableNames: ''! !FormCanvas class methodsFor: 'instance creation'! extent: aPoint ^ self extent: aPoint depth: Display depth ! ! !FormCanvas class methodsFor: 'instance creation'! extent: extent depth: depth ^ self new setForm: (Form extent: extent depth: depth)! ! !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! ! !FormCanvas class methodsFor: 'instance creation' stamp: 'jm 8/2/97 13:54'! on: aForm ^ self new setForm: aForm ! ! ClassTestCase subclass: #FormTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Tests-Primitives'! !FormTest commentStamp: 'ar 7/21/2007 21:39' prior: 0! Various tests for class form.! !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)! ! !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. ]. ! ! Object subclass: #ForwardingSystemProgressItem instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Widgets'! Number subclass: #Fraction instanceVariableNames: 'numerator denominator' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Numbers'! !Fraction commentStamp: 'VeronicaUquillas 6/11/2010 14:04' prior: 0! 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: '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 sum of the receiver and aNumber." | n d d1 d2 | aNumber isFraction ifTrue: [d := denominator gcd: aNumber denominator. n := numerator * (d1 := aNumber denominator // d) + (aNumber numerator * (d2 := denominator // d)). d1 := d1 * d2. n := n // (d2 := n gcd: d). (d := d1 * (d // d2)) = 1 ifTrue: [^ n]. ^ Fraction numerator: n denominator: d]. ^ aNumber adaptToFraction: self andSend: #+! ! !Fraction methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:58'! - aNumber "Answer the difference between the receiver and aNumber." aNumber isFraction ifTrue: [^ self + aNumber negated]. ^ 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: 'arithmetic'! negated "Refer to the comment in Number|negated." ^ Fraction numerator: numerator negated 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: # aNumber aNumber isFraction ifTrue: [^ numerator * aNumber denominator > (aNumber numerator * denominator)]. ^ aNumber adaptToFraction: self andCompare: #>! ! !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: '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: '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: 'converting' stamp: 'nice 9/25/2011 12:47'! 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 highBit. hb := b highBit. "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: 'converting'! asFraction "Answer the receiver itself." ^self! ! !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'! isFraction ^ true! ! !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: '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: '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: '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 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: 'mathematical functions' stamp: 'LC 4/22/1998 14:05'! squared "See Fraction (Number) | squared" ^ Fraction numerator: numerator squared denominator: denominator squared! ! !Fraction methodsFor: 'printing'! printOn: aStream aStream nextPut: $(. numerator printOn: aStream. aStream nextPut: $/. denominator printOn: aStream. aStream nextPut: $). ! ! !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: 'printing' stamp: 'nice 3/29/2011 22:56'! printOn: aStream showingDecimalPlaces: placesDesired "Same as super, but provides a faster implementation by inlining some Fraction protocol thus avoiding intermediate Fraction creation." | roundedFractionPart integerPart scaling | placesDesired <= 0 ifTrue: [self rounded printOn: aStream] ifFalse: [scaling := 10 raisedToInteger: placesDesired. integerPart := numerator abs quo: denominator. roundedFractionPart := (numerator abs - (integerPart * denominator)) * scaling * 2 + denominator quo: denominator * 2. roundedFractionPart = scaling ifTrue: [integerPart := integerPart + 1. roundedFractionPart := 0]. "Don't print minus sign if result is rouded to zero" (numerator negative and: [integerPart > 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: '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: 'self evaluating' stamp: 'apb 4/20/2006 18:41'! isSelfEvaluating ^ true! ! !Fraction methodsFor: 'testing' stamp: 'HenrikSperreJohansen 1/18/2012 13:10'! isPowerOfTwo |reduced| reduced := self reduced. ^(reduced numerator = 1 and: [reduced denominator isPowerOfTwo]) or: [reduced denominator = 1 and: reduced numerator isPowerOfTwo]! ! !Fraction methodsFor: 'testing' stamp: 'ul 11/29/2010 20:05'! negative ^numerator negative! ! !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: '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: 'truncation and round off' stamp: 'GuillermoPolito 6/22/2012 14:49'! round: numberOfWishedDecimal ^self asFloat round: numberOfWishedDecimal! ! !Fraction methodsFor: 'truncation and round off'! truncated "Refer to the comment in Number|truncated." ^numerator quo: denominator! ! !Fraction methodsFor: 'private'! denominator ^denominator! ! !Fraction methodsFor: 'private'! numerator ^numerator! ! !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'! 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: '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 class instanceVariableNames: ''! !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! ! !Fraction class methodsFor: 'instance creation' stamp: 'nice 10/30/2011 16:34'! 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." ^(SqNumberParser on: stringOrStream) nextFraction! ! ClassTestCase subclass: #FractionTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Numbers'! !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 - 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 - 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: 'nice 6/3/2011 21:32'! testFloor self assert: (3 / 2) floor = 1. self assert: (-3 / 2) floor = -2.! ! !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 - 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 - 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: 'nice 10/31/2010 21:12'! testDegreeCos "self run: #testDegreeCos" self shouldnt: [ (4/3) degreeCos] raise: Error. -361/3 to: 359/3 do: [:i | self assert: (i degreeCos closeTo: i degreesToRadians cos)].! ! !FractionTest methodsFor: 'tests - mathematical functions' stamp: 'nice 10/31/2010 21:15'! testDegreeSin "self run: #testDegreeSin" self shouldnt: [ (4/3) degreeSin] raise: Error. -361/3 to: 359/3 do: [:i | self assert: (i degreeSin closeTo: i degreesToRadians sin)].! ! !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: '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 - 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:27'! testInexactSqrt " FractionTest new testInexactSqrt " self assert: ((1 << 1024 + 1) / (1 << 1024 + 3)) sqrt = 1.0! ! !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 - 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 - 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: '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: '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 - 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)'. ! ! !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 - 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 - rounding' stamp: 'GuillermoPolito 6/22/2012 14:51'! testRounding " self debug: #testRounding " self assert: ((6/90) round: 2) equals: 0.07! ! !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: 'private' stamp: 'jmv 10/11/2011 22:12'! assert: a classAndValueEquals: b self assert: a class = b class. self assert: a = b! ! AbstractSpec subclass: #FrameLayoutSpec instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Spec-Core-Specs'! !FrameLayoutSpec commentStamp: '' prior: 0! A FrameLayoutSpec is for a FrameLayout! !FrameLayoutSpec methodsFor: 'private' stamp: 'BenjaminVanRyseghem 7/13/2012 03:08'! classSymbol ^ #FrameLayout! ! !FrameLayoutSpec methodsFor: 'private' stamp: 'BenjaminVanRyseghem 10/17/2012 13:25'! initializeInstance ^ self defaultReceiver new! ! Object subclass: #FreeTypeCache instanceVariableNames: 'maximumSize used fontTable fifo' classVariableNames: '' poolDictionaries: 'FreeTypeCacheConstants' category: 'FreeType-Cache'! !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: '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: 'add-remove' stamp: 'tween 8/10/2006 21:20'! 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 isNil ifTrue:[0] ifFalse:[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: 'add-remove' stamp: 'tween 8/10/2006 13:40'! removeAll fontTable := self dictionaryClass new: 100. fifo := self fifoClass new. used := 0. ! ! !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: '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: '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: 'AlainPlantec 11/26/2009 21:58'! cacheSize ^ self maximumSize / 1024! ! !FreeTypeCache methodsFor: 'public' stamp: 'AlainPlantec 11/26/2009 21:59'! cacheSize: anInteger self maximumSize: (anInteger * 1024)! ! !FreeTypeCache methodsFor: 'public' stamp: 'AlainPlantec 11/13/2009 14:46'! maximumSize ^ maximumSize ! ! !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: 'public' stamp: 'tween 8/10/2006 13:46'! report "answer a description of the current state of the cache" | usedPercent | usedPercent := maximumSize isNil ifTrue:[0] ifFalse:[(used * 100 / maximumSize) asFloat rounded]. ^usedPercent asString,'% Full (maximumSize: ', maximumSize asString, ' , used: ', used asString,')'! ! !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:20'! dictionaryClass ^Dictionary! ! !FreeTypeCache methodsFor: 'private' stamp: 'tween 8/10/2006 19:03'! fifoClass ^FreeTypeCacheLinkedList! ! !FreeTypeCache methodsFor: 'private' stamp: 'tween 8/10/2006 13:22'! fifoEntryClass ^FreeTypeCacheEntry! ! !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 class instanceVariableNames: 'current'! !FreeTypeCache class methodsFor: 'accessing' stamp: 'tween 8/10/2006 15:33'! clearCurrent " self clearCurrent. " current := nil! ! !FreeTypeCache class methodsFor: 'accessing' stamp: 'tween 8/10/2006 17:03'! current current isNil ifFalse:[^current]. ^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:45'! initialize " self initialize. " Smalltalk addToShutDownList: self. "should it be at a particular place in the list?"! ! !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: 'cleanup' stamp: 'MarcusDenker 4/22/2011 10:32'! cleanUp self clearCurrent! ! !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! ! SharedPool subclass: #FreeTypeCacheConstants instanceVariableNames: '' classVariableNames: 'FreeTypeCacheGlyph FreeTypeCacheGlyphLCD FreeTypeCacheGlyphMono FreeTypeCacheLinearWidth FreeTypeCacheWidth' poolDictionaries: '' category: 'FreeType-Cache'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FreeTypeCacheConstants class instanceVariableNames: ''! !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 ! ! Link subclass: #FreeTypeCacheEntry instanceVariableNames: 'font charCode type object previousLink' classVariableNames: '' poolDictionaries: '' category: 'FreeType-Cache'! !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'! font: anObject "Set the value of font" font := anObject! ! !FreeTypeCacheEntry methodsFor: 'accessing' stamp: 'tween 8/10/2006 14:55'! object "Answer the value of object" ^ object! ! !FreeTypeCacheEntry methodsFor: 'accessing' stamp: 'tween 8/10/2006 14:55'! object: anObject "Set the value of object" object := anObject! ! !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 17:56'! previousLink: anObject "Set the value of previousLink" previousLink := anObject! ! !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 13:16'! type: anObject "Set the value of type" type := anObject! ! !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: 'comparing' stamp: 'tween 8/10/2006 13:34'! hash ^charCode hash! ! LinkedList subclass: #FreeTypeCacheLinkedList instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FreeType-Cache'! !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: '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: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: '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! ! !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: '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: '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 ! ! TestCase subclass: #FreeTypeCacheTest instanceVariableNames: 'cache cache1K fullCache font1 font1XGlyph font1ZGlyph font1YGlyph font2 font3' classVariableNames: '' poolDictionaries: 'FreeTypeCacheConstants' category: 'FreeTypeTests-cache'! !FreeTypeCacheTest methodsFor: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' 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. ! ! !FreeTypeCacheTest methodsFor: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'tween 8/10/2006 09:24'! testSingleton self assert: FreeTypeCache current class = FreeTypeCache. self assert: FreeTypeCache current == FreeTypeCache current. ! ! !FreeTypeCacheTest methodsFor: 'as yet unclassified' 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: 'as yet unclassified' 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]) ! ! FreeTypeFileInfoAbstract subclass: #FreeTypeEmbeddedFileInfo instanceVariableNames: 'fileContents baseName' classVariableNames: '' poolDictionaries: '' category: 'FreeType-FontManager'! !FreeTypeEmbeddedFileInfo methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:21'! baseName "Answer the value of baseName" ^ baseName! ! !FreeTypeEmbeddedFileInfo methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:19'! baseName: anObject "Set the value of baseName" baseName := anObject! ! !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'! fileContents: anObject "Set the value of fileContents" fileContents := anObject! ! !FreeTypeEmbeddedFileInfo methodsFor: 'accessing' stamp: 'tween 7/28/2007 12:43'! fileSize ^fileContents size! ! !FreeTypeEmbeddedFileInfo methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:16'! locationType "Answer the value of locationType" ^ #embedded! ! !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: 'testing' stamp: 'tween 7/16/2007 00:31'! isEmbedded ^true! ! FT2Handle subclass: #FreeTypeExternalMemory instanceVariableNames: 'bytes' classVariableNames: '' poolDictionaries: '' category: 'FreeType-Base'! !FreeTypeExternalMemory methodsFor: 'accessing' stamp: 'tween 8/12/2006 08:40'! bytes ^bytes! ! !FreeTypeExternalMemory methodsFor: 'accessing' stamp: 'tween 8/12/2006 08:40'! bytes: aByteArray bytes := aByteArray! ! !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: 'primitives' stamp: 'tween 8/12/2006 10:24'! primDestroyHandle ^self primitiveFailed! ! !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 class instanceVariableNames: ''! !FreeTypeExternalMemory class methodsFor: 'instance creation' stamp: 'tween 8/12/2006 08:42'! bytes: aByteArray | answer | answer := self basicNew bytes: aByteArray; yourself. ^answer! ! FT2Face subclass: #FreeTypeFace instanceVariableNames: 'filename index fileContentsExternalMemory valid hasKerning session' classVariableNames: '' poolDictionaries: '' category: 'FreeType-Fonts'! !FreeTypeFace methodsFor: 'accessing' stamp: 'tween 3/16/2007 12:44'! familyName ^super familyName ifNil:['?']! ! !FreeTypeFace methodsFor: 'accessing' stamp: 'tween 3/16/2007 12:44'! fileContentsExternalMemory: aFreeTypeExternalMemory fileContentsExternalMemory := aFreeTypeExternalMemory! ! !FreeTypeFace methodsFor: 'accessing' stamp: 'tween 3/16/2007 12:44'! fileContentsExternalMemoryBytes ^fileContentsExternalMemory ifNotNil:[fileContentsExternalMemory bytes]! ! !FreeTypeFace methodsFor: 'accessing' stamp: 'tween 3/16/2007 12:44'! filename ^filename! ! !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 ^index! ! !FreeTypeFace methodsFor: 'accessing' stamp: 'tween 3/16/2007 12:44'! index: anInteger index := anInteger! ! !FreeTypeFace methodsFor: 'accessing' stamp: 'tween 3/16/2007 12:44'! styleName ^super styleName ifNil:['']! ! !FreeTypeFace methodsFor: 'caching' stamp: 'IgorStasenko 10/9/2012 17:41'! releaseCachedState hasKerning := nil. ! ! !FreeTypeFace methodsFor: 'initialize-release' stamp: 'tween 3/16/2007 12:44'! actAsExecutor super actAsExecutor. filename := ''.! ! !FreeTypeFace methodsFor: 'initialize-release' stamp: 'tween 3/16/2007 12:53'! beNull super beNull. valid := nil ! ! !FreeTypeFace methodsFor: 'testing' stamp: 'tween 3/16/2007 12:44'! hasFamilyName ^super familyName notNil! ! !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: 'testing' stamp: 'tween 3/16/2007 12:44'! hasStyleName ^super styleName notNil! ! !FreeTypeFace methodsFor: 'testing' stamp: 'tween 3/31/2007 16:18'! isValid ^valid ifNil:[valid := super isValid]! ! !FreeTypeFace methodsFor: 'validation' stamp: 'CamilloBruni 7/15/2012 19:15'! create "create me in the FT2Plugin. This gets my handle, and loads the fields" fileContentsExternalMemory isNil ifTrue: [ self newFaceFromFile: filename asFileReference index: index ] ifFalse: [ self newFaceFromExternalMemory: fileContentsExternalMemory index: index ]. self loadFields ! ! !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: '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 methodsFor: 'validation' stamp: 'tween 3/16/2007 12:44'! primNewFaceFromExternalMemory: aFreeTypeExternalMemory size: anInteger index: anInteger2 ^self primitiveFailed! ! !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 class instanceVariableNames: ''! !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: '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! ! !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! ! FreeTypeFileInfoAbstract subclass: #FreeTypeFileInfo instanceVariableNames: 'absoluteOrRelativePath absolutePath locationType modificationTime fileSize' classVariableNames: '' poolDictionaries: '' category: 'FreeType-FontManager'! !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 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! ! !FreeTypeFileInfo methodsFor: 'accessing' stamp: 'tween 3/16/2007 04:26'! absolutePath: anObject "Set the value of absolutePath" absolutePath := anObject! ! !FreeTypeFileInfo methodsFor: 'accessing' stamp: 'CamilloBruni 5/4/2012 20:21'! baseName ^ absolutePath asFileReference basename! ! !FreeTypeFileInfo methodsFor: 'accessing' stamp: 'tween 3/16/2007 00:55'! fileSize "Answer the value of fileSize" ^ fileSize! ! !FreeTypeFileInfo methodsFor: 'accessing' stamp: 'tween 3/16/2007 00:55'! fileSize: anObject "Set the value of fileSize" fileSize := anObject! ! !FreeTypeFileInfo methodsFor: 'accessing' stamp: 'tween 3/15/2007 17:31'! locationType "Answer the value of locationType" ^ locationType! ! !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/16/2007 01:14'! modificationTime "Answer the value of modificationTime" ^ modificationTime! ! !FreeTypeFileInfo methodsFor: 'accessing' stamp: 'tween 3/16/2007 01:14'! modificationTime: anObject "Set the value of modificationTime" modificationTime := 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! ! Object subclass: #FreeTypeFileInfoAbstract instanceVariableNames: 'index familyName styleName postscriptName bold italic fixedWidth numFaces familyGroupName slant slantValue weight stretch weightValue stretchValue styleNameExtracted upright' classVariableNames: '' poolDictionaries: '' category: 'FreeType-FontManager'! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! bold "Answer the value of bold" ^ bold! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! bold: anObject "Set the value of bold" bold := anObject! ! !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'! familyGroupName "Answer the value of familyGroupName" ^ familyGroupName! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! familyName "Answer the value of familyName" ^ familyName! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! familyName: anObject "Set the value of familyName" familyName := anObject! ! !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'! fixedWidth: anObject "Set the value of fixedWidth" fixedWidth := anObject! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! index "Answer the value of index" ^ index! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! index: anObject "Set the value of index" index := anObject! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 9/29/2007 10:42'! isBolderThan: val ^self weightValue >= val! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 9/29/2007 10:41'! isItalicOrOblique ^self slantValue > 0! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! italic "Answer the value of italic" ^ italic! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! italic: anObject "Set the value of italic" italic := anObject! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! numFaces "Answer the value of numFaces" ^ numFaces! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! numFaces: anObject "Set the value of numFaces" numFaces := anObject! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! postscriptName "Answer the value of postscriptName" ^ postscriptName! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 7/16/2007 00:20'! postscriptName: anObject "Set the value of postscriptName" postscriptName := anObject! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:59'! slant "Answer the value of slant" ^ slant! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 8/16/2007 21:39'! slantValue ^slantValue! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 8/11/2007 14:22'! stretch "Answer the value of stretch" ^ stretch! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 8/16/2007 01:04'! stretchValue "Answer the value of stretchValue" ^ stretchValue! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 8/16/2007 01:04'! stretchValue: anObject "Set the value of stretchValue" stretchValue := anObject! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 8/16/2007 20:59'! style "Answer the value of slant" ^ slant! ! !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'! styleName: anObject "Set the value of styleName" styleName := anObject! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 8/12/2007 19:27'! styleNameExtracted ^styleNameExtracted! ! !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: '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: '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 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: '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/11/2007 14:22'! weight "Answer the value of weight" ^ weight! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 8/16/2007 01:04'! weightValue "Answer the value of weightValue" ^ weightValue! ! !FreeTypeFileInfoAbstract methodsFor: 'accessing' stamp: 'tween 8/16/2007 01:04'! weightValue: anObject "Set the value of weightValue" weightValue := anObject! ! !FreeTypeFileInfoAbstract methodsFor: 'testing' stamp: 'tween 7/16/2007 00:31'! isEmbedded ^false! ! AbstractFont subclass: #FreeTypeFont instanceVariableNames: 'face pointSize simulatedEmphasis pixelSize widthAndKernedWidthCache cachedHeight cachedAscent cachedDescent subPixelPositioned symbolFont' classVariableNames: '' poolDictionaries: 'FT2Constants FreeTypeCacheConstants' category: 'FreeType-Fonts'! !FreeTypeFont methodsFor: 'accessing' stamp: 'tween 7/15/2007 22:00'! clearCachedMetrics widthAndKernedWidthCache := cachedHeight := cachedAscent := cachedDescent := subPixelPositioned := nil! ! !FreeTypeFont methodsFor: 'accessing' stamp: 'tween 9/29/2007 09:44'! defaultSimulatedItalicSlant ^0.22! ! !FreeTypeFont methodsFor: 'accessing' stamp: 'tween 3/17/2007 11:27'! depth ^ 32.! ! !FreeTypeFont methodsFor: 'accessing' stamp: 'tween 3/17/2007 11:33'! face "Validate, and answer, the receiver's face" ^face validate! ! !FreeTypeFont methodsFor: 'accessing' stamp: 'tween 3/17/2007 11:34'! face: aFace face := aFace! ! !FreeTypeFont methodsFor: 'accessing' stamp: 'tween 3/31/2007 11:57'! hash ^pointSize hash! ! !FreeTypeFont methodsFor: 'accessing' stamp: 'tween 3/17/2007 11:44'! maxAscii "should have default in AbstractFont" ^SmallInteger maxVal! ! !FreeTypeFont methodsFor: 'accessing' stamp: 'tween 3/17/2007 11:44'! minAscii "should have default in AbstractFont" ^0! ! !FreeTypeFont methodsFor: 'accessing' stamp: 'tween 8/27/2007 10:02'! postscriptName ^self face postscriptName! ! !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: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: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: '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: '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: 'accessing' stamp: 'dik 6/10/2010 21:13'! veryDeepCopyWith: deepCopier! ! !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: '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: '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: '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: '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: '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: '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: '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: '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: '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: 'initialize-release' stamp: 'tween 3/17/2007 11:39'! initialize: aFont self face: aFont face.! ! !FreeTypeFont methodsFor: 'initialize-release' stamp: 'tween 3/17/2007 11:45'! releaseCachedState face releaseCachedState. FreeTypeCache current removeAllForFont: self.! ! !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: 'measuring' stamp: 'tween 3/26/2007 13:14'! basicAscent ^(self face ascender * self pixelSize // self face unitsPerEm). ! ! !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: 'measuring' stamp: 'tween 3/17/2007 11:28'! descentKern "should have default in AbstractFont" ^0! ! !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: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 4/3/2007 17:25'! height ^cachedHeight ifNil:[ cachedHeight := (self face height * self pixelSize / self face unitsPerEm) ceiling ]! ! !FreeTypeFont methodsFor: 'measuring' stamp: 'tween 4/3/2007 16:42'! hintedKerningLeft: leftChar right: rightChar ^(self linearKerningLeft: leftChar right: rightChar) rounded! ! !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: '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:43'! lineGrid ^self height! ! !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: '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: 'measuring' stamp: 'tween 3/31/2007 11:38'! pixelSize ^pixelSize ifNil:[pixelSize := super pixelSize rounded]! ! !FreeTypeFont methodsFor: 'measuring' stamp: 'tween 3/17/2007 11:45'! pointSize ^pointSize! ! !FreeTypeFont methodsFor: 'measuring' stamp: 'tween 3/17/2007 11:45'! pointSize: aSize pointSize := aSize! ! !FreeTypeFont methodsFor: 'measuring' stamp: 'tween 4/2/2007 22:10'! widthAndKernedWidthCache ^widthAndKernedWidthCache ifNil:[widthAndKernedWidthCache := Dictionary new]! ! !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: '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 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: '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: '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: '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: '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: 'testing' stamp: 'tween 9/29/2007 09:49'! isBold ^(simulatedEmphasis == nil and:[self face isBold]) or:[self isSimulatedBold]! ! !FreeTypeFont methodsFor: 'testing' stamp: 'tween 3/17/2007 11:41'! isFixedWidth ^self face isFixedWidth ! ! !FreeTypeFont methodsFor: 'testing' stamp: 'tween 9/29/2007 09:48'! isItalic ^(simulatedEmphasis == nil and:[self face isItalic]) or:[self isSimulatedItalic]! ! !FreeTypeFont methodsFor: 'testing' stamp: 'tween 9/29/2007 09:49'! isRegular ^(simulatedEmphasis == nil and:[self face isRegular]) or: [self isSimulatedRegular]! ! !FreeTypeFont methodsFor: 'testing' stamp: 'tween 9/29/2007 09:41'! isSimulated ^simulatedEmphasis notNil! ! !FreeTypeFont methodsFor: 'testing' stamp: 'tween 9/29/2007 09:42'! isSimulatedBold ^self simulatedEmphasis anyMask: 1! ! !FreeTypeFont methodsFor: 'testing' stamp: 'tween 9/29/2007 09:45'! isSimulatedItalic ^self simulatedEmphasis anyMask: 2! ! !FreeTypeFont methodsFor: 'testing' stamp: 'tween 9/29/2007 09:45'! isSimulatedRegular ^simulatedEmphasis = 0! ! !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: '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: 'testing' stamp: 'tween 3/17/2007 11:42'! isTTCFont "not really - look for senders of this" ^true! ! !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 class instanceVariableNames: ''! !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]! ! !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: 'profiling' stamp: 'BernardoContreras 10/2/2011 19:42'! profileHintedComposition " self profileHintedComposition " | t f m text | FreeTypeSettings current hintingSymbol: #None. FreeTypeSettings current hintingSymbol: #Light. "cache is now clear" t := TextStyle named: #DefaultTextStyle. f := t fontOfPointSize: 12. m := TextMorph new. m width: 200; height: 200. m backgroundColor: Color white. text := 'Welcome to the finale version of 3.9 of 7 of November 2006 You will find more recent versions at http://www.squeak.org/ This image will be used to produce other distributions such as a developer image and a fun with Squeak image. We hope that you will really appreciate this version and that Squeak will help you making your projects reality. You can also participate to Squeak at different kinds of levels. This can be as simple as: - asking questions in the beginner list (beginners@lists.squeakfoundation.org) or in the dev list (squeak-dev@lists.squeakfoundation.org) - answering questions - finding and reporting bugs at: http://bugs.impara.de - fixing them, testing fixes and commenting them - writing tests for uncovered parts - helping for the website - creating new cool products, frameworks, applications in squeak - writing articles.... We wish you a lot of fun and we would like to thanks all the persons that participated to make this release a really good one. We know who you are!! Stephane Ducasse and Marcus Denker stephane.ducasse@free.fr and denker@iam.unibe.ch' asText. text addAttribute: (TextFontReference toFont: f). m contents: text. m openInWorld. Smalltalk tools timeProfiler onBlock: [ 2 timesRepeat:[m justified; leftFlush]]. m delete ! ! !FreeTypeFont class methodsFor: 'profiling' stamp: 'BernardoContreras 10/2/2011 19:43'! profileHintedDisplayCached " self profileHintedDisplayCached " | t f m text canvas | FreeTypeSettings current hintingSymbol: #None. FreeTypeSettings current hintingSymbol: #Light. "cache is now clear" t := TextStyle named: #DefaultTextStyle. f := t fontOfPointSize: 12. m := TextMorph new. m width: 200; height: 200. m backgroundColor: Color white. text := 'Welcome to the finale version of 3.9 of 7 of November 2006 You will find more recent versions at http://www.squeak.org/ This image will be used to produce other distributions such as a developer image and a fun with Squeak image. We hope that you will really appreciate this version and that Squeak will help you making your projects reality. You can also participate to Squeak at different kinds of levels. This can be as simple as: - asking questions in the beginner list (beginners@lists.squeakfoundation.org) or in the dev list (squeak-dev@lists.squeakfoundation.org) - answering questions - finding and reporting bugs at: http://bugs.impara.de - fixing them, testing fixes and commenting them - writing tests for uncovered parts - helping for the website - creating new cool products, frameworks, applications in squeak - writing articles.... We wish you a lot of fun and we would like to thanks all the persons that participated to make this release a really good one. We know who you are!! Stephane Ducasse and Marcus Denker stephane.ducasse@free.fr and denker@iam.unibe.ch' asText. text addAttribute: (TextFontReference toFont: f). m contents: text. m openInWorld. canvas := (FormCanvas on: (Form extent: 1000@1000 depth: 32)). m drawOn: canvas. "this fills the cache" Smalltalk tools timeProfiler onBlock: [ 2 timesRepeat: [m drawOn: canvas ]]. m delete ! ! !FreeTypeFont class methodsFor: 'profiling' stamp: 'BernardoContreras 10/2/2011 19:44'! profileHintedDisplayCachedUsingMode34 " self profileHintedDisplayCachedUsingMode34 " | t f m text | FreeTypeSettings current hintingSymbol: #None. FreeTypeSettings current hintingSymbol: #Light. "cache is now clear" t := TextStyle named: #DefaultTextStyle. f := t fontOfPointSize: 12. m := TextMorph new. m width: 200; height: 200. m backgroundColor: Color white. text := 'Welcome to the finale version of 3.9 of 7 of November 2006 You will find more recent versions at http://www.squeak.org/ This image will be used to produce other distributions such as a developer image and a fun with Squeak image. We hope that you will really appreciate this version and that Squeak will help you making your projects reality. You can also participate to Squeak at different kinds of levels. This can be as simple as: - asking questions in the beginner list (beginners@lists.squeakfoundation.org) or in the dev list (squeak-dev@lists.squeakfoundation.org) - answering questions - finding and reporting bugs at: http://bugs.impara.de - fixing them, testing fixes and commenting them - writing tests for uncovered parts - helping for the website - creating new cool products, frameworks, applications in squeak - writing articles.... We wish you a lot of fun and we would like to thanks all the persons that participated to make this release a really good one. We know who you are!! Stephane Ducasse and Marcus Denker stephane.ducasse@free.fr and denker@iam.unibe.ch' asText. text addAttribute: (TextFontReference toFont: f). m contents: text. m openInWorld. FreeTypeSettings current pretendBitBltSubPixelUnavailableDuring:[ | canvas | canvas := (FormCanvas on: (Form extent: 1000@1000 depth: 32)). m drawOn: canvas. "this fills the cache" Smalltalk tools timeProfiler onBlock: [ 2 timesRepeat: [m drawOn: canvas ]]]. m delete ! ! !FreeTypeFont class methodsFor: 'profiling' stamp: 'BernardoContreras 10/2/2011 19:44'! profileHintedWidthOfString " self profileHintedWidthOfString " | t f string | FreeTypeSettings current hintingSymbol: #None. FreeTypeSettings current hintingSymbol: #Light. "cache is now clear" t := TextStyle named: #DefaultTextStyle. f := t fontOfPointSize: 12. string := 'Welcome to the finale version of 3.9 of 7 of November 2006 You will find more recent versions at http://www.squeak.org/ This image will be used to produce other distributions such as a developer image and a fun with Squeak image. We hope that you will really appreciate this version and that Squeak will help you making your projects reality. You can also participate to Squeak at different kinds of levels. This can be as simple as: - asking questions in the beginner list (beginners@lists.squeakfoundation.org) or in the dev list (squeak-dev@lists.squeakfoundation.org) - answering questions - finding and reporting bugs at: http://bugs.impara.de - fixing them, testing fixes and commenting them - writing tests for uncovered parts - helping for the website - creating new cool products, frameworks, applications in squeak - writing articles.... We wish you a lot of fun and we would like to thanks all the persons that participated to make this release a really good one. We know who you are!! Stephane Ducasse and Marcus Denker stephane.ducasse@free.fr and denker@iam.unibe.ch' . Smalltalk tools timeProfiler onBlock: [ 200 timesRepeat:[f widthOfString: string]]. ! ! !FreeTypeFont class methodsFor: 'profiling' stamp: 'BernardoContreras 10/2/2011 19:45'! profileHintedWidthOfStringCached " self profileHintedWidthOfStringCached " | t f string | FreeTypeSettings current hintingSymbol: #None. FreeTypeSettings current hintingSymbol: #Light. "cache is now clear" t := TextStyle named: #DefaultTextStyle. f := t fontOfPointSize: 12. string := 'Welcome to the finale version of 3.9 of 7 of November 2006 You will find more recent versions at http://www.squeak.org/ This image will be used to produce other distributions such as a developer image and a fun with Squeak image. We hope that you will really appreciate this version and that Squeak will help you making your projects reality. You can also participate to Squeak at different kinds of levels. This can be as simple as: - asking questions in the beginner list (beginners@lists.squeakfoundation.org) or in the dev list (squeak-dev@lists.squeakfoundation.org) - answering questions - finding and reporting bugs at: http://bugs.impara.de - fixing them, testing fixes and commenting them - writing tests for uncovered parts - helping for the website - creating new cool products, frameworks, applications in squeak - writing articles.... We wish you a lot of fun and we would like to thanks all the persons that participated to make this release a really good one. We know who you are!! Stephane Ducasse and Marcus Denker stephane.ducasse@free.fr and denker@iam.unibe.ch' . f widthOfString: string. "this fills any caches" Smalltalk tools timeProfiler onBlock: [ 200 timesRepeat:[f widthOfString: string]]. ! ! !FreeTypeFont class methodsFor: 'profiling' stamp: 'BernardoContreras 10/2/2011 19:45'! profileHintedWidthOfStringCachedMulti " self profileHintedWidthOfStringCachedMulti " | t f string | FreeTypeSettings current hintingSymbol: #None. FreeTypeSettings current hintingSymbol: #Light. "cache is now clear" t := TextStyle named: #DefaultTextStyle. f := t fontOfPointSize: 12. string := 'Welcome to the finale version of 3.9 of 7 of November 2006 You will find more recent versions at http://www.squeak.org/ This image will be used to produce other distributions such as a developer image and a fun with Squeak image. We hope that you will really appreciate this version and that Squeak will help you making your projects reality. You can also participate to Squeak at different kinds of levels. This can be as simple as: - asking questions in the beginner list (beginners@lists.squeakfoundation.org) or in the dev list (squeak-dev@lists.squeakfoundation.org) - answering questions - finding and reporting bugs at: http://bugs.impara.de - fixing them, testing fixes and commenting them - writing tests for uncovered parts - helping for the website - creating new cool products, frameworks, applications in squeak - writing articles.... We wish you a lot of fun and we would like to thanks all the persons that participated to make this release a really good one. We know who you are!! Stephane Ducasse and Marcus Denker stephane.ducasse@free.fr and denker@iam.unibe.ch' , 1000 asCharacter asString. f widthOfString: string. "this fills any caches" Smalltalk tools timeProfiler onBlock: [ 200 timesRepeat:[f widthOfString: string]]. ! ! !FreeTypeFont class methodsFor: 'profiling' stamp: 'BernardoContreras 10/2/2011 19:46'! profileHintedWidthOfStringMulti " self profileHintedWidthOfStringMulti " | t f string | FreeTypeSettings current hintingSymbol: #None. FreeTypeSettings current hintingSymbol: #Light. "cache is now clear" t := TextStyle named: #DefaultTextStyle. f := t fontOfPointSize: 12. string := 'Welcome to the finale version of 3.9 of 7 of November 2006 You will find more recent versions at http://www.squeak.org/ This image will be used to produce other distributions such as a developer image and a fun with Squeak image. We hope that you will really appreciate this version and that Squeak will help you making your projects reality. You can also participate to Squeak at different kinds of levels. This can be as simple as: - asking questions in the beginner list (beginners@lists.squeakfoundation.org) or in the dev list (squeak-dev@lists.squeakfoundation.org) - answering questions - finding and reporting bugs at: http://bugs.impara.de - fixing them, testing fixes and commenting them - writing tests for uncovered parts - helping for the website - creating new cool products, frameworks, applications in squeak - writing articles.... We wish you a lot of fun and we would like to thanks all the persons that participated to make this release a really good one. We know who you are!! Stephane Ducasse and Marcus Denker stephane.ducasse@free.fr and denker@iam.unibe.ch' , 1000 asCharacter asString. Smalltalk tools timeProfiler onBlock: [ 200 timesRepeat:[f widthOfString: string]]. ! ! !FreeTypeFont class methodsFor: 'profiling' stamp: 'BernardoContreras 10/2/2011 19:46'! profileUnhinted " self profileUnhinted " | t f m text | t := TextStyle named: #DefaultTextStyle. f := t fontOfPointSize: 12. m := TextMorph new. m width: 200; height: 200. m backgroundColor: Color white. text := 'Welcome to the finale version of 3.9 of 7 of November 2006 You will find more recent versions at http://www.squeak.org/ This image will be used to produce other distributions such as a developer image and a fun with Squeak image. We hope that you will really appreciate this version and that Squeak will help you making your projects reality. You can also participate to Squeak at different kinds of levels. This can be as simple as: - asking questions in the beginner list (beginners@lists.squeakfoundation.org) or in the dev list (squeak-dev@lists.squeakfoundation.org) - answering questions - finding and reporting bugs at: http://bugs.impara.de - fixing them, testing fixes and commenting them - writing tests for uncovered parts - helping for the website - creating new cool products, frameworks, applications in squeak - writing articles.... We wish you a lot of fun and we would like to thanks all the persons that participated to make this release a really good one. We know who you are!! Stephane Ducasse and Marcus Denker stephane.ducasse@free.fr and denker@iam.unibe.ch' asText. text addAttribute: (TextFontReference toFont: f). m contents: text. m openInWorld. Smalltalk tools timeProfiler onBlock: [m justified; leftFlush]. m delete ! ! !FreeTypeFont class methodsFor: 'profiling' stamp: 'BernardoContreras 10/2/2011 19:46'! profileUnhintedComposition " self profileUnhintedComposition " | t f m text | FreeTypeSettings current hintingSymbol: #None. FreeTypeSettings current hintingSymbol: #Light. "cache is now clear" t := TextStyle named: #DefaultTextStyle. f := t fontOfPointSize: 12. m := TextMorph new. m width: 200; height: 200. m backgroundColor: Color white. text := 'Welcome to the finale version of 3.9 of 7 of November 2006 You will find more recent versions at http://www.squeak.org/ This image will be used to produce other distributions such as a developer image and a fun with Squeak image. We hope that you will really appreciate this version and that Squeak will help you making your projects reality. You can also participate to Squeak at different kinds of levels. This can be as simple as: - asking questions in the beginner list (beginners@lists.squeakfoundation.org) or in the dev list (squeak-dev@lists.squeakfoundation.org) - answering questions - finding and reporting bugs at: http://bugs.impara.de - fixing them, testing fixes and commenting them - writing tests for uncovered parts - helping for the website - creating new cool products, frameworks, applications in squeak - writing articles.... We wish you a lot of fun and we would like to thanks all the persons that participated to make this release a really good one. We know who you are!! Stephane Ducasse and Marcus Denker stephane.ducasse@free.fr and denker@iam.unibe.ch' asText. text addAttribute: (TextFontReference toFont: f). m contents: text. m openInWorld. Smalltalk tools timeProfiler onBlock: [ 2 timesRepeat:[m justified; leftFlush]]. m delete ! ! !FreeTypeFont class methodsFor: 'profiling' stamp: 'BernardoContreras 10/2/2011 19:46'! profileUnhintedCompositionMulti " self profileUnhintedCompositionMulti " | t f m text | FreeTypeSettings current hintingSymbol: #None. FreeTypeSettings current hintingSymbol: #Light. "cache is now clear" t := TextStyle named: #DefaultTextStyle. f := t fontOfPointSize: 12. m := TextMorph new. m width: 200; height: 200. m backgroundColor: Color white. text := ('Welcome to the finale version of 3.9 of 7 of November 2006 You will find more recent versions at http://www.squeak.org/ This image will be used to produce other distributions such as a developer image and a fun with Squeak image. We hope that you will really appreciate this version and that Squeak will help you making your projects reality. You can also participate to Squeak at different kinds of levels. This can be as simple as: - asking questions in the beginner list (beginners@lists.squeakfoundation.org) or in the dev list (squeak-dev@lists.squeakfoundation.org) - answering questions - finding and reporting bugs at: http://bugs.impara.de - fixing them, testing fixes and commenting them - writing tests for uncovered parts - helping for the website - creating new cool products, frameworks, applications in squeak - writing articles.... We wish you a lot of fun and we would like to thanks all the persons that participated to make this release a really good one. We know who you are!! Stephane Ducasse and Marcus Denker stephane.ducasse@free.fr and denker@iam.unibe.ch' , 1000 asCharacter asString) asText. text addAttribute: (TextFontReference toFont: f). m contents: text. m openInWorld. Smalltalk tools timeProfiler onBlock: [ 2 timesRepeat:[m justified; leftFlush]]. m delete ! ! !FreeTypeFont class methodsFor: 'profiling' stamp: 'BernardoContreras 10/2/2011 19:47'! profileUnhintedDisplay " self profileUnhintedDisplay " | t f m text canvas | FreeTypeSettings current hintingSymbol: #None. FreeTypeSettings current hintingSymbol: #Light. "cache is now clear" t := TextStyle named: #DefaultTextStyle. f := t fontOfPointSize: 12. m := TextMorph new. m width: 200; height: 200. m backgroundColor: Color white. text := 'Welcome to the finale version of 3.9 of 7 of November 2006 You will find more recent versions at http://www.squeak.org/ This image will be used to produce other distributions such as a developer image and a fun with Squeak image. We hope that you will really appreciate this version and that Squeak will help you making your projects reality. You can also participate to Squeak at different kinds of levels. This can be as simple as: - asking questions in the beginner list (beginners@lists.squeakfoundation.org) or in the dev list (squeak-dev@lists.squeakfoundation.org) - answering questions - finding and reporting bugs at: http://bugs.impara.de - fixing them, testing fixes and commenting them - writing tests for uncovered parts - helping for the website - creating new cool products, frameworks, applications in squeak - writing articles.... We wish you a lot of fun and we would like to thanks all the persons that participated to make this release a really good one. We know who you are!! Stephane Ducasse and Marcus Denker stephane.ducasse@free.fr and denker@iam.unibe.ch' asText. text addAttribute: (TextFontReference toFont: f). m contents: text. m openInWorld. canvas := (FormCanvas on: (Form extent: 1000@1000 depth: 32)). Smalltalk tools timeProfiler onBlock: [ 2 timesRepeat: [m drawOn: canvas ]]. m delete ! ! !FreeTypeFont class methodsFor: 'profiling' stamp: 'BernardoContreras 10/2/2011 19:47'! profileUnhintedDisplayCached " self profileUnhintedDisplayCached " | t f m text canvas | FreeTypeSettings current hintingSymbol: #None. FreeTypeSettings current hintingSymbol: #Light. "cache is now clear" t := TextStyle named: #DefaultTextStyle. f := t fontOfPointSize: 12. m := TextMorph new. m width: 200; height: 200. m backgroundColor: Color white. text := 'Welcome to the finale version of 3.9 of 7 of November 2006 You will find more recent versions at http://www.squeak.org/ This image will be used to produce other distributions such as a developer image and a fun with Squeak image. We hope that you will really appreciate this version and that Squeak will help you making your projects reality. You can also participate to Squeak at different kinds of levels. This can be as simple as: - asking questions in the beginner list (beginners@lists.squeakfoundation.org) or in the dev list (squeak-dev@lists.squeakfoundation.org) - answering questions - finding and reporting bugs at: http://bugs.impara.de - fixing them, testing fixes and commenting them - writing tests for uncovered parts - helping for the website - creating new cool products, frameworks, applications in squeak - writing articles.... We wish you a lot of fun and we would like to thanks all the persons that participated to make this release a really good one. We know who you are!! Stephane Ducasse and Marcus Denker stephane.ducasse@free.fr and denker@iam.unibe.ch' asText. text addAttribute: (TextFontReference toFont: f). m contents: text. m openInWorld. canvas := (FormCanvas on: (Form extent: 1000@1000 depth: 32)). m drawOn: canvas. "this fills the cache" Smalltalk tools timeProfiler onBlock: [ 2 timesRepeat: [m drawOn: canvas ]]. m delete ! ! !FreeTypeFont class methodsFor: 'profiling' stamp: 'BernardoContreras 10/2/2011 19:48'! profileUnhintedDisplayCachedMulti " self profileUnhintedDisplayCachedMulti " | t f m text canvas | FreeTypeSettings current hintingSymbol: #None. FreeTypeSettings current hintingSymbol: #Light. "cache is now clear" t := TextStyle named: #DefaultTextStyle. f := t fontOfPointSize: 12. m := TextMorph new. m width: 200; height: 200. m backgroundColor: Color white. text := ('Welcome to the finale version of 3.9 of 7 of November 2006 You will find more recent versions at http://www.squeak.org/ This image will be used to produce other distributions such as a developer image and a fun with Squeak image. We hope that you will really appreciate this version and that Squeak will help you making your projects reality. You can also participate to Squeak at different kinds of levels. This can be as simple as: - asking questions in the beginner list (beginners@lists.squeakfoundation.org) or in the dev list (squeak-dev@lists.squeakfoundation.org) - answering questions - finding and reporting bugs at: http://bugs.impara.de - fixing them, testing fixes and commenting them - writing tests for uncovered parts - helping for the website - creating new cool products, frameworks, applications in squeak - writing articles.... We wish you a lot of fun and we would like to thanks all the persons that participated to make this release a really good one. We know who you are!! Stephane Ducasse and Marcus Denker stephane.ducasse@free.fr and denker@iam.unibe.ch' , 1000 asCharacter asString) asText. text addAttribute: (TextFontReference toFont: f). m contents: text. m openInWorld. canvas := (FormCanvas on: (Form extent: 1000@1000 depth: 32)). m drawOn: canvas. "this fills the cache" Smalltalk tools timeProfiler onBlock: [ 2 timesRepeat: [m drawOn: canvas ]]. m delete ! ! !FreeTypeFont class methodsFor: 'profiling' stamp: 'BernardoContreras 10/2/2011 19:48'! profileUnhintedDisplayMulti " self profileUnhintedDisplayMulti " | t f m text canvas | FreeTypeSettings current hintingSymbol: #None. FreeTypeSettings current hintingSymbol: #Light. "cache is now clear" t := TextStyle named: #DefaultTextStyle. f := t fontOfPointSize: 12. m := TextMorph new. m width: 200; height: 200. m backgroundColor: Color white. text := ('Welcome to the finale version of 3.9 of 7 of November 2006 You will find more recent versions at http://www.squeak.org/ This image will be used to produce other distributions such as a developer image and a fun with Squeak image. We hope that you will really appreciate this version and that Squeak will help you making your projects reality. You can also participate to Squeak at different kinds of levels. This can be as simple as: - asking questions in the beginner list (beginners@lists.squeakfoundation.org) or in the dev list (squeak-dev@lists.squeakfoundation.org) - answering questions - finding and reporting bugs at: http://bugs.impara.de - fixing them, testing fixes and commenting them - writing tests for uncovered parts - helping for the website - creating new cool products, frameworks, applications in squeak - writing articles.... We wish you a lot of fun and we would like to thanks all the persons that participated to make this release a really good one. We know who you are!! Stephane Ducasse and Marcus Denker stephane.ducasse@free.fr and denker@iam.unibe.ch' , 1000 asCharacter asString) asText. text addAttribute: (TextFontReference toFont: f). m contents: text. m openInWorld. canvas := (FormCanvas on: (Form extent: 1000@1000 depth: 32)). Smalltalk tools timeProfiler onBlock: [ 2 timesRepeat: [m drawOn: canvas ]]. m delete ! ! !FreeTypeFont class methodsFor: 'profiling' stamp: 'BernardoContreras 10/2/2011 19:48'! profileUnhintedWidthOfString " self profileUnhintedWidthOfString " | t f string | FreeTypeSettings current hintingSymbol: #None. FreeTypeSettings current hintingSymbol: #Light. "cache is now clear" t := TextStyle named: #DefaultTextStyle. f := t fontOfPointSize: 12. string := 'Welcome to the finale version of 3.9 of 7 of November 2006 You will find more recent versions at http://www.squeak.org/ This image will be used to produce other distributions such as a developer image and a fun with Squeak image. We hope that you will really appreciate this version and that Squeak will help you making your projects reality. You can also participate to Squeak at different kinds of levels. This can be as simple as: - asking questions in the beginner list (beginners@lists.squeakfoundation.org) or in the dev list (squeak-dev@lists.squeakfoundation.org) - answering questions - finding and reporting bugs at: http://bugs.impara.de - fixing them, testing fixes and commenting them - writing tests for uncovered parts - helping for the website - creating new cool products, frameworks, applications in squeak - writing articles.... We wish you a lot of fun and we would like to thanks all the persons that participated to make this release a really good one. We know who you are!! Stephane Ducasse and Marcus Denker stephane.ducasse@free.fr and denker@iam.unibe.ch' . Smalltalk tools timeProfiler onBlock: [ 200 timesRepeat:[f widthOfString: string]]. ! ! !FreeTypeFont class methodsFor: 'profiling' stamp: 'BernardoContreras 10/2/2011 19:48'! profileUnhintedWidthOfStringCached " self profileUnhintedWidthOfStringCached " | t f string | FreeTypeSettings current hintingSymbol: #None. FreeTypeSettings current hintingSymbol: #Light. "cache is now clear" t := TextStyle named: #DefaultTextStyle. f := t fontOfPointSize: 12. string := 'Welcome to the finale version of 3.9 of 7 of November 2006 You will find more recent versions at http://www.squeak.org/ This image will be used to produce other distributions such as a developer image and a fun with Squeak image. We hope that you will really appreciate this version and that Squeak will help you making your projects reality. You can also participate to Squeak at different kinds of levels. This can be as simple as: - asking questions in the beginner list (beginners@lists.squeakfoundation.org) or in the dev list (squeak-dev@lists.squeakfoundation.org) - answering questions - finding and reporting bugs at: http://bugs.impara.de - fixing them, testing fixes and commenting them - writing tests for uncovered parts - helping for the website - creating new cool products, frameworks, applications in squeak - writing articles.... We wish you a lot of fun and we would like to thanks all the persons that participated to make this release a really good one. We know who you are!! Stephane Ducasse and Marcus Denker stephane.ducasse@free.fr and denker@iam.unibe.ch' . f widthOfString: string. "this fills any caches" Smalltalk tools timeProfiler onBlock: [ 200 timesRepeat:[f widthOfString: string]]. ! ! !FreeTypeFont class methodsFor: 'profiling' stamp: 'BernardoContreras 10/2/2011 19:49'! profileUnhintedWidthOfStringCachedMulti " self profileUnhintedWidthOfStringCachedMulti " | t f string | FreeTypeSettings current hintingSymbol: #None. FreeTypeSettings current hintingSymbol: #Light. "cache is now clear" t := TextStyle named: #DefaultTextStyle. f := t fontOfPointSize: 12. string := 'Welcome to the finale version of 3.9 of 7 of November 2006 You will find more recent versions at http://www.squeak.org/ This image will be used to produce other distributions such as a developer image and a fun with Squeak image. We hope that you will really appreciate this version and that Squeak will help you making your projects reality. You can also participate to Squeak at different kinds of levels. This can be as simple as: - asking questions in the beginner list (beginners@lists.squeakfoundation.org) or in the dev list (squeak-dev@lists.squeakfoundation.org) - answering questions - finding and reporting bugs at: http://bugs.impara.de - fixing them, testing fixes and commenting them - writing tests for uncovered parts - helping for the website - creating new cool products, frameworks, applications in squeak - writing articles.... We wish you a lot of fun and we would like to thanks all the persons that participated to make this release a really good one. We know who you are!! Stephane Ducasse and Marcus Denker stephane.ducasse@free.fr and denker@iam.unibe.ch' , 1000 asCharacter asString. f widthOfString: string. "this fills any caches" Smalltalk tools timeProfiler onBlock: [ 200 timesRepeat:[f widthOfString: string]]. ! ! !FreeTypeFont class methodsFor: 'profiling' stamp: 'BernardoContreras 10/2/2011 19:49'! profileUnhintedWidthOfStringMulti " self profileUnhintedWidthOfStringMulti " | t f string | FreeTypeSettings current hintingSymbol: #None. FreeTypeSettings current hintingSymbol: #Light. "cache is now clear" t := TextStyle named: #DefaultTextStyle. f := t fontOfPointSize: 12. string := 'Welcome to the finale version of 3.9 of 7 of November 2006 You will find more recent versions at http://www.squeak.org/ This image will be used to produce other distributions such as a developer image and a fun with Squeak image. We hope that you will really appreciate this version and that Squeak will help you making your projects reality. You can also participate to Squeak at different kinds of levels. This can be as simple as: - asking questions in the beginner list (beginners@lists.squeakfoundation.org) or in the dev list (squeak-dev@lists.squeakfoundation.org) - answering questions - finding and reporting bugs at: http://bugs.impara.de - fixing them, testing fixes and commenting them - writing tests for uncovered parts - helping for the website - creating new cool products, frameworks, applications in squeak - writing articles.... We wish you a lot of fun and we would like to thanks all the persons that participated to make this release a really good one. We know who you are!! Stephane Ducasse and Marcus Denker stephane.ducasse@free.fr and denker@iam.unibe.ch' , 1000 asCharacter asString. Smalltalk tools timeProfiler onBlock: [ 200 timesRepeat:[f widthOfString: string]]. ! ! FontFamilyAbstract subclass: #FreeTypeFontFamily instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FreeType-FontManager'! !FreeTypeFontFamily methodsFor: 'accessing' stamp: 'tween 8/25/2007 14:26'! addMember: aFreeTypeFontFamilyMember aFreeTypeFontFamilyMember family: self. members add: aFreeTypeFontFamilyMember! ! !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: 'accessing' stamp: 'tween 8/16/2007 22:59'! memberWithStyleName: aString ^members detect:[:each | each styleName = aString] ifNone:[] ! ! !FreeTypeFontFamily methodsFor: 'initialize-release' 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: 'simulated members' stamp: 'tween 8/18/2007 22:22'! rebuildSimulatedMembers "FOR TESTING ONLY" members := members reject:[:each| each simulated]. self addSimulatedMembers.! ! FontFamilyMemberAbstract subclass: #FreeTypeFontFamilyMember instanceVariableNames: 'fileInfo stretchName stretchValue weightName weightValue slantName slantValue simulated' classVariableNames: '' poolDictionaries: '' category: 'FreeType-FontManager'! !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:46'! fileInfo: anObject "Set the value of fileInfo" fileInfo := anObject! ! !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'! simulated: anObject "Set the value of simulated" simulated := anObject! ! !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: 'accessing' stamp: 'tween 8/16/2007 20:29'! slantValue: anObject "Set the value of slantValue" slantValue := anObject! ! !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: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'! stretchValue: anObject "Set the value of stretchValue" stretchValue := 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:29'! weightName: anObject "Set the value of weightName" weightName := 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'! weightValue: anObject "Set the value of weightValue" weightValue := anObject! ! !FreeTypeFontFamilyMember methodsFor: 'comparing' stamp: 'tween 8/16/2007 23:23'! <= aFreeTypeFontFamilyMember ^self sortValue <= aFreeTypeFontFamilyMember sortValue! ! !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: 'copying' stamp: 'tween 9/29/2007 12:49'! asSimulatedBold ^self copy weightValue: LogicalFont weightBold; styleName: (fileInfo styleNameWithWeightForcedToBe: 'Bold'); simulated: true; yourself! ! !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 class instanceVariableNames: ''! !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 ! ! FontProviderAbstract subclass: #FreeTypeFontProvider instanceVariableNames: 'fileInfos fileInfoCache tempFileInfos embeddedFileInfoCache families tempFamilies' classVariableNames: '' poolDictionaries: '' category: 'FreeType-FontManager'! !FreeTypeFontProvider commentStamp: '' prior: 0! 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: 'accessing' stamp: 'tween 3/16/2007 12:39'! addFileInfo: aFreeTypeFileInfo index: i fileInfos add: aFreeTypeFileInfo ! ! !FreeTypeFontProvider methodsFor: 'accessing' stamp: 'tween 7/28/2007 13:28'! addFirstFileInfo: aFreeTypeFileInfo index: i fileInfos addFirst: aFreeTypeFileInfo ! ! !FreeTypeFontProvider methodsFor: 'accessing' stamp: 'CamilloBruni 7/15/2012 19:18'! 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 isNil ifTrue:[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: 'accessing' stamp: 'CamilloBruni 7/15/2012 19:18'! cacheEmbeddedFileInfo: aFreeTypeEmbeddedFileInfo index: i (embeddedFileInfoCache at:{aFreeTypeEmbeddedFileInfo fileSize. i} ifAbsentPut:[ Set new ]) add: aFreeTypeEmbeddedFileInfo ! ! !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: '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: '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: '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: 'file paths' stamp: 'lr 3/14/2010 21:13'! 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: '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: '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: 'file paths' stamp: 'CamilloBruni 7/15/2012 18:54'! platformAbsoluteDirectories OSPlatform isWin32 ifTrue: [ ^ self winFontDirectories ]. OSPlatform isUnix ifTrue: [ ^ self unixFontDirectories ]. OSPlatform isMacOSX ifTrue: [ ^ self macOSXFolderDirectories ]. ^ {}! ! !FreeTypeFontProvider methodsFor: 'file paths' stamp: 'CamilloBruni 7/15/2012 18:52'! platformImageRelativeDirectories | directory | directory := Smalltalk imagePath asFileReference / 'Fonts'. 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: '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: '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: '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: '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: 'font families' stamp: 'tween 8/18/2007 14:19'! families ^tempFamilies ifNil:[families]! ! !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: '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: 'initialize-release' 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 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: 'loading and updating' stamp: 'tween 3/14/2007 23:17'! loadFromSystem self updateFromSystem. ! ! !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: '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: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: 'loading and updating' stamp: 'CamilloBruni 7/15/2012 19:31'! updateFontsFromSystem | done | FT2Library current ifNil: [ ^ 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: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: 'loading and updating' stamp: 'CamilloBruni 7/15/2012 19:09'! 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 isNil ifTrue:[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 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: '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: '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 class instanceVariableNames: 'current'! !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: '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 ! ! AbstractFontSelectorDialogWindow subclass: #FreeTypeFontSelectorDialogWindow instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Windows'! !FreeTypeFontSelectorDialogWindow commentStamp: 'LaurentLaffont 4/15/2011 20:19' prior: 0! 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: '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: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: 'gvc 4/21/2009 17:49'! newFontStyleButtonRowMorph "Answer a new font style button row morph." ^self newRow: { self newBoldButtonMorph. self newItalicButtonMorph}! ! !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]! ! Object subclass: #FreeTypeGlyphRenderer instanceVariableNames: '' classVariableNames: '' poolDictionaries: 'FT2Constants' category: 'FreeType-GlyphRendering'! !FreeTypeGlyphRenderer commentStamp: 'tween 4/4/2007 09:48' prior: 0! This class produces glyphs for a FreeTypeFont. It can be subclassed to provide, for example, sub-pixel anti-aliased glyphs.! !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 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: '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: '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: '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: '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 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 class instanceVariableNames: 'current'! !FreeTypeGlyphRenderer class methodsFor: 'accessing' stamp: 'tween 4/4/2007 09:50'! current: aKindOfFreeTypeGlyphRender current := aKindOfFreeTypeGlyphRender! ! !FreeTypeGlyphRenderer class methodsFor: 'instance creation' stamp: 'tween 4/4/2007 19:24'! current " FreeTypeGlyphRenderer current " ^current ifNil:[current := self new]! ! Object subclass: #FreeTypeNameParser instanceVariableNames: 'combinedName familyNameIn styleNameIn delimiters tokens extractedSlant extractedSlantValue extractedUpright extractedStretch extractedWeight italicFlag boldFlag extractedWeightValue extractedStretchValue' classVariableNames: '' poolDictionaries: '' category: 'FreeType-FontManager'! !FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/12/2007 20:14'! boldFlag: aBoolean boldFlag := aBoolean! ! !FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/16/2007 21:32'! extractedSlant ^extractedSlant! ! !FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/16/2007 21:33'! extractedSlantValue ^extractedSlantValue! ! !FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/12/2007 12:29'! extractedStretch ^extractedStretch! ! !FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/16/2007 00:55'! extractedStretchValue ^extractedStretchValue! ! !FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/16/2007 01:16'! extractedUpright ^extractedUpright! ! !FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/12/2007 12:29'! extractedWeight ^extractedWeight! ! !FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/16/2007 00:55'! extractedWeightValue ^extractedWeightValue! ! !FreeTypeNameParser methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 1/8/2012 14:44'! familyName ^combinedName trimBoth! ! !FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/11/2007 18:06'! familyName: familyName familyNameIn := familyName. ! ! !FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/11/2007 23:39'! familyNameIn: familyName familyNameIn := familyName. ! ! !FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/12/2007 20:14'! italicFlag: aBoolean italicFlag := aBoolean! ! !FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/11/2007 18:06'! styleName: styleName styleNameIn := styleName. ! ! !FreeTypeNameParser methodsFor: 'accessing' stamp: 'tween 8/11/2007 23:39'! styleNameIn: styleName styleNameIn := styleName. ! ! !FreeTypeNameParser methodsFor: 'initialize-release' stamp: 'alain.plantec 5/28/2009 09:55'! initialize super initialize. delimiters := ',.-:='. Character separators do:[:c | delimiters := delimiters , c asString]. ! ! !FreeTypeNameParser methodsFor: 'known names' stamp: 'tween 8/16/2007 02:54'! italicAndObliqueNames ^self class italicAndObliqueNames! ! !FreeTypeNameParser methodsFor: 'known names' stamp: 'tween 8/16/2007 02:12'! italicNames ^self class italicNames! ! !FreeTypeNameParser methodsFor: 'known names' stamp: 'tween 8/25/2007 13:28'! normalNames ^self class normalNames ! ! !FreeTypeNameParser methodsFor: 'known names' stamp: 'tween 9/29/2007 11:41'! stretchNames ^self class stretchNames! ! !FreeTypeNameParser methodsFor: 'known names' stamp: 'tween 9/29/2007 11:41'! weightNames ^self class weightNames ! ! !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: '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: '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: '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: '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: '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: '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: 'parsing' stamp: 'CamilloBruni 11/2/2012 15:33'! 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 class instanceVariableNames: 'weightNames stretchNames obliqueNames normalNames italicNames'! !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').! ! !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'}. } ! ! Object subclass: #FreeTypeSettings instanceVariableNames: 'gamma hinting lightHinting subPixelAntiAliasing forceAutoHinting lcdHinting lcdvHinting monoHinting bitBltSubPixelAvailable subPixelFilters forceNonSubPixelCount gammaTable gammaInverseTable' classVariableNames: 'UpdateFontsAtImageStartup' poolDictionaries: 'FT2Constants FreeTypeCacheConstants' category: 'FreeType-Settings'! !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: 'tween 3/30/2007 18:04'! clearBitBltSubPixelAvailable bitBltSubPixelAvailable := nil.! ! !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 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: '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 11/27/2009 09:13'! gamma ^gamma ifNil:[gamma := 1.0] ! ! !FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:25'! gammaInverseTable ^gammaInverseTable! ! !FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:25'! gammaTable ^gammaTable! ! !FreeTypeSettings methodsFor: 'accessing' stamp: 'AlainPlantec 11/26/2009 22:22'! glyphContrast ^ 100 - ((self gamma sqrt * 100) - 50)! ! !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:13'! hinting ^hinting ifNil:[hinting := true]! ! !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: '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: '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:15'! lcdHinting ^lcdHinting ifNil:[lcdHinting := false]! ! !FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:15'! lcdvHinting ^lcdvHinting ifNil:[lcdvHinting := false]! ! !FreeTypeSettings methodsFor: 'accessing' stamp: 'tween 3/30/2007 18:16'! lightHinting ^lightHinting ifNil:[lightHinting := 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: '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:17'! monoHinting ^monoHinting ifNil:[monoHinting := false]! ! !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: '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: '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:20'! subPixelAntiAliasing self bitBltSubPixelAvailable ifFalse:[^false]. self forceNonSubPixelCount > 0 ifTrue:[^false]. ^subPixelAntiAliasing ifNil:[false]! ! !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: '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 class instanceVariableNames: 'current'! !FreeTypeSettings class methodsFor: 'class initialization' stamp: 'MarcusDenker 3/17/2012 10:04'! initialize " self initialize " Smalltalk removeFromStartUpList: self. Smalltalk addToStartUpList: self . ! ! !FreeTypeSettings class methodsFor: 'instance creation' stamp: 'tween 3/30/2007 17:54'! current current == nil ifFalse:[^current]. ^current := self new! ! !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: '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]]! ! FreeTypeGlyphRenderer subclass: #FreeTypeSubPixelAntiAliasedGlyphRenderer instanceVariableNames: '' classVariableNames: '' poolDictionaries: 'FT2Constants' category: 'FreeType-GlyphRendering'! !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: '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: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 instanceVariableNames: ''! !FreeTypeSubPixelAntiAliasedGlyphRenderer class methodsFor: 'class initialization' stamp: 'AlainPlantec 1/5/2010 11:44'! initialize " self initialize " FreeTypeGlyphRenderer current: self new. ! ! Object subclass: #FreeTypeSystemSettings instanceVariableNames: '' classVariableNames: 'LoadFT2Library' poolDictionaries: '' category: 'Settings-FreeType'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! FreeTypeSystemSettings class instanceVariableNames: ''! !FreeTypeSystemSettings class methodsFor: 'settings' stamp: 'AlainPlantec 9/17/2011 17:03'! freeTypeSettingsOn: aBuilder (aBuilder setting: #noFt2Library) target: self; icon: UITheme current 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: UITheme current 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: 'AlainPlantec 9/17/2011 16:13'! ft2LibraryVersion ^ UITheme current newLabelIn: World for: self label: 'Available version: ', FT2Version current libraryVersion asString getEnabled: nil.! ! !FreeTypeSystemSettings class methodsFor: 'settings' stamp: 'AlainPlantec 9/17/2011 16:09'! loadFt2Library ^ LoadFT2Library ifNil: [LoadFT2Library := false] ! ! !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: 'AlainPlantec 9/17/2011 15:50'! noFt2Library ^ 'Free type fonts are not available'! ! HierarchicalUrl subclass: #FtpUrl instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Network-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 instanceVariableNames: ''! !FtpUrl class methodsFor: 'constants' stamp: 'SeanDeNigris 8/26/2012 15:32'! schemeName ^ 'ftp'.! ! Morph subclass: #FullscreenMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !FullscreenMorph commentStamp: 'gvc 5/18/2007 13:04' prior: 0! Provides for another morph to occupy the full screen area (less docking bars).! !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 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:21'! edgeToAdhereTo "Must implement. Answer #none." ^#none! ! !FullscreenMorph methodsFor: 'as yet unclassified' 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:15'! isAdheringToBottom "Must implement. Answer false." ^false! ! !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 9/14/2006 16:15'! isAdheringToRight "Must implement. Answer false." ^false! ! !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 9/14/2006 16:11'! isDockingBar "Answer yes so we get updated when the Display is resized." ^true! ! !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 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: '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/15/2006 09:04'! openInWorld: aWorld "Open as is." ^self openAsIsIn: aWorld! ! !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 19:27'! updateBounds "Update the receiver's bounds to fill the world." self bounds: self owner clearArea ! ! LabelMorph subclass: #FuzzyLabelMorph instanceVariableNames: 'offset alpha' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !FuzzyLabelMorph commentStamp: 'gvc 5/18/2007 13:16' prior: 0! 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: 'accessing' stamp: 'gvc 3/26/2007 16:57'! alpha "Answer the value of alpha" ^ alpha! ! !FuzzyLabelMorph methodsFor: 'accessing' stamp: 'gvc 8/9/2007 12:51'! alpha: anObject "Set the value of alpha" alpha := anObject. self changed! ! !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: '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: '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: 'gvc 8/9/2007 12:52'! initialize "Initialize the receiver." offset := 1. alpha := 0.5. super initialize! ! !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: '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))! ! EncodedCharSet subclass: #GB2312 instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Multilingual-Encodings'! !GB2312 commentStamp: 'yo 10/19/2004 19:52' prior: 0! This class represents the domestic character encoding called GB 2312 used for simplified Chinese. ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GB2312 class instanceVariableNames: ''! !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'! initialize " GB2312 initialize " compoundTextSequence := String streamContents: [ :stream | stream nextPut: Character escape. stream nextPut: $$. stream nextPut: $(. stream nextPut: $A ]! ! !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: 'yo 10/22/2002 19:51'! leadingChar ^ 2. ! ! !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/14/2003 10:19'! ucsTable ^ UCSTable gb2312Table. ! ! ImageReadWriter subclass: #GIFReadWriter instanceVariableNames: 'width height bitsPerPixel colorPalette rowByteSize xpos ypos pass interlace codeSize clearCode eoiCode freeCode maxCode prefixTable suffixTable remainBitCount bufByte bufStream transparentIndex mapOf32 localColorTable delay loopCount offset' classVariableNames: 'Extension ImageSeparator Terminator' poolDictionaries: '' category: 'Graphics-Files'! !GIFReadWriter commentStamp: '' prior: 0! Copyright (c) Kazuki Yasumatsu, 1995. All rights reserved. Used with permission. Modified for use in Squeak.! !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: '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: '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: '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: 'accessing' stamp: 'lr 7/4/2009 10:42'! setStream: aStream "Feed it in from an existing source" stream := aStream! ! !GIFReadWriter methodsFor: 'accessing' stamp: 'di 9/15/1998 09:53'! understandsImageFormat ^('abc' collect: [:x | stream next asCharacter]) = 'GIF'! ! !GIFReadWriter methodsFor: 'stream access' stamp: 'bf 5/29/2003 01:23'! close "Write terminator" self nextPut: Terminator. ^super close! ! !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' 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: '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-bits access' stamp: 'lr 7/4/2009 10:42'! flushBits remainBitCount = 0 ifFalse: [ self nextBytePut: bufByte. remainBitCount := 0 ]. self flushBuffer! ! !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: '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-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-decoding' stamp: 'lr 7/4/2009 10:42'! 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 isNil ifTrue: [ form := self readBitData ] ifFalse: [ 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-decoding'! readCode ^self nextBits! ! !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-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: 'private-decoding'! readWord ^self next + (self next bitShift: 8)! ! !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-encoding'! flushCode self flushBits! ! !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: '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: 'private-encoding'! writeCode: aCode self nextBitsPut: aCode! ! !GIFReadWriter methodsFor: 'private-encoding'! writeCodeAndCheckCodeSize: aCode self writeCode: aCode. self checkCodeSize! ! !GIFReadWriter methodsFor: 'private-encoding' stamp: 'lr 7/4/2009 10:42'! 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 isNil ifTrue: [ 0 ] ifFalse: [ 9 ]); writeWord: (delay isNil ifTrue: [ 0 ] ifFalse: [ delay ]); nextPut: (transparentIndex isNil ifTrue: [ 0 ] ifFalse: [ transparentIndex ]); 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-encoding'! writeWord: aWord self nextPut: (aWord bitAnd: 255). self nextPut: ((aWord bitShift: -8) bitAnd: 255). ^aWord! ! !GIFReadWriter methodsFor: 'private-packing' stamp: 'damiencassou 5/30/2008 14:51'! fillBuffer | packSize | packSize := self next. bufStream := (self next: packSize) readStream! ! !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: 'private-packing'! nextByte bufStream atEnd ifTrue: [self atEnd ifTrue: [^nil]. self fillBuffer]. ^bufStream next! ! !GIFReadWriter methodsFor: 'private-packing'! nextBytePut: aByte bufStream nextPut: aByte. bufStream size >= 254 ifTrue: [self flushBuffer]! ! !GIFReadWriter methodsFor: 'private-packing'! peekByte bufStream atEnd ifTrue: [self atEnd ifTrue: [^nil]. self fillBuffer]. ^bufStream peek! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GIFReadWriter class instanceVariableNames: ''! !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: 'examples' stamp: 'CamilloBruni 5/4/2012 20:26'! grabScreenAndSaveOnDisk "GIFReadWriter grabScreenAndSaveOnDisk" | form fileName | form := Form fromUser. form bits size = 0 ifTrue: [ ^ Beeper beep ]. fileName := (FileSystem disk workingDirectory / 'Pharo', 'gif') fullName. UIManager default informUser: 'Writing ' translated, fileName during: [ GIFReadWriter putForm: form onFileNamed: fileName ]! ! !GIFReadWriter class methodsFor: 'image reading/writing' stamp: 'asm 12/11/2003 21:29'! typicalFileExtensions "Answer a collection of file extensions (lowercase) which files that I can read might commonly have" self allSubclasses detect: [:cls | cls wantsToHandleGIFs ] ifNone: ["if none of my subclasses wants , then i''ll have to do" ^ #('gif' )]. ^ #( )! ! !GIFReadWriter class methodsFor: 'image reading/writing' stamp: 'asm 12/11/2003 21:29'! wantsToHandleGIFs ^ false! ! !GIFReadWriter class methodsFor: 'initialization' stamp: 'lr 7/4/2009 10:42'! initialize "GIFReadWriter initialize" ImageSeparator := $, asInteger. Extension := $!! asInteger. Terminator := $; asInteger! ! SharedPool subclass: #GZipConstants instanceVariableNames: '' classVariableNames: 'GZipAsciiFlag GZipCommentFlag GZipContinueFlag GZipDeflated GZipEncryptFlag GZipExtraField GZipMagic GZipNameFlag GZipReservedFlags' poolDictionaries: '' category: 'Compression-Streams'! !GZipConstants commentStamp: '' prior: 0! 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 instanceVariableNames: ''! !GZipConstants class methodsFor: 'pool initialization' stamp: 'ar 5/18/2003 19:00'! gzipMagic ^GZipMagic! ! !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" ! ! FastInflateStream subclass: #GZipReadStream instanceVariableNames: '' classVariableNames: '' poolDictionaries: 'GZipConstants' category: 'Compression-Streams'! !GZipReadStream commentStamp: '' prior: 0! 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 instanceVariableNames: ''! !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: '*System-FileRegistry' stamp: 'tbn 8/11/2010 10:29'! serviceDecompressToFile ^ FileModifyingSimpleServiceEntry provider: self label: 'Decompress to file' selector: #saveContents: description: 'Decompress to file'! ! !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: '*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: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: '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: '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: '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: '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: '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: 'initialization' stamp: 'IgorStasenko 3/6/2011 18:53'! unload Smalltalk tools fileList unregisterFileReader: self ! ! !GZipReadStream class methodsFor: 'unzipping' stamp: 'StephaneDucasse 7/31/2012 23:05'! 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: 'unzipping' stamp: 'StephaneDucasse 7/31/2012 23:05'! 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 ensureDirectory. unzipped := FileStream newFileNamed: (pathString asFileReference / newName) fullName. unzipped isNil ifTrue: [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! ! ZipWriteStream subclass: #GZipWriteStream instanceVariableNames: '' classVariableNames: '' poolDictionaries: 'GZipConstants' category: 'Compression-Streams'! !GZipWriteStream commentStamp: '' prior: 0! gzip is an integral part of the VM. ! !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 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 class instanceVariableNames: ''! !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: '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'! ! !GZipWriteStream class methodsFor: '*System-FileRegistry' stamp: 'nk 11/26/2002 13:10'! services ^ { self serviceCompressFile }! ! !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: '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! ! ScrollBar subclass: #GeneralScrollBar instanceVariableNames: 'showState' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !GeneralScrollBar commentStamp: 'gvc 5/18/2007 13:01' prior: 0! Support for GeneralScrollPane.! !GeneralScrollBar methodsFor: 'accessing' stamp: 'GaryChambers 11/16/2011 13:30'! showAlways "Set the scrollbar to be always shown." self showState: #always! ! !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:26'! showState ^ showState! ! !GeneralScrollBar methodsFor: 'accessing' stamp: 'GaryChambers 11/16/2011 13:26'! showState: anObject showState := anObject! ! !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'! showsAlways "Answer whether the scrollbar should always be shown." ^self showState == #always! ! !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:28'! showsWhenNeeded "Answer whether the scrollbar should be shown if needed." ^self showState == #whenNeeded! ! !GeneralScrollBar methodsFor: 'initialize-release' stamp: 'GaryChambers 11/16/2011 13:29'! initialize "Initialize the receiver." super initialize. self showWhenNeeded! ! !GeneralScrollBar methodsFor: 'model access' stamp: 'gvc 9/7/2006 13:45'! setValue: newValue "Bypass screwed up scrollbar!!" ^self perform: #setValue: withArguments: {newValue} inSuperclass: Slider! ! Morph subclass: #GeneralScrollPane instanceVariableNames: 'scroller hScrollbar vScrollbar' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !GeneralScrollPane commentStamp: 'gvc 5/18/2007 13:01' prior: 0! A scroll pane that handles its contents accurately.! !GeneralScrollPane methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/28/2008 16:49'! handlesMouseWheel: evt "Do I want to receive mouseWheel events?." ^true! ! !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: '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: 'accessing' stamp: 'gvc 9/7/2006 10:16'! hScrollbar: anObject "Set the value of hScrollbar" hScrollbar := anObject! ! !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 09:40'! scroller: anObject "Set the value of scroller" scroller := anObject! ! !GeneralScrollPane methodsFor: 'accessing' stamp: 'gvc 9/7/2006 10:16'! vScrollbar "Answer the value of vScrollbar" ^ vScrollbar! ! !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: '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: '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 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: '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 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 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: '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: '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: '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: '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: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: '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: '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: '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 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: 'IgorStasenko 7/22/2011 19:07'! newHScrollbar "Answer a new horizontal scrollbar." ^GeneralScrollBar new model: self accessor: #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: 'IgorStasenko 7/22/2011 19:07'! newVScrollbar "Answer a new vertical scrollbar." ^GeneralScrollBar new model: self accessor: #vScrollbarValue! ! !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: '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: '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 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: 'as yet unclassified' stamp: 'gvc 9/7/2006 09:48'! scrollTarget "Answer the morph that is scrolled." ^self scroller submorphs first! ! !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! ! !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: '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: '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 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 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 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 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 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: '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: '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:34'! vScrollbarShowAlways "Set the vertical scrollbar to always show." self vScrollbar showAlways. self updateScrollbars! ! !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: 'as yet unclassified' stamp: 'gvc 9/7/2006 10:15'! vScrollbarShowing "Answer whether the vertical scrollbar is showing." ^self vScrollbar 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 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: '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 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 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: 'event handling' stamp: 'gvc 9/7/2006 12:16'! handlesKeyboard: evt "Yes for page up/down." ^true! ! !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: '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: 'initialize' stamp: 'gvc 9/7/2006 12:23'! defaultColor "Answer the default color/fill style for the receiver." ^ Color transparent! ! !GeneralScrollPane methodsFor: 'initialize' 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: '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: '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: '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]! ! Stream subclass: #Generator instanceVariableNames: 'block next continue home' classVariableNames: '' poolDictionaries: '' category: 'Collections-Streams'! !Generator commentStamp: 'ar 2/10/2010 20:51' prior: 0! 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: '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: '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: '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: '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: 'lr 2/10/2010 09:16'! peek "Answer the upcoming object of the receiver." ^ next! ! !Generator methodsFor: 'accessing' stamp: 'lr 2/10/2010 09:16'! size "A generator does not know its size." ^ self shouldNotImplement! ! !Generator methodsFor: 'initialization' stamp: 'lr 1/8/2009 16:18'! initializeOn: aBlock block := aBlock. self reset! ! !Generator methodsFor: 'printing' stamp: 'lr 1/8/2009 16:21'! printOn: aStream aStream nextPutAll: self class name; nextPutAll: ' on: '; print: block! ! !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: '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: '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: 'testing' stamp: 'ar 2/10/2010 21:00'! atEnd "Answer whether the receiver can access any more objects." ^ continue isNil! ! !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 class instanceVariableNames: ''! !Generator class methodsFor: 'instance-creation' stamp: 'lr 1/8/2009 15:54'! on: aBlock ^ self basicNew initializeOn: aBlock! ! TestCase subclass: #GeneratorTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Streams'! !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: '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: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 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 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:45'! testEmpty | generator | generator := Generator on: [ :g | ]. self assert: generator atEnd. self assert: generator peek isNil. self assert: generator next isNil! ! !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: 'ar 2/10/2010 21:01'! testErrorPropagation "Ensure that errors in the generator block are properly propagated" | generator | self shouldnt:[generator := Generator on: [ :g | g yield: 1. g error: 'yo']] raise: Error. self should:[generator next] raise: Error. ! ! !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: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: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: '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 1/8/2009 16:46'! testSimple | generator | generator := Generator on: [ :g | g yield: 1; yield: 2 ]. self assert: generator upToEnd asArray = #( 1 2 )! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GeneratorTest class instanceVariableNames: ''! !GeneratorTest class methodsFor: 'accessing' stamp: 'lr 2/10/2010 08:34'! packageNamesUnderTest ^ #('Generator')! ! Url subclass: #GenericUrl instanceVariableNames: 'schemeName locator' classVariableNames: '' poolDictionaries: '' category: 'Network-Url'! !GenericUrl commentStamp: '' prior: 0! 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: 'access' stamp: 'ls 6/20/1998 19:46'! locator ^locator! ! !GenericUrl methodsFor: 'access' stamp: 'ls 6/20/1998 19:46'! schemeName ^schemeName! ! !GenericUrl methodsFor: 'classification' stamp: 'FBS 11/20/2003 13:39'! scheme ^ self schemeName.! ! !GenericUrl methodsFor: 'parsing' stamp: 'CamilloBruni 12/16/2011 11:24'! privateInitializeFromText: aString schemeName := Url 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: 'private' stamp: 'ls 6/20/1998 19:46'! schemeName: schemeName0 locator: locator0 schemeName := schemeName0. locator := locator0.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GenericUrl class instanceVariableNames: ''! !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: 'ls 7/26/1998 21:24'! absoluteFromText: aString | schemeName locator | schemeName := Url schemeNameForString: aString. schemeName ifNil: [ ^self schemeName: 'xnoscheme' locator: aString ]. locator := aString copyFrom: (schemeName size + 2) to: aString size. ^self schemeName: schemeName locator: locator! ! ClassTestCase subclass: #GenericUrlTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetworkTests-Url'! !GenericUrlTest methodsFor: 'testing' stamp: 'fbs 2/2/2005 12:56'! testAsString | url | url := GenericUrl new schemeName: 'sip' locator: 'foo@bar'. self assert: url asString = 'sip:foo@bar'.! ! Form subclass: #GlyphForm instanceVariableNames: 'advance linearAdvance' classVariableNames: '' poolDictionaries: '' category: 'FreeType-Fonts'! !GlyphForm methodsFor: 'accessing' stamp: 'tween 4/23/2006 20:54'! advance ^advance! ! !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 ^linearAdvance ! ! !GlyphForm methodsFor: 'accessing' stamp: 'tween 8/6/2006 21:10'! linearAdvance: aNumber ^linearAdvance := aNumber! ! !GlyphForm methodsFor: 'converting' stamp: 'tween 8/6/2006 21:57'! asFormOfDepth: d | newForm | d = self depth ifTrue:[^self]. newForm := self class extent: self extent depth: d. (BitBlt current 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! ! RotatingStringMorph subclass: #GoBackStringMorph instanceVariableNames: 'index frontward wait' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon'! !GoBackStringMorph commentStamp: '' prior: 0! 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: '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 ]! ! !GoBackStringMorph methodsFor: 'private' stamp: 'CT 1/8/2013 18:55'! currentContentsLargeEnough ^(self font widthOfString: self contents) <= (self ownerChain collect: [ :morph | morph extent x ]) min! ! Object subclass: #Gofer instanceVariableNames: 'references repositories errorBlock packageCacheRepository resolvedReferencesCache' classVariableNames: '' poolDictionaries: '' category: 'Gofer-Core'! !Gofer commentStamp: 'lr 1/30/2010 14:42' prior: 0! : 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: '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: '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: 'accessing' stamp: 'lr 12/13/2009 17:18'! references "Answer the configured references." ^ Array withAll: references! ! !Gofer methodsFor: 'accessing' stamp: 'lr 12/13/2009 17:18'! repositories "Answer the configured monticello repositories." | result | result := OrderedCollection withAll: repositories. packageCacheRepository isNil ifFalse: [ result addFirst: packageCacheRepository ]. ^ result asArray! ! !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: 'copying' stamp: 'lr 12/13/2009 16:52'! postCopy references := references copy. repositories := repositories copy. resolvedReferencesCache := nil! ! !Gofer methodsFor: 'deprecated' stamp: 'StephaneDucasse 4/25/2012 16:18'! addPackage: aPackage self package: aPackage! ! !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 10/3/2009 11:31'! cleanup "Cleans the specified packages." ^ self execute: GoferCleanup! ! !Gofer methodsFor: 'operations' stamp: 'lr 11/10/2009 10:08'! commit "Commit the modified packages." ^ self execute: GoferCommit! ! !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/3/2009 21:06'! fetch "Download versions from remote repositories into the local cache." ^ self execute: GoferFetch! ! !Gofer methodsFor: 'operations' stamp: 'lr 11/30/2009 14:17'! load "Load the specified packages into the image." ^ self execute: GoferLoad! ! !Gofer methodsFor: 'operations' stamp: 'CamilloBruni 9/18/2012 18:58'! loadDevelopment "Load the development version of the previously specifed configuration." ^ self execute: GoferMetacelloLoadDevelopment! ! !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: '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: '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: 'operations' stamp: 'lr 11/10/2009 10:06'! merge "Merge the specified packages into their working copies." ^ self execute: GoferMerge! ! !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: 'operations' stamp: 'lr 8/20/2009 11:44'! recompile "Recompile the specified packages." ^ self execute: GoferRecompile! ! !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: '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: '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/10/2009 10:07'! unload "Unload the specified packages." ^ self execute: GoferUnload! ! !Gofer methodsFor: 'operations' stamp: 'lr 9/18/2009 18:12'! update "Update the specified packages." ^ self execute: GoferUpdate! ! !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: '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: '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: '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: '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: '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: '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: '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: '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' 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' 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 methodsFor: 'repositories-options' stamp: 'lr 12/13/2009 16:33'! disablePackageCache "Disable the use of the package-cache repository." packageCacheRepository := nil! ! !Gofer methodsFor: 'repositories-options' stamp: 'lr 12/13/2009 16:32'! disableRepositoryErrors "Silently swallow all repository errors." errorBlock := [ :error | error resume: #() ]! ! !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: 'repositories-options' stamp: 'lr 12/13/2009 16:32'! enableRepositoryErrors "Throw an exception when repositories are not available." errorBlock := [ :error | error pass ]! ! !Gofer methodsFor: 'repositories-places' stamp: 'lr 2/7/2010 15:11'! blueplane: aString self url: 'http://squeaksource.blueplane.jp/' , aString! ! !Gofer methodsFor: 'repositories-places' stamp: 'dkh 10/16/2009 10:04'! gemsource: aString self url: 'http://seaside.gemstone.com/ss/' , aString! ! !Gofer methodsFor: 'repositories-places' stamp: 'lr 7/10/2009 16:27'! impara: aString self url: 'http://source.impara.de/' , aString! ! !Gofer methodsFor: 'repositories-places' stamp: 'lr 7/10/2009 16:25'! renggli: aString self url: 'http://source.lukas-renggli.ch/' , aString! ! !Gofer methodsFor: 'repositories-places' stamp: 'CamilloBruni 9/18/2012 18:27'! smalltalkhubUser: aUserName project: aProjectName self repository: (MCSmalltalkhubRepository owner: aUserName project: aProjectName)! ! !Gofer methodsFor: 'repositories-places' stamp: 'lr 7/10/2009 16:28'! squeakfoundation: aString self url: 'http://source.squeakfoundation.org/' , aString! ! !Gofer methodsFor: 'repositories-places' stamp: 'CamilloBruni 9/18/2012 18:28'! squeaksource3: aProjectName self repository: (MCGemstoneRepository location: 'http://ss3.gemstone.com/ss/' , aProjectName)! ! !Gofer methodsFor: 'repositories-places' stamp: 'CamilloBruni 9/18/2012 18:29'! squeaksource: aProjectName self repository: (MCSqueaksourceRepository location: 'http://www.squeaksource.com/' , aProjectName)! ! !Gofer methodsFor: 'repositories-places' stamp: 'lr 7/10/2009 16:26'! wiresong: aString self url: 'http://source.wiresong.ca/' , aString! ! !Gofer methodsFor: 'private' stamp: 'lr 12/13/2009 16:28'! basicReferencesIn: aRepository ^ [ aRepository goferReferences asSortedCollection asArray ] on: GoferRepositoryError do: errorBlock! ! !Gofer methodsFor: 'private' stamp: 'lr 10/2/2009 10:11'! execute: anOperationClass ^ self execute: anOperationClass do: nil! ! !Gofer methodsFor: 'private' stamp: 'lr 12/13/2009 16:43'! execute: anOperationClass do: aBlock | operation result | operation := anOperationClass on: self copy. aBlock isNil ifFalse: [ aBlock value: operation ]. ^ operation execute! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Gofer class instanceVariableNames: ''! !Gofer class methodsFor: 'instance creation' stamp: 'lr 11/6/2009 10:50'! it ^ self new! ! !Gofer class methodsFor: 'instance creation' stamp: 'lr 8/20/2009 09:54'! new ^ self basicNew initialize! ! !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: '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! ! GoferTest subclass: #GoferApiTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Gofer-Tests'! !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' stamp: 'lr 12/13/2009 17:40'! testInitialReferences self assert: gofer references isEmpty! ! !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-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)! ! !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-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' 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: '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: '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-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' 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' 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-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-options' stamp: 'MarcusDenker 12/8/2011 10:47'! 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. self shouldnt: [ gofer resolved ] raise: GoferRepositoryError! ! !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-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'! testImpara gofer impara: 'Tweak'. self assert: gofer repositories: #('http://source.impara.de/Tweak')! ! !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-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'! testSqueakfoundation gofer squeakfoundation: '39a'. self assert: gofer repositories: #('http://source.squeakfoundation.org/39a')! ! !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-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 ]! ! GoferLocalChanges subclass: #GoferBrowseLocalChanges instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Gofer-Core'! !GoferBrowseLocalChanges methodsFor: 'running' stamp: 'lr 12/14/2009 23:50'! execute ^ super execute browse! ! GoferRemoteChanges subclass: #GoferBrowseRemoteChanges instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Gofer-Core'! !GoferBrowseRemoteChanges methodsFor: 'running' stamp: 'lr 12/14/2009 23:50'! execute ^ super execute browse! ! GoferWorking subclass: #GoferChanges instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Gofer-Core'! !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: 'queries' stamp: 'lr 12/12/2009 13:00'! sourceSnapshotOf: aReference "Answer the source snapshot of aReference." self subclassResponsibility! ! !GoferChanges methodsFor: 'queries' stamp: 'lr 12/12/2009 12:59'! targetSnapshotOf: aReference "Answer the source snapshot of aReference." self subclassResponsibility! ! !GoferChanges methodsFor: 'running' stamp: 'lr 12/14/2009 23:50'! execute ^ self model! ! !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: 'private' stamp: 'lr 8/19/2009 14:02'! defaultModel ^ MCPatch operations: OrderedCollection new! ! GoferWorking subclass: #GoferCleanup instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Gofer-Core'! !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'! cleanupCategories: aWorkingCopy aWorkingCopy packageSet systemCategories do: [ :category | (Smalltalk organization classesInCategory: category) isEmpty ifTrue: [ Smalltalk organization removeSystemCategory: category ] ]! ! !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: 'running' stamp: 'lr 10/3/2009 11:30'! execute self workingCopies do: [ :each | self cleanup: each ]! ! GoferWorking subclass: #GoferCommit instanceVariableNames: 'message' classVariableNames: '' poolDictionaries: '' category: 'Gofer-Core'! !GoferCommit methodsFor: 'accessing' stamp: 'lr 10/2/2009 10:12'! message ^ message! ! !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 ]! ! !GoferCommit methodsFor: 'running' stamp: 'lr 12/27/2009 17:21'! execute: aWorkingCopy | repositories version | repositories := self gofer repositories reject: [ :repository | (aWorkingCopy changesRelativeToRepository: repository) isEmpty ]. repositories isEmpty ifTrue: [ ^ self ]. version := [ aWorkingCopy newVersion ] on: MCVersionNameAndMessageRequest do: [ :notifcation | self message isNil ifTrue: [ message := notifcation outer last ]. notifcation resume: (Array with: notifcation suggestedName with: self message) ]. self gofer repositories do: [ :repository | repository storeVersion: version ]! ! !GoferCommit methodsFor: 'running' stamp: 'lr 12/13/2009 19:20'! initializeOn: aGofer super initializeOn: aGofer disablePackageCache! ! GoferPackageReference subclass: #GoferConfigurationReference instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Gofer-Core'! !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: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: 'accessing' stamp: 'CamilloBruni 9/18/2012 19:05'! project ^ self configurationClass project! ! !GoferConfigurationReference methodsFor: 'testing' stamp: 'CamilloBruni 9/18/2012 19:05'! isConfigurationReference ^ true! ! GoferPackageReference subclass: #GoferConstraintReference instanceVariableNames: 'constraintBlock' classVariableNames: '' poolDictionaries: '' category: 'Gofer-Core'! !GoferConstraintReference commentStamp: 'lr 1/30/2010 14:37' prior: 0! 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 instanceVariableNames: ''! !GoferConstraintReference class methodsFor: 'instance creation' stamp: 'lr 12/9/2009 22:44'! name: aString constraint: aBlock ^ self basicNew initializeName: aString constraint: aBlock! ! GoferSynchronize subclass: #GoferFetch instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Gofer-Core'! !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'! ! !GoferFetch methodsFor: 'private' stamp: 'lr 11/30/2009 13:46'! defaultModel ^ Set new! ! GoferOperation subclass: #GoferLoad instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Gofer-Core'! !GoferLoad methodsFor: 'accessing' stamp: 'StephaneDucasse 12/30/2012 20:29'! versions ^ model versions! ! !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: 'running' stamp: 'StephaneDucasse 12/30/2012 20:28'! execute self model hasVersions ifTrue: [ self model load ]. self updateRepositories. self updateCategories! ! !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) ]! ! !GoferLoad methodsFor: 'private' stamp: 'lr 9/3/2009 11:00'! defaultModel ^ MCVersionLoader new! ! !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: '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 ] ]! ! GoferChanges subclass: #GoferLocalChanges instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Gofer-Core'! !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! ! !GoferLocalChanges methodsFor: 'queries' stamp: 'lr 12/12/2009 13:01'! targetSnapshotOf: aReference ^ aReference workingCopy package snapshot! ! GoferUpdate subclass: #GoferMerge instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Gofer-Core'! !GoferMerge methodsFor: 'running' stamp: 'CamilloBruni 1/16/2012 15:53'! execute [ self model merge ] on: MCMergeResolutionRequest do: [ :request | request merger conflicts isEmpty ifTrue: [ request resume: true ] ifFalse: [ request pass ]]. self gofer cleanup! ! !GoferMerge methodsFor: 'private' stamp: 'lr 8/19/2009 14:01'! defaultModel ^ MCVersionMerger new! ! GoferLoad subclass: #GoferMetacelloLoad instanceVariableNames: 'version' classVariableNames: '' poolDictionaries: '' category: 'Gofer-Core'! !GoferMetacelloLoad methodsFor: 'accessing' stamp: 'CamilloBruni 9/18/2012 19:00'! configuration ^ self configurationReference project! ! !GoferMetacelloLoad methodsFor: 'accessing' stamp: 'CamilloBruni 9/18/2012 19:14'! configurationReference ^ gofer references detect: [ :ref| ref isConfigurationReference ] ifNone: [ Error signal: 'Could not find a valid ConfigurationReference' ].! ! !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! ! !GoferMetacelloLoad methodsFor: 'running' stamp: 'CamilloBruni 9/18/2012 18:53'! execute super execute. self loadConfiguration.! ! !GoferMetacelloLoad methodsFor: 'running' stamp: 'CamilloBruni 9/21/2012 16:49'! loadConfiguration | configuration metacelloVersion | configuration := self configuration. version ifNotNil: [ metacelloVersion := configuration version: self version ]. metacelloVersion load! ! GoferMetacelloLoad subclass: #GoferMetacelloLoadDevelopment instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Gofer-Core'! !GoferMetacelloLoadDevelopment methodsFor: 'accessing' stamp: 'CamilloBruni 9/18/2012 19:13'! version: aVersionString self shouldNotImplement! ! !GoferMetacelloLoadDevelopment methodsFor: 'initialization' stamp: 'CamilloBruni 10/9/2012 19:30'! initialize super initialize. version := #development.! ! !GoferMetacelloLoadDevelopment methodsFor: 'running' stamp: 'CamilloBruni 10/9/2012 19:34'! loadConfiguration | configuration metacelloVersion | configuration := self configuration project. metacelloVersion := version ifNil: [ configuration stableVersion ] ifNotNil: [ configuration latestVersion: self version ]. metacelloVersion load! ! Object subclass: #GoferOperation instanceVariableNames: 'gofer model' classVariableNames: '' poolDictionaries: '' category: 'Gofer-Core'! !GoferOperation methodsFor: 'accessing' stamp: 'lr 10/3/2009 11:38'! gofer "Answer the Gofer instance that triggered this operation." ^ gofer! ! !GoferOperation methodsFor: 'accessing' stamp: 'lr 8/20/2009 10:13'! model "Answer the Monticello model of this operation." ^ model! ! !GoferOperation methodsFor: 'initialization' stamp: 'lr 8/19/2009 14:01'! initialize model := self defaultModel! ! !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 methodsFor: 'private' stamp: 'lr 8/19/2009 14:01'! defaultModel ^ nil! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GoferOperation class instanceVariableNames: ''! !GoferOperation class methodsFor: 'instance creation' stamp: 'TestRunner 12/12/2009 11:09'! new self error: 'Gofer operations can only work on Gofer instances.'! ! !GoferOperation class methodsFor: 'instance creation' stamp: 'lr 8/20/2009 12:01'! on: aGofer ^ self basicNew initializeOn: aGofer! ! GoferTest subclass: #GoferOperationTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Gofer-Tests'! !GoferOperationTest methodsFor: 'running' stamp: 'EstebanLorenzano 9/12/2012 16:44'! runCase ^ "SystemAnnouncer uniqueInstance suspendAllWhile: [ "super runCase "]"! ! !GoferOperationTest methodsFor: 'running' stamp: 'lr 12/13/2009 17:49'! setUp super setUp. gofer repository: self monticelloRepository! ! !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: 'StephaneDucasse 3/29/2010 17:36'! 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. self shouldnt: [ gofer cleanup ] raise: Error. 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: 'lr 3/16/2010 09:59'! testCommit | repository | repository := MCDictionaryRepository new. gofer package: 'GoferFoo'; load. gofer := Gofer new. gofer disablePackageCache. gofer repository: repository. gofer package: 'GoferFoo'. self shouldnt: [ gofer commit: 'A test commit' ] raise: Error. self assert: repository allVersionInfos size = 1! ! !GoferOperationTest methodsFor: 'testing' stamp: 'lr 3/16/2010 09:59'! testFetch gofer package: 'GoferFoo'. self shouldnt: [ gofer fetch ] raise: Error! ! !GoferOperationTest methodsFor: 'testing' stamp: 'lr 3/16/2010 10:05'! testLoad gofer version: 'GoferFoo-lr.1'. self shouldnt: [ gofer load ] raise: Error. self assert: (self hasVersion: 'GoferFoo-lr.1'). self assert: (self hasClass: #GoferFoo)! ! !GoferOperationTest methodsFor: 'testing' stamp: 'StephaneDucasse 3/16/2010 18:04'! testLocalChanges | changes | gofer package: 'GoferBar'; load. (Smalltalk globals classNamed: #GoferBar) compile: 'foo'. self shouldnt: [ changes := gofer localChanges ] raise: Error. self assert: changes operations size = 1! ! !GoferOperationTest methodsFor: 'testing' stamp: 'PavelKrivanek 3/6/2012 13:20'! testMerge | initial | initial := gofer copy. initial version: 'GoferBar-jf.1'; load. gofer package: 'GoferBar'; load. (Smalltalk globals classNamed: #GoferBar) compile: 'foo'. self shouldnt: [ [gofer merge] on: ProvideAnswerNotification do: [:e | e resume: true] ] raise: Error. self assert: (self hasClass: #GoferBar selector: #foo)! ! !GoferOperationTest methodsFor: 'testing' stamp: 'lr 3/16/2010 10:00'! testPush | repository | gofer := Gofer new. gofer disablePackageCache. gofer repository: (repository := MCDictionaryRepository new). gofer package: 'GoferFoo'. self shouldnt: [ gofer push ] raise: Error! ! !GoferOperationTest methodsFor: 'testing' stamp: 'lr 1/5/2010 11:03'! testRecompile gofer package: 'Gofer-Core'. self shouldnt: [ gofer recompile ] raise: Error! ! !GoferOperationTest methodsFor: 'testing' stamp: 'StephaneDucasse 8/27/2010 10:54'! 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. self shouldnt: [ gofer reinitialize ] raise: Error. self assert: (class classPool at: #InstanceSide) isNil. self assert: (class classPool at: #ClassSide) ! ! !GoferOperationTest methodsFor: 'testing' stamp: 'StephaneDucasse 3/16/2010 18:04'! testRemoteChanges | changes | gofer package: 'GoferBar'; load. (Smalltalk globals classNamed: #GoferBar) compile: 'foo'. self shouldnt: [ changes := gofer remoteChanges ] raise: Error. self assert: changes operations size = 1! ! !GoferOperationTest methodsFor: 'testing' stamp: 'lr 3/14/2010 21:13'! testRevert gofer package: 'GoferFoo'; package: 'GoferBar'; load. (Smalltalk globals classNamed: #GoferBar) category: 'GoferFoo'. self shouldnt: [ gofer revert ] raise: Error. self assert: (Smalltalk globals classNamed: #GoferFoo) category asSymbol = #GoferFoo. self assert: (Smalltalk globals classNamed: #GoferBar) category asSymbol = #GoferBar! ! !GoferOperationTest methodsFor: 'testing' stamp: 'lr 3/16/2010 10:01'! testUnload gofer package: 'GoferFoo'; load. self shouldnt: [ gofer unload ] raise: Error. self deny: (self hasPackage: 'GoferFoo'). self deny: (self hasClass: #GoferFoo)! ! !GoferOperationTest methodsFor: 'testing' stamp: 'lr 3/16/2010 10:05'! testUpdate | initial | initial := gofer copy. initial version: 'GoferFoo-lr.1'; load. gofer package: 'GoferFoo'. self shouldnt: [ gofer update ] raise: Error. self assert: (self hasVersion: 'GoferFoo-lr.4')! ! !GoferOperationTest methodsFor: 'utilities' stamp: 'StephaneDucasse 6/2/2012 20:31'! allManagers ^ MCWorkingCopy allManagers ! ! !GoferOperationTest methodsFor: 'utilities' stamp: 'lr 3/14/2010 21:13'! hasClass: aSymbol ^ Smalltalk globals includesKey: aSymbol! ! !GoferOperationTest methodsFor: 'utilities' stamp: 'lr 3/14/2010 21:13'! hasClass: aSymbol selector: aSelector ^ (Smalltalk globals classNamed: aSymbol) includesSelector: aSelector! ! !GoferOperationTest methodsFor: 'utilities' stamp: 'StephaneDucasse 6/2/2012 20:31'! hasPackage: aString | package | package := self allManagers detect: [ :each | each packageName = aString ] ifNone: [ nil ]. ^ package notNil! ! !GoferOperationTest methodsFor: 'utilities' stamp: 'StephaneDucasse 6/2/2012 20:31'! hasVersion: aString | version | version := self allManagers detect: [ :each | each ancestry ancestorString = aString ] ifNone: [ nil ]. ^ version notNil! ! GoferReference subclass: #GoferPackageReference instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Gofer-Core'! !GoferPackageReference commentStamp: 'lr 12/9/2009 22:47' prior: 0! A GoferPackageReference refers to the latest version of a Monticello package.! !GoferPackageReference methodsFor: 'accessing' stamp: 'lr 12/13/2009 17:12'! packageName ^ name! ! !GoferPackageReference methodsFor: 'private' stamp: 'lr 1/21/2010 00:16'! matches: aResolvedReference ^ self packageName = aResolvedReference packageName! ! GoferSynchronize subclass: #GoferPush instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Gofer-Core'! !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'! ! !GoferPush methodsFor: 'private' stamp: 'lr 11/30/2009 13:46'! defaultModel ^ OrderedCollection new! ! GoferWorking subclass: #GoferRecompile instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Gofer-Core'! !GoferRecompile methodsFor: 'running' stamp: 'lr 12/13/2009 19:12'! execute self workingCopies do: [ :each | self execute: each ]! ! !GoferRecompile methodsFor: 'running' stamp: 'EstebanLorenzano 9/12/2012 13:33'! execute: aWorkingCopy aWorkingCopy packageSet methods do: [ :each | each actualClass recompile: each selector ]! ! Object subclass: #GoferReference instanceVariableNames: 'name' classVariableNames: '' poolDictionaries: '' category: 'Gofer-Core'! !GoferReference commentStamp: 'lr 1/30/2010 14:38' prior: 0! A GoferReference is an abstract superclass for various kinds of references to Monticello packages and versions.! !GoferReference methodsFor: 'accessing' stamp: 'lr 12/11/2009 22:02'! name "Answer the name of this reference." ^ name! ! !GoferReference methodsFor: 'accessing' stamp: 'lr 12/13/2009 17:09'! packageName "Answer the package name." self subclassResponsibility! ! !GoferReference methodsFor: 'comparing' stamp: 'lr 12/12/2009 13:33'! = aReference ^ self class = aReference class and: [ self name = aReference name ]! ! !GoferReference methodsFor: 'comparing' stamp: 'lr 12/12/2009 13:33'! hash ^ self name hash! ! !GoferReference methodsFor: 'initialization' stamp: 'lr 12/9/2009 22:57'! initializeName: aString name := aString! ! !GoferReference methodsFor: 'printing' stamp: 'lr 12/11/2009 22:02'! printOn: aStream super printOn: aStream. aStream nextPutAll: ' name: '; print: self name! ! !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: '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: '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: '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: 'testing' stamp: 'CamilloBruni 9/18/2012 19:05'! isConfigurationReference ^ false! ! !GoferReference methodsFor: 'private' stamp: 'lr 1/21/2010 00:16'! matches: aResolvedReference "Answer true if the receiver matches aResolvedReference." self subclassResponsibility! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GoferReference class instanceVariableNames: ''! !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.'! ! GoferTest subclass: #GoferReferenceTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Gofer-Tests'! !GoferReferenceTest methodsFor: 'running' stamp: 'lr 12/13/2009 17:53'! setUp super setUp. gofer repository: self monticelloRepository! ! !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 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' 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'! 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-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-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:06'! testContraintShouldFindWorkingCopy | constraintReference workingCopy | constraintReference := GoferConstraintReference name: 'Gofer-Core' constraint: [ :reference | false ]. workingCopy := constraintReference workingCopy. self assert: workingCopy packageName = 'Gofer-Core'! ! !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: '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-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'! ! GoferWorking subclass: #GoferReinitialize instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Gofer-Core'! !GoferReinitialize commentStamp: 'LaurentLaffont 2/23/2011 20:22' prior: 0! 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: 'lr 12/30/2009 11:14'! execute self workingCopies do: [ :each | self execute: each ]! ! !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 ] ]! ! GoferChanges subclass: #GoferRemoteChanges instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Gofer-Core'! !GoferRemoteChanges methodsFor: 'queries' stamp: 'lr 12/12/2009 13:00'! sourceSnapshotOf: aReference ^ aReference workingCopy package snapshot! ! !GoferRemoteChanges methodsFor: 'private' stamp: 'TestRunner 12/13/2009 19:27'! targetSnapshotOf: aReference ^ (aReference resolveWith: self gofer) version snapshot! ! Error subclass: #GoferRepositoryError instanceVariableNames: 'repository' classVariableNames: '' poolDictionaries: '' category: 'Gofer-Core'! !GoferRepositoryError commentStamp: 'lr 1/30/2010 14:39' prior: 0! 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 instanceVariableNames: ''! !GoferRepositoryError class methodsFor: 'instance creation' stamp: 'lr 12/9/2009 19:15'! signal: aString repository: aRepository ^ self new repository: aRepository; signal: aString! ! GoferVersionReference subclass: #GoferResolvedReference instanceVariableNames: 'repository' classVariableNames: '' poolDictionaries: '' category: 'Gofer-Core'! !GoferResolvedReference commentStamp: 'lr 1/30/2010 14:38' prior: 0! 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: '*CI-Loader' stamp: 'CamilloBruni 12/16/2011 10:29'! load Gofer new repository: self repository; package: package; version: self name; load! ! !GoferResolvedReference methodsFor: '*metacello-mc' stamp: 'DaleHenrichs 1/12/2010 20:38'! asMetacelloCachingResolvedReference ^MetacelloCachingGoferResolvedReference name: self name repository: self repository! ! !GoferResolvedReference methodsFor: '*metacello-mc' stamp: 'dkh 10/11/2011 22:39'! 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! ! !GoferResolvedReference methodsFor: 'accessing' stamp: 'lr 12/11/2009 22:33'! repository "Answer the repository of the receiver." ^ repository! ! !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: '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 methodsFor: 'initialization' stamp: 'lr 12/9/2009 22:55'! initializeName: aString repository: aRepository self initializeName: aString. repository := aRepository! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GoferResolvedReference class instanceVariableNames: ''! !GoferResolvedReference class methodsFor: 'instance creation' stamp: 'lr 12/9/2009 22:55'! name: aString repository: aRepository ^ self basicNew initializeName: aString repository: aRepository! ! TestResource subclass: #GoferResource instanceVariableNames: 'versionReferences monticelloRepository' classVariableNames: '' poolDictionaries: '' category: 'Gofer-Tests'! !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 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: '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')! ! GoferUpdate subclass: #GoferRevert instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Gofer-Core'! !GoferRevert methodsFor: 'running' stamp: 'lr 9/19/2009 13:15'! execute self workingCopies do: [ :each | each modified: false ]. super execute! ! !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! ! GoferOperation subclass: #GoferSynchronize instanceVariableNames: 'cacheReferences' classVariableNames: '' poolDictionaries: '' category: 'Gofer-Core'! !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! ! TestCase subclass: #GoferTest instanceVariableNames: 'gofer' classVariableNames: '' poolDictionaries: '' category: 'Gofer-Tests'! !GoferTest methodsFor: 'accessing' stamp: 'lr 12/12/2009 10:44'! monticelloRepository ^ GoferResource current monticelloRepository! ! !GoferTest methodsFor: 'accessing' stamp: 'lr 12/12/2009 10:46'! versionReferences ^ GoferResource current versionReferences! ! !GoferTest methodsFor: 'running' stamp: 'lr 12/13/2009 17:38'! setUp super setUp. gofer := Gofer new. gofer disablePackageCache! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GoferTest class instanceVariableNames: ''! !GoferTest class methodsFor: 'accessing' stamp: 'lr 1/5/2010 11:06'! packageNamesUnderTest ^ #('Gofer-Core')! ! !GoferTest class methodsFor: 'accessing' stamp: 'lr 12/11/2009 23:54'! resources ^ Array with: GoferResource! ! !GoferTest class methodsFor: 'testing' stamp: 'lr 10/1/2009 22:00'! isAbstract ^ self name = #GoferTest! ! !GoferTest class methodsFor: 'testing' stamp: 'JorgeRessia 3/16/2010 20:23'! isUnitTest ^false! ! GoferWorking subclass: #GoferUnload instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Gofer-Core'! !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: 'unloading' stamp: 'lr 10/3/2009 11:46'! unload: aWorkingCopy self unloadClasses: aWorkingCopy. self unloadPackage: aWorkingCopy ! ! !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: 'unloading' stamp: 'lr 8/19/2009 14:00'! unloadPackage: aWorkingCopy self model unloadPackage: aWorkingCopy package! ! !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: 'unregistering' stamp: 'EstebanLorenzano 9/14/2012 11:31'! unregisterPackageInfo: aWorkingCopy PackageOrganizer default unregisterPackageNamed: aWorkingCopy packageName! ! !GoferUnload methodsFor: 'unregistering' stamp: 'EstebanLorenzano 9/12/2012 13:34'! unregisterPackageSet: aWorkingCopy aWorkingCopy packageSet unregister! ! !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: 'lr 8/20/2009 11:54'! unregisterWorkingCopy: aWorkingCopy aWorkingCopy unregister! ! !GoferUnload methodsFor: 'private' stamp: 'lr 3/14/2010 21:13'! defaultModel ^ (Smalltalk globals at: #MCMultiPackageLoader ifAbsent: [ MCPackageLoader ]) new! ! GoferWorking subclass: #GoferUpdate instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Gofer-Core'! !GoferUpdate methodsFor: 'running' stamp: 'StephaneDucasse 12/30/2012 20:28'! execute self model hasVersions ifTrue: [ self model load ]. self gofer cleanup! ! !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: 'lr 9/18/2009 18:13'! defaultModel ^ MCVersionLoader new! ! !GoferUpdate methodsFor: 'private' stamp: 'TestRunner 12/13/2009 18:08'! referenceFor: aReference ^ aReference! ! GoferReference subclass: #GoferVersionReference instanceVariableNames: 'package author branch versionNumber' classVariableNames: '' poolDictionaries: '' category: 'Gofer-Core'! !GoferVersionReference commentStamp: 'lr 12/9/2009 22:50' prior: 0! A GoferVersionReference refers to a specific version of a Monticello package.! !GoferVersionReference methodsFor: '*metacello-mc' stamp: 'dkh 4/17/2011 13:10'! 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)}! ! !GoferVersionReference methodsFor: 'accessing' stamp: 'lr 12/11/2009 22:22'! author "Answer the author of the receiver." ^ author! ! !GoferVersionReference methodsFor: 'accessing' stamp: 'lr 12/11/2009 22:23'! branch "Answer the branch of the receiver." ^ branch! ! !GoferVersionReference methodsFor: 'accessing' stamp: 'lr 12/13/2009 17:12'! packageName "Answer the package of the receiver." ^ package! ! !GoferVersionReference methodsFor: 'accessing' stamp: 'lr 12/13/2009 17:20'! versionNumber "Answer the version of the receiver." ^ versionNumber! ! !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! ! GoferOperation subclass: #GoferWorking instanceVariableNames: 'workingCopies' classVariableNames: '' poolDictionaries: '' category: 'Gofer-Core'! !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) ]! ! Object subclass: #GoogleAttachment instanceVariableNames: 'comment contents filename issue name url' classVariableNames: '' poolDictionaries: '' category: 'CI-Core'! !GoogleAttachment commentStamp: '' prior: 0! A GoogleAttachment is a representation of a google issue tracker attachment! !GoogleAttachment methodsFor: 'accessing' stamp: 'CamilloBruni 9/21/2011 15:26'! comment ^ comment! ! !GoogleAttachment methodsFor: 'accessing' stamp: 'CamilloBruni 9/21/2011 15:26'! comment: anObject comment := anObject! ! !GoogleAttachment methodsFor: 'accessing' stamp: 'CamilloBruni 9/20/2011 16:32'! contents ^ contents ifNil: [ contents := (ZnEasy get: self url) contents ]! ! !GoogleAttachment methodsFor: 'accessing' stamp: 'CamilloBruni 9/25/2011 05:04'! description ^ '"', self filename, '" from Comment #', self comment id asString! ! !GoogleAttachment methodsFor: 'accessing' stamp: 'CamilloBruni 9/18/2011 18:47'! filename ^ filename! ! !GoogleAttachment methodsFor: 'accessing' stamp: 'CamilloBruni 9/19/2011 17:41'! issue ^ issue! ! !GoogleAttachment methodsFor: 'accessing' stamp: 'CamilloBruni 9/19/2011 17:41'! issue: anObject issue := anObject! ! !GoogleAttachment methodsFor: 'accessing' stamp: 'CamilloBruni 9/18/2011 18:51'! load filename := ('name=[^&]+' asRegex matchesIn: url) first allButFirst: 'name=' size.! ! !GoogleAttachment methodsFor: 'accessing' stamp: 'CamilloBruni 9/21/2011 15:34'! published ^ self comment published! ! !GoogleAttachment methodsFor: 'accessing' stamp: 'CamilloBruni 9/18/2011 18:50'! url ^ url! ! !GoogleAttachment methodsFor: 'comparing' stamp: 'CamilloBruni 9/19/2011 17:50'! = anObject (anObject isKindOf: self class) ifFalse: [ ^ false ]. ^ self issue = anObject issue and: [ self name = anObject name ]! ! !GoogleAttachment methodsFor: 'comparing' stamp: 'CamilloBruni 9/19/2011 17:49'! hash ^ self issue hash bitXor: self name hash! ! !GoogleAttachment methodsFor: 'initialize-release' stamp: 'CamilloBruni 9/19/2011 17:22'! initializeWith: anURLString super initialize. url := anURLString. self load.! ! !GoogleAttachment methodsFor: 'printing' stamp: 'CamilloBruni 9/18/2011 18:43'! printOn: aStream ^ aStream print: self filename! ! !GoogleAttachment methodsFor: 'testing' stamp: 'CamilloBruni 9/22/2011 09:37'! isSource ^ (self filename endsWith: '.st') or: [ self filename endsWith: '.cs' ].! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GoogleAttachment class instanceVariableNames: ''! !GoogleAttachment class methodsFor: 'instance-creation' stamp: 'CamilloBruni 9/18/2011 18:27'! fromURL: anURLString ^ self basicNew initializeWith: anURLString; yourself! ! Object subclass: #GoogleIssue instanceVariableNames: 'attachements changeLoader comments description id labels published relatedPackages slice state status title tracker updated' classVariableNames: '' poolDictionaries: '' category: 'CI-Core'! !GoogleIssue commentStamp: '' prior: 0! A GoogleIssue is a representation of a Google Issue Tracker issue. see for a documentation of the google issue api.! !GoogleIssue methodsFor: 'acessing' stamp: 'CamilloBruni 9/21/2011 17:44'! allAttachments "return a list of all attachments ordered by date. oldest first. Note: this might includes duplicates as resubmitted attachments do not overwrite old ones. For a unique list see GoogleIssue >> #attachemnts" ^ attachements ifNil: [ attachements := self loadAttachments ] ! ! !GoogleIssue methodsFor: 'acessing' stamp: 'CamilloBruni 9/21/2011 15:46'! attachments "return a list of unique attachments. Note: This list only includes the latest version of an attachment. For a complete list see GoogleIssue >> #allAttachmnens" attachements ifNil: [ attachements := self loadAttachments ]. ^ attachements reversed asSet asArray ! ! !GoogleIssue methodsFor: 'acessing' stamp: 'CamilloBruni 9/19/2011 18:02'! changeSets ^ self attachments select: [ :each| (each filename endsWith: '.cs') or: [ each filename endsWith: '.st' ]]! ! !GoogleIssue methodsFor: 'acessing' stamp: 'CamilloBruni 9/22/2011 18:03'! changed ^ self lastComment updated! ! !GoogleIssue methodsFor: 'acessing' stamp: 'MonkeyGalactikalIntegrator 6/29/2012 17:39'! commentById: anInteger ^ self comments detect: [ :comment| comment id = anInteger ]! ! !GoogleIssue methodsFor: 'acessing' stamp: 'BenjaminVanRyseghem 3/26/2012 16:38'! comments "return a list of GoogleIssueComment for this issue" ^ comments ifNil: [ comments := {self description}, self loadComments ].! ! !GoogleIssue methodsFor: 'acessing' stamp: 'BenjaminVanRyseghem 3/26/2012 16:38'! description ^ description! ! !GoogleIssue methodsFor: 'acessing' stamp: 'Integrator 6/21/2012 17:52'! description: aStringOrDescription description := aStringOrDescription asGoogleIssueDescription. description title: self title. description author: (self tracker ifNil: [ nil ] ifNotNil: [:t | t user ]).! ! !GoogleIssue methodsFor: 'acessing' stamp: 'CamilloBruni 9/18/2011 20:38'! id "a unique id to identify a google issue" ^ id! ! !GoogleIssue methodsFor: 'acessing' stamp: 'CamilloBruni 9/18/2011 20:40'! labels "a list of google labels" ^ labels! ! !GoogleIssue methodsFor: 'acessing' stamp: 'CamilloBruni 8/16/2011 15:01'! labels: aCollection labels := aCollection! ! !GoogleIssue methodsFor: 'acessing' stamp: 'CamilloBruni 9/22/2011 18:02'! lastComment ^ self comments detectMax: [ :comment| comment published ]! ! !GoogleIssue methodsFor: 'acessing' stamp: 'CamilloBruni 9/22/2011 18:02'! newestComment ^ self comments detectMax: [ :comment| comment updated ]! ! !GoogleIssue methodsFor: 'acessing' stamp: 'CamilloBruni 8/16/2011 14:35'! project ^ tracker project! ! !GoogleIssue methodsFor: 'acessing' stamp: 'CamilloBruni 8/16/2011 15:02'! published ^ published! ! !GoogleIssue methodsFor: 'acessing' stamp: 'CamilloBruni 8/16/2011 15:03'! published: aDateTime published := aDateTime! ! !GoogleIssue methodsFor: 'acessing' stamp: 'CamilloBruni 8/16/2011 18:36'! relatedPackages ^ relatedPackages ifNil: [ relatedPackages := self loadRelatedPackages ]. ! ! !GoogleIssue methodsFor: 'acessing' stamp: 'CamilloBruni 8/16/2011 16:48'! slice ^ slice ifNil: [ slice := self loadSlice ].! ! !GoogleIssue methodsFor: 'acessing' stamp: 'CamilloBruni 8/16/2011 15:02'! state ^ state! ! !GoogleIssue methodsFor: 'acessing' stamp: 'CamilloBruni 8/16/2011 15:02'! status ^ status! ! !GoogleIssue methodsFor: 'acessing' stamp: 'CamilloBruni 9/20/2011 18:13'! status: aSataneouStatusString status := aSataneouStatusString! ! !GoogleIssue methodsFor: 'acessing' stamp: 'CamilloBruni 8/16/2011 15:02'! title ^ title! ! !GoogleIssue methodsFor: 'acessing' stamp: 'BenjaminVanRyseghem 3/26/2012 16:49'! title: aString title := aString. description ifNotNil: [ description title: self title ].! ! !GoogleIssue methodsFor: 'acessing' stamp: 'CamilloBruni 8/16/2011 15:01'! tracker ^ tracker! ! !GoogleIssue methodsFor: 'acessing' stamp: 'CamilloBruni 8/16/2011 15:01'! tracker: aTracker tracker := aTracker! ! !GoogleIssue methodsFor: 'acessing' stamp: 'CamilloBruni 8/16/2011 15:03'! updated ^ updated! ! !GoogleIssue methodsFor: 'acessing' stamp: 'CamilloBruni 8/16/2011 15:03'! updated: aDateTime updated := aDateTime! ! !GoogleIssue methodsFor: 'acessing' stamp: 'CamilloBruni 9/20/2011 16:53'! url ^ self url: ''! ! !GoogleIssue methodsFor: 'acessing' stamp: 'MonkeyGalactikalIntegrator 6/29/2012 17:45'! url: aSubPath | url | url := 'http://code.google.com/feeds/issues/p' asZnUrl. url addPathSegment: self project; addPathSegments: (($/ split: aSubPath) reject: [ :each| each isEmpty ]). ^ url! ! !GoogleIssue methodsFor: 'acessing' stamp: 'CamilloBruni 9/18/2011 18:19'! viewUrl ^ 'http://code.google.com/p/', self project, '/issues/detail?id=', id asString! ! !GoogleIssue methodsFor: 'checking' stamp: 'CamilloBruni 9/22/2011 18:16'! hasToBeChecked |date newestComment| self hasFix ifFalse: [ ^ false ]. self flag: 'uuugly hardcoding of the user...'. (self newestComment author name == 'pharo.ulysse') ifTrue: [ ^ false ]. newestComment := self newestCommentFrom: 'pharo.ulysse'. newestComment ifNil: [ ^ true ]. date := self hasSlice ifTrue: [ self slice date ] ifFalse: [ (self changeSets detectMax: [ :each| each published]) published ]. ^ date > newestComment updated! ! !GoogleIssue methodsFor: 'checking' stamp: 'BenjaminVanRyseghem 3/26/2012 17:20'! monkeyIsChecking self status: 'MonkeyIsChecking'. self submitStatusChange: 'The Monkey is currently checking this issue. Please don''t change it!!'! ! !GoogleIssue methodsFor: 'checking' stamp: 'CamilloBruni 9/22/2011 18:05'! newestCommentFrom: anEmailString | messagesFrom | messagesFrom := self comments select: [:comment | comment author = anEmailString ]. ^ messagesFrom detectMax: [ :comment| comment updated ]! ! !GoogleIssue methodsFor: 'comparing' stamp: 'CamilloBruni 9/19/2011 17:53'! = anObject (anObject isKindOf: self class) ifFalse: [ ^ false ]. "for now the url is enough, should be extended to check things like lables and so forth" ^ self url = anObject url ! ! !GoogleIssue methodsFor: 'comparing' stamp: 'CamilloBruni 9/19/2011 17:53'! hash ^ self url hash! ! !GoogleIssue methodsFor: 'initialization' stamp: 'CamilloBruni 2/15/2013 14:48'! initialize "Initialization code for GoogleIssue" super initialize. attachements := nil. changeLoader := nil. comments := nil. description := nil. id := nil. labels := {}. published := nil. relatedPackages := nil. slice := nil. state := nil. status := nil. title := nil. tracker := nil. updated := nil.! ! !GoogleIssue methodsFor: 'initialize-release' stamp: 'CamilloBruni 8/16/2011 15:01'! initializeWith: trackingId super initialize. id := trackingId.! ! !GoogleIssue methodsFor: 'integration' stamp: 'BenjaminVanRyseghem 7/13/2012 14:52'! changeLoader ^ changeLoader ifNil: [ changeLoader := UlysseTheMonkey issue: self ].! ! !GoogleIssue methodsFor: 'integration' stamp: 'BenjaminVanRyseghem 7/2/2012 15:53'! checkedInLabel ^ {GoogleIssueTracker checkedInLabel , Smalltalk lastUpdateString squeezeOutNumber asString}! ! !GoogleIssue methodsFor: 'integration' stamp: 'BenjaminVanRyseghem 9/25/2011 17:23'! ensureFix "check whether this issue has a loadable source, either an attached .cs or .st file or a SLICE" self hasFix ifFalse: [ self errorNoSources ]! ! !GoogleIssue methodsFor: 'integration' stamp: 'BenjaminVanRyseghem 6/29/2012 15:17'! errorNoSources "set the status of the issue to NoSourcesAvailable" self status: PharoTrackerLabels noSourcesAvailable. ^ self submitStatusChange: (String streamContents: [ :stream| stream << 'This Issue has been checked by Ulysse the Monkey, but no sources are available'; lf; lf. stream << 'Someone should have a look either to check the validity of the source or to report a strange behavior of a crazy monkey.']).! ! !GoogleIssue methodsFor: 'integration' stamp: 'BenjaminVanRyseghem 6/29/2012 15:17'! errorNoSources: aMessageString "set the status of the issue to NoSourcesAvailable" self status: PharoTrackerLabels noSourcesAvailable. ^ self submitStatusChange: (String streamContents: [ :stream| stream << 'This Issue has been checked by Ulysse the Monkey, but no sources are available:'; lf; lf. stream << aMessageString]).! ! !GoogleIssue methodsFor: 'integration' stamp: 'BenjaminVanRyseghem 6/30/2012 16:53'! failingTest: aMessageString "set the status of the issue to WorkNeeded and post a message" self status: PharoTrackerLabels testFailure. ^ self submitStatusChange: aMessageString. ! ! !GoogleIssue methodsFor: 'integration' stamp: 'BenjaminVanRyseghem 7/2/2012 15:53'! fixToInclude "set the status of the issue to FixToInclude" self status: PharoTrackerLabels issueChecked. self labels: self checkedInLabel. ^ self submitStatusChange: 'This Issue has been checked by Ulysse the Monkey'! ! !GoogleIssue methodsFor: 'integration' stamp: 'BenjaminVanRyseghem 7/2/2012 15:53'! fixToInclude: aString "set the status of the issue to FixToInclude" self status: PharoTrackerLabels issueChecked. self labels: self checkedInLabel. ^ self submitStatusChange: 'This Issue has been checked by Ulysse the Monkey ', aString.! ! !GoogleIssue methodsFor: 'integration' stamp: 'BenjaminVanRyseghem 3/26/2012 17:20'! integratedInVersion: anInteger "set the status of the issue to ReviewNeeded and post a message" self status: #Integrated. ^ self submitStatusChange: (String streamContents: [ :stream| stream <<'Integrated in Pharo' << SystemVersion current dottedMajorMinor<< ' ' << anInteger printString; cr ;cr ; <<'Thanks' ])! ! !GoogleIssue methodsFor: 'integration' stamp: 'CamilloBruni 12/16/2011 10:03'! load "try to load this issue using the ChangeLoader which will update the tracker status accordingly" self ensureFix. ^ self changeLoader load ! ! !GoogleIssue methodsFor: 'integration' stamp: 'CamilloBruni 12/16/2011 10:03'! loadAndTest "try to load this issue using the ChangeLoader which will update the tracker status accordingly" self ensureFix. ^ self changeLoader loadAndTest. ! ! !GoogleIssue methodsFor: 'integration' stamp: 'BenjaminVanRyseghem 6/29/2012 15:22'! reviewNeeded: aMessageString "set the status of the issue to WorkNeeded and post a message" self status: PharoTrackerLabels workNeeded. ^ self submitStatusChange: aMessageString. ! ! !GoogleIssue methodsFor: 'integration-private' stamp: 'BenjaminVanRyseghem 9/21/2011 15:23'! addComment: aMessage ^ ' ', aMessage, ' ',self tracker user email,' '! ! !GoogleIssue methodsFor: 'integration-private' stamp: 'MonkeyGalactikalIntegrator 6/29/2012 17:30'! commentsUrl ^ self url: '/issues/', id asString, '/comments/full'! ! !GoogleIssue methodsFor: 'integration-private' stamp: 'BenjaminVanRyseghem 3/26/2012 18:08'! issueCreateXML ^ String streamContents: [ :s| self issueCreateXMLOn: s ].! ! !GoogleIssue methodsFor: 'integration-private' stamp: 'BenjaminVanRyseghem 3/26/2012 18:08'! issueCreateXMLOn: stream self issueXMLHeaderOn: stream. self issueXMLDescriptionOn: stream. self issueXMLTitleOn: stream. self issueXMLAuthorOn: stream. self issueXMLStatusOn: stream. self issueXMLLabelsOn: stream. self issueXMLOwnerOn: stream. self issueXMLFooterOn: stream! ! !GoogleIssue methodsFor: 'integration-private' stamp: 'BenjaminVanRyseghem 3/26/2012 18:05'! issueUrl ^ self url: '/issues/full'! ! !GoogleIssue methodsFor: 'integration-private' stamp: 'MonkeyGalactikalIntegrator 6/29/2012 17:35'! postXML: anXMLString to: anUrl | client entity | "google allows committing changes only on https" anUrl scheme: 'https'. client := self tracker client. entity := ZnEntity text: anXMLString. entity contentType: ((ZnMimeType main: 'application' sub: 'atom+xml') setCharSetUTF8). client url: anUrl; entity: entity; post. ^ client response! ! !GoogleIssue methodsFor: 'integration-private' stamp: 'BenjaminVanRyseghem 3/26/2012 17:22'! statusUpdateXML: aMessage ^ String streamContents: [ :s| self statusUpdateXML: aMessage on: s ].! ! !GoogleIssue methodsFor: 'integration-private' stamp: 'BenjaminVanRyseghem 7/2/2012 15:51'! statusUpdateXML: aMessage on: stream self issueXMLHeaderOn: stream. self issueXMLDescription: aMessage on: stream. self issueXMLAuthorOn: stream. self issueXMLUpdatesOn: stream. self issueXMLFooterOn: stream! ! !GoogleIssue methodsFor: 'integration-private' stamp: 'BenjaminVanRyseghem 3/26/2012 18:00'! submitStatusChange ^ self submitStatusChange:''! ! !GoogleIssue methodsFor: 'integration-private' stamp: 'BenjaminVanRyseghem 3/26/2012 18:06'! submitStatusChange: aMessageString ^ self postXML: (self statusUpdateXML: aMessageString) to: self commentsUrl! ! !GoogleIssue methodsFor: 'integration-private' stamp: 'BenjaminVanRyseghem 3/26/2012 17:25'! xmlEscape: aString on: stream "a poor man's convert... :/" | map | map := Dictionary newFromPairs: #( $" '"' $' ''' $< '<' $> '>' $& '&'). aString do: [ :c| map at: c ifPresent: [ :mapping| stream nextPutAll: mapping ] ifAbsent: [ stream nextPut: c]]. ! ! !GoogleIssue methodsFor: 'loading' stamp: 'BenjaminVanRyseghem 2/28/2012 18:42'! attachmentsScript "since there is no api for accessing attachments from the google issuetracker we have to manually fetch the website and extract the attachments :)" ^ (self attachments collect: [:e | '']) joinUsing: '. ' ! ! !GoogleIssue methodsFor: 'loading' stamp: 'CamilloBruni 9/7/2012 16:57'! loadAttachments "since there is no api for accessing attachments from the google issuetracker we have to manually fetch the website and extract the attachments :)" | soup regex attachmentLinks commentTags attachment comment| soup := GoogleIssueTracker soupClass fromString: (self tracker get: self viewUrl) contents. "manually find the matching attachment urls.." regex := ('//', self project, '.googlecode.com/issues/attachment\?.*') asRegex. attachmentLinks := ((soup // 'a') select: [ :tag| tag size = 1]) attribute: #href matching: regex. attachmentLinks isEmpty ifTrue: [ ^ Array new ]. "find the parent comment" commentTags := (soup // 'div') attribute: 'id' matching: 'hc[0-9]+' asRegex. "assign attachments to issues" ^ (Array streamContents: [ :stream| commentTags do: [ :commentTag| comment := self commentById: (commentTag id allButFirst: 2) asInteger. attachmentLinks select: [ :link| commentTag includesTag: link] thenDo: [ :link| stream nextPut: (comment addAttachment: ((GoogleAttachment fromURL: 'http:', link href) issue: self; yourself))]]]) sort: [ :a :b| a published <= b published] ! ! !GoogleIssue methodsFor: 'loading' stamp: 'MonkeyGalactikalIntegrator 6/29/2012 17:30'! loadComments |contents doc nodes | contents := (self tracker get: self commentsUrl) contents. doc := GoogleIssueTracker soupClass fromString: contents. ^ ((doc findAllTags: 'entry') collect: [ :node| (GoogleIssueComment fromXML: node) issue: self; yourself ]) asArray. ! ! !GoogleIssue methodsFor: 'loading' stamp: 'CamilloBruni 8/16/2011 18:47'! loadRelatedPackages | packages testPackages| packages := self slice version dependencies collect: [ :dep| dep package name ]. self flag: 'should also add the packages of all subclasses...'. "manually try to figure out weirdly TEST- prefixed packages" testPackages := OrderedCollection new. packages do: [ :package| self flag: 'there must be a cleaner way to do this...'. testPackages addAll: (SystemNavigation default environment organization categoriesMatching: 'Tests-', package, '*')]. testPackages addAll: packages. ^ testPackages asArray! ! !GoogleIssue methodsFor: 'loading' stamp: 'CamilloBruni 9/19/2011 18:10'! loadSlice ^ self loadSliceFrom: (Gofer new url: 'http://ss3.gemstone.com/ss/PharoInbox')! ! !GoogleIssue methodsFor: 'loading' stamp: 'CamilloBruni 9/5/2012 17:09'! loadSliceFrom: gofer | match slices | match := 'SLICE-Issue-', id asString. slices := gofer allResolved select: [ :ref| ref name beginsWith: match]. slices ifEmpty: [ ^ nil ]. slices size == 1 ifTrue: [ ^ slices first ]. "filter out local cache repositories" slices := slices reject: [ :goferReference| goferReference repository isKindOf: MCCacheRepository ]. " get the last version " ^ (slices sort: [ :a :b | a versionNumber >= b versionNumber ]) first! ! !GoogleIssue methodsFor: 'loading' stamp: 'BenjaminVanRyseghem 9/26/2011 17:45'! loadSource self hasSlice ifTrue: [ ^ self loadSlice ]. self hasAttachment ifTrue: [ ^ self loadAttachments ]. self error: 'Nothing to do'! ! !GoogleIssue methodsFor: 'loading' stamp: 'BenjaminVanRyseghem 2/28/2012 18:17'! script self hasSlice ifTrue: [ ^ self sliceScript ]. self hasAttachment ifTrue: [ ^ self attachmentsScript ]. self error: 'Nothing to do'! ! !GoogleIssue methodsFor: 'loading' stamp: 'BenjaminVanRyseghem 2/28/2012 21:36'! sliceScript | slc | slc := self slice. ^ String streamContents: [:s | s << 'Gofer new url: ' << slc repository description printString <<';' << String crlf << String tab << 'package: ' << slc packageName printString << ';' << String crlf << String tab << 'version: ' << slc name printString <<';' << String crlf << String tab << 'load.' ].! ! !GoogleIssue methodsFor: 'new issue' stamp: 'BenjaminVanRyseghem 7/4/2012 13:49'! newEntryURL ^ self url: '/issues/full'! ! !GoogleIssue methodsFor: 'new issue' stamp: 'BenjaminVanRyseghem 7/4/2012 13:39'! newIssueXML ^ String streamContents: [:s | self newIssueXML: s ]! ! !GoogleIssue methodsFor: 'new issue' stamp: 'BenjaminVanRyseghem 7/4/2012 13:45'! newIssueXML: stream self issueXMLHeaderOn: stream; issueXMLTitleOn: stream; issueXMLDescription: stream; issueXMLAuthorOn: stream; issueXMLStatusOn: stream; issueXMLOwnerOn: stream; issueXMLLabelsOn: stream; issueXMLFooterOn: stream! ! !GoogleIssue methodsFor: 'new issue' stamp: 'BenjaminVanRyseghem 7/4/2012 14:17'! submitAsNewEntry | response | response := self postXML: (self newIssueXML) to: self newEntryURL. response statusLine code = 201 ifTrue: [ id := (response headers headers at: 'Location') squeezeOutNumber ] ifFalse: [ ErrorWhileCreationException response: response ]. ^ self! ! !GoogleIssue methodsFor: 'printing' stamp: 'BenjaminVanRyseghem 9/26/2011 16:01'! name ^ String streamContents: [:s | s << self id asString << ': ' << self title ]! ! !GoogleIssue methodsFor: 'printing' stamp: 'Integrator 9/20/2012 14:38'! printOn: aStream super printOn: aStream. aStream nextPutAll: '(#' ; nextPutAll: self id asString; nextPutAll: ': '; nextPutAll: self title asString; nextPutAll: ')'! ! !GoogleIssue methodsFor: 'saving' stamp: 'BenjaminVanRyseghem 3/26/2012 18:23'! submit "save an issue on the tracker" | result | id ifNotNil: [ ^ self error: 'Cannot create the same issue twice. Original issue is ', self viewUrl ]. result := self postXML: self issueCreateXML to: self issueUrl. "set the id to prevent multiple submissions of the same issue" id := result location squeezeOutNumber. ^ result.! ! !GoogleIssue methodsFor: 'testing' stamp: 'CamilloBruni 9/18/2011 20:32'! hasAttachment ^ self attachments isEmpty not! ! !GoogleIssue methodsFor: 'testing' stamp: 'CamilloBruni 9/19/2011 18:02'! hasChangeSet ^ self attachments anySatisfy: [ :each| (each filename endsWith: '.cs') or: [ each filename endsWith: '.st' ]].! ! !GoogleIssue methodsFor: 'testing' stamp: 'CamilloBruni 9/22/2011 16:28'! hasFix ^ self hasSlice or: [ self hasChangeSet ].! ! !GoogleIssue methodsFor: 'testing' stamp: 'CamilloBruni 9/18/2011 20:38'! hasSlice "return whether this issue has a corresponding slice in the pharo inbox" ^ self slice isNil not! ! !GoogleIssue methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 7/2/2012 16:12'! isGreen "return true if all the tests of the affected package are green" ^ (UlysseTheMonkey issue: self) isGreen! ! !GoogleIssue methodsFor: 'tests' stamp: 'BenjaminVanRyseghem 9/26/2011 18:41'! dirtyPackagesTests "I should be changed to be able to detect the changes without having to load the cs" | categories classes | categories := MCWorkingCopy allManagers select: [ :each | each modified ] thenCollect: [:each| each package name ]. categories := categories reject: [:e | e = 'KernelTests' ]. classes := self class environment allClasses select: [:class | categories anySatisfy: [:name | class category beginsWith: name ]]. ^ classes select: [:e | (e inheritsFrom: TestCase) and: [ e isAbstract not ]].! ! !GoogleIssue methodsFor: 'tests' stamp: 'BenjaminVanRyseghem 9/26/2011 18:36'! impactedPackagesTests | categories classes | categories := self relatedPackages. classes := self class environment allClasses select: [:class | categories anySatisfy: [:name | class category beginsWith: name ]]. ^ classes select: [:e | (e inheritsFrom: TestCase) and: [ e isAbstract not ]].! ! !GoogleIssue methodsFor: 'tests' stamp: 'BenjaminVanRyseghem 9/26/2011 18:38'! testClassesToBeChecked self hasSlice ifTrue: [ ^ self impactedPackagesTests ]. self hasAttachment ifTrue: [ ^ self dirtyPackagesTests ]. ^ self error: 'Why are you loading me ?'! ! !GoogleIssue methodsFor: 'private-XML code' stamp: 'BenjaminVanRyseghem 3/26/2012 17:39'! issueXMLAuthorOn: stream stream nextPutAll: ' '. self xmlEscape: self tracker user email on: stream. stream nextPutAll: ' '! ! !GoogleIssue methodsFor: 'private-XML code' stamp: 'BenjaminVanRyseghem 7/4/2012 13:40'! issueXMLDescription: stream stream nextPutAll: ''. self xmlEscape: self description content on: stream. stream nextPutAll: ''! ! !GoogleIssue methodsFor: 'private-XML code' stamp: 'BenjaminVanRyseghem 3/26/2012 17:37'! issueXMLDescription: aMessage on: stream stream nextPutAll: ''. self xmlEscape: aMessage on: stream. stream nextPutAll: ''! ! !GoogleIssue methodsFor: 'private-XML code' stamp: 'BenjaminVanRyseghem 3/26/2012 18:10'! issueXMLDescriptionOn: stream self issueXMLDescription: self description content on: stream.! ! !GoogleIssue methodsFor: 'private-XML code' stamp: 'BenjaminVanRyseghem 3/26/2012 17:44'! issueXMLFooterOn: stream stream nextPutAll: ''! ! !GoogleIssue methodsFor: 'private-XML code' stamp: 'BenjaminVanRyseghem 3/26/2012 17:34'! issueXMLHeader ^ ' '! ! !GoogleIssue methodsFor: 'private-XML code' stamp: 'BenjaminVanRyseghem 3/26/2012 17:37'! issueXMLHeaderOn: stream stream nextPutAll: self issueXMLHeader! ! !GoogleIssue methodsFor: 'private-XML code' stamp: 'BenjaminVanRyseghem 3/26/2012 17:52'! issueXMLLabelsOn: stream labels do: [ :e | stream nextPutAll: ''. self xmlEscape: e on: stream. stream nextPutAll: '' ]! ! !GoogleIssue methodsFor: 'private-XML code' stamp: 'BenjaminVanRyseghem 3/26/2012 17:43'! issueXMLOwnerOn: stream stream nextPutAll: ' '. self xmlEscape: self tracker user email on: stream. stream nextPutAll: ' '! ! !GoogleIssue methodsFor: 'private-XML code' stamp: 'BenjaminVanRyseghem 3/26/2012 17:41'! issueXMLStatusOn: stream stream nextPutAll: ''. self xmlEscape: self status on: stream. stream nextPutAll: ''! ! !GoogleIssue methodsFor: 'private-XML code' stamp: 'BenjaminVanRyseghem 3/26/2012 17:50'! issueXMLTitleOn: stream stream nextPutAll: ''. self xmlEscape: self title on: stream. stream nextPutAll: ''! ! !GoogleIssue methodsFor: 'private-XML code' stamp: 'BenjaminVanRyseghem 7/2/2012 15:51'! issueXMLUpdatesOn: stream stream nextPutAll: ''. self issueXMLStatusOn: stream. self issueXMLLabelsOn: stream. stream nextPutAll: ''! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GoogleIssue class instanceVariableNames: ''! !GoogleIssue class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 6/30/2012 12:31'! fromXML: entryNode tracker: aTracker | issue | issue := self id: ((entryNode findTag: 'id') text subStrings: '/') last squeezeOutNumber. issue tracker: aTracker. issue published: entryNode published text asDateAndTime. issue updated: entryNode updated text asDateAndTime. issue title: entryNode title text. issue description: ((GoogleIssueDescription fromXML: entryNode) issue: issue; yourself). issue labels: ((entryNode findAllTags: 'issues:label') collect: [:element| element text]). ^ issue! ! !GoogleIssue class methodsFor: 'instance creation' stamp: 'CamilloBruni 9/22/2011 22:51'! id: id ^ self basicNew initializeWith: id! ! Object subclass: #GoogleIssueComment instanceVariableNames: 'attachments author content id issue published title updated' classVariableNames: '' poolDictionaries: '' category: 'CI-Core'! !GoogleIssueComment commentStamp: '' prior: 0! A GoogleIssueComment is a representation of a Google Issue Tracker issue's comment! !GoogleIssueComment methodsFor: 'accessing' stamp: 'CamilloBruni 9/21/2011 15:37'! addAttachment: anAttachment attachments add: anAttachment. anAttachment comment: self. ^ anAttachment! ! !GoogleIssueComment methodsFor: 'accessing' stamp: 'CamilloBruni 9/21/2011 02:01'! attachments ^ attachments! ! !GoogleIssueComment methodsFor: 'accessing' stamp: 'CamilloBruni 9/21/2011 02:01'! attachments: anObject attachments := anObject! ! !GoogleIssueComment methodsFor: 'acessing' stamp: 'CamilloBruni 8/16/2011 15:29'! author ^ author! ! !GoogleIssueComment methodsFor: 'acessing' stamp: 'CamilloBruni 8/16/2011 15:29'! author: anAuthor author := anAuthor! ! !GoogleIssueComment methodsFor: 'acessing' stamp: 'CamilloBruni 8/16/2011 15:29'! content ^ content! ! !GoogleIssueComment methodsFor: 'acessing' stamp: 'CamilloBruni 8/16/2011 15:29'! content: aString content := aString! ! !GoogleIssueComment methodsFor: 'acessing' stamp: 'CamilloBruni 8/16/2011 15:28'! id ^ id! ! !GoogleIssueComment methodsFor: 'acessing' stamp: 'CamilloBruni 8/16/2011 15:28'! issue ^ issue! ! !GoogleIssueComment methodsFor: 'acessing' stamp: 'CamilloBruni 9/21/2011 15:39'! issue: anIssue issue := anIssue! ! !GoogleIssueComment methodsFor: 'acessing' stamp: 'CamilloBruni 8/16/2011 15:28'! published ^ published! ! !GoogleIssueComment methodsFor: 'acessing' stamp: 'CamilloBruni 9/21/2011 15:41'! published: aDateTime published := aDateTime! ! !GoogleIssueComment methodsFor: 'acessing' stamp: 'CamilloBruni 8/16/2011 15:28'! title ^ title! ! !GoogleIssueComment methodsFor: 'acessing' stamp: 'CamilloBruni 9/21/2011 15:39'! title: aString title := aString! ! !GoogleIssueComment methodsFor: 'acessing' stamp: 'CamilloBruni 8/16/2011 15:28'! updated ^ updated! ! !GoogleIssueComment methodsFor: 'acessing' stamp: 'CamilloBruni 9/21/2011 15:41'! updated: aDateTime updated := aDateTime! ! !GoogleIssueComment methodsFor: 'converting' stamp: 'BenjaminVanRyseghem 3/26/2012 17:04'! asComment ^ self! ! !GoogleIssueComment methodsFor: 'converting' stamp: 'BenjaminVanRyseghem 3/26/2012 17:05'! asDescription GoogleIssueDescription adoptInstance: self. ^ self ! ! !GoogleIssueComment methodsFor: 'converting' stamp: 'BenjaminVanRyseghem 3/26/2012 16:40'! asGoogleIssueComment ^ self! ! !GoogleIssueComment methodsFor: 'initialize-release' stamp: 'CamilloBruni 9/21/2011 15:36'! initializeWith: anIssueId super initialize. id := anIssueId. attachments := OrderedCollection new.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GoogleIssueComment class instanceVariableNames: ''! !GoogleIssueComment class methodsFor: 'instance creation' stamp: 'CamilloBruni 9/22/2011 22:08'! fromXML: entryNode | comment idString | idString := entryNode id text. comment := self id: (idString copyFrom: (idString lastIndexOf: $/) + 1 to: idString size) asInteger. comment published: entryNode published text asDateAndTime. comment updated: entryNode updated text asDateAndTime. comment title: entryNode title text trimBoth. comment content: entryNode content text trimBoth. comment author: (GoogleUser fromXML: entryNode author). ^ comment! ! !GoogleIssueComment class methodsFor: 'instance creation' stamp: 'CamilloBruni 9/22/2011 22:08'! id: id ^ self basicNew initializeWith: id! ! GoogleIssueComment subclass: #GoogleIssueDescription instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CI-Core'! !GoogleIssueDescription commentStamp: '' prior: 0! A GoogleIssueDescription is a representation of a Google Issue Tracker issue first comment (the Google API have a special name for it)! !GoogleIssueDescription methodsFor: 'acessing' stamp: 'CamilloBruni 9/22/2011 22:47'! id ^ 0! ! !GoogleIssueDescription methodsFor: 'converting' stamp: 'BenjaminVanRyseghem 3/26/2012 17:05'! asComment GoogleIssueComment adoptInstance: self. ^ self ! ! !GoogleIssueDescription methodsFor: 'converting' stamp: 'BenjaminVanRyseghem 3/26/2012 17:04'! asDescription ^ self! ! !GoogleIssueDescription methodsFor: 'converting' stamp: 'BenjaminVanRyseghem 3/26/2012 16:57'! asGoogleIssueDescription ^ self! ! !GoogleIssueDescription methodsFor: 'initialize-release' stamp: 'CamilloBruni 9/22/2011 22:47'! initializeWith: anIssueId super initializeWith: 0! ! Object subclass: #GoogleIssueTracker instanceVariableNames: 'authentificationToken project integrated user token' classVariableNames: '' poolDictionaries: '' category: 'CI-Core'! !GoogleIssueTracker commentStamp: '' prior: 0! self example. IntegrationManager initialize. IntegrationManager default summary. see for a documentation of the google issue api.! !GoogleIssueTracker methodsFor: 'accessing' stamp: 'CamilloBruni 9/20/2011 16:01'! googleServiceName "identifies the issue tracker. Generally the prefix of the google service's domain name (http://code.google.com/...) see http://code.google.com/apis/gdata/faq.html#clientlogin" ^ #code! ! !GoogleIssueTracker methodsFor: 'accessing' stamp: 'CamilloBruni 8/16/2011 14:23'! project ^ project! ! !GoogleIssueTracker methodsFor: 'accessing' stamp: 'CamilloBruni 9/20/2011 16:48'! token ^ token! ! !GoogleIssueTracker methodsFor: 'accessing' stamp: 'CamilloBruni 9/20/2011 16:33'! user ^ user! ! !GoogleIssueTracker methodsFor: 'accessing' stamp: 'CamilloBruni 9/20/2011 13:17'! viewUrl ^ 'http://code.google.com/p/', self project! ! !GoogleIssueTracker methodsFor: 'initialize-release' stamp: 'CamilloBruni 9/18/2011 04:13'! initializeWith: name super initialize. project := name. integrated := Set new.! ! !GoogleIssueTracker methodsFor: 'integration' stamp: 'BenjaminVanRyseghem 10/3/2011 17:20'! readyForIntegrationIssues ^ self issuesWithParams: 'status=FixToInclude'.! ! !GoogleIssueTracker methodsFor: 'issues' stamp: 'CamilloBruni 9/21/2011 01:52'! closedIssues ^ self issuesWithParams: 'can=closed'. ! ! !GoogleIssueTracker methodsFor: 'issues' stamp: 'CamilloBruni 8/16/2011 15:24'! issue: id ^ (self issuesWithParams: 'id=', id asString) first.! ! !GoogleIssueTracker methodsFor: 'issues' stamp: 'CamilloBruni 9/21/2011 01:52'! issuesToCheck ^ self issuesWithParams: 'can=open'.! ! !GoogleIssueTracker methodsFor: 'issues' stamp: 'BenjaminVanRyseghem 3/26/2012 18:12'! newIssueNamed: aTitleString description: aString " create a new issue on myself. Example: | issue | issue := self newIssueNamed: 'foo' description: 'an issue description'. issue submit. " ^ GoogleIssue new tracker: self; title: aTitleString; description: aString; status: #Accepted; yourself.! ! !GoogleIssueTracker methodsFor: 'issues' stamp: 'CamilloBruni 1/16/2013 18:01'! nextAlreadyCheckedButInAPreviousPharoVersionIssue "choose the next issue to check by ulysse" | issues nextIssue | "try issues which are new and unprrocessed" issues := self issuesWithParams: 'can=open&status=' , PharoTrackerLabels issueChecked , '&q=Milestone%3D' , SystemVersion current dottedMajorMinor. ^ issues detect: [ :e || labels | labels := e labels select: [ :s | (s beginsWith: self checkedInLabel) ]. labels ifEmpty: [ ^ e ]. labels noneSatisfy: [:s | s squeezeOutNumber = Smalltalk lastUpdateString squeezeOutNumber ]] ifNone: [ nil ]! ! !GoogleIssueTracker methodsFor: 'issues' stamp: 'CamilloBruni 9/5/2012 22:34'! nextIssue "choose the next issue to check by ulysse" | issues nextIssue | "try issues which are new and unprrocessed" issues := self issuesWithParams: self nextIssueParams. issues ifEmpty: [ ^ self nextAlreadyCheckedButInAPreviousPharoVersionIssue ]. nextIssue := issues first. nextIssue hasFix ifTrue: [ ^ nextIssue ] ifFalse: [ nextIssue errorNoSources. ^ self nextIssue ]! ! !GoogleIssueTracker methodsFor: 'issues' stamp: 'BenjaminVanRyseghem 6/30/2012 17:12'! nextIssueId ^ self nextIssue ifNil: [ nil ] ifNotNil:[ :nextIssue | nextIssue id ]! ! !GoogleIssueTracker methodsFor: 'issues' stamp: 'MonkeyGalactikalIntegrator 1/16/2013 18:08'! nextIssueParams. ^ String streamContents: [ :s| s nextPutAll: 'can=open&status='; nextPutAll: PharoTrackerLabels reviewNeeded; nextPutAll: '&q=Milestone%3D'; nextPutAll: SystemVersion current dottedMajorMinor]! ! !GoogleIssueTracker methodsFor: 'issues' stamp: 'CamilloBruni 9/21/2011 01:49'! openIssues ^ self issuesWithParams: 'can=open'.! ! !GoogleIssueTracker methodsFor: 'login' stamp: 'CamilloBruni 9/20/2011 16:35'! authenticate: aUserEmailAddress with: aPasswordString user := GoogleUser email: aUserEmailAddress. token := user authenticateService: self googleServiceName with: aPasswordString.! ! !GoogleIssueTracker methodsFor: 'testing' stamp: 'CamilloBruni 9/20/2011 16:38'! isAuthenticated ^ token isNil not! ! !GoogleIssueTracker methodsFor: 'private' stamp: 'BenjaminVanRyseghem 7/2/2012 15:04'! checkedInLabel ^ self class checkedInLabel! ! !GoogleIssueTracker methodsFor: 'private' stamp: 'CamilloBruni 9/20/2011 18:05'! client |client| client := ZnEasy client. self isAuthenticated ifTrue: [ client headerAt: 'Authorization' add: 'GoogleLogin auth="', self token id, '"']. ^ client! ! !GoogleIssueTracker methodsFor: 'private' stamp: 'CamilloBruni 9/20/2011 18:06'! get: anUrl | client | client := self client. client url: anUrl. ^ client get; response! ! !GoogleIssueTracker methodsFor: 'private' stamp: 'DamienCassou 5/15/2012 18:29'! issuesFromXML: xml ^ (((GoogleIssueTracker soupClass fromString: xml) findAllTags: 'entry' ) collect: [ :node| GoogleIssue fromXML: node tracker: self]) asArray. ! ! !GoogleIssueTracker methodsFor: 'private' stamp: 'CamilloBruni 9/20/2011 16:57'! issuesURL ^ 'http://code.google.com/feeds/issues/p/', project, '/issues/full?max-results=99999&'! ! !GoogleIssueTracker methodsFor: 'private' stamp: 'CamilloBruni 9/20/2011 17:01'! issuesWithParams: urlParams ^ self issuesFromXML: (self get: (self issuesURL, urlParams)) contents ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GoogleIssueTracker class instanceVariableNames: ''! !GoogleIssueTracker class methodsFor: 'instance creation' stamp: 'CamilloBruni 8/16/2011 14:22'! for: projectName ^ self new initializeWith: projectName.! ! !GoogleIssueTracker class methodsFor: 'instance creation' stamp: 'CamilloBruni 9/18/2011 04:10'! pharo ^ self for: 'pharo'! ! !GoogleIssueTracker class methodsFor: 'issues' stamp: 'BenjaminVanRyseghem 7/2/2012 15:03'! checkedInLabel ^ 'CheckedIn'! ! !GoogleIssueTracker class methodsFor: 'to be overriden' stamp: 'CamilloBruni 2/15/2013 00:20'! example "self example" | tracker issue | "Example usage of the issue tracker" Halt now: 'Evaluate step by step for a better understanding'. tracker := GoogleIssueTracker pharo. "give back a list of all open issues" tracker openIssues. issue := tracker issue: 4839 "this is an explicit testing issue". issue comments. issue hasAttachment ifTrue: [ "give back a list of the recent attachements" issue attachments. "give back a list of all attachments (including previous versions of the same file)" issue allAttachments]. issue hasSlice ifTrue: [ "return a Gofer object for the slice corresponding to the issue" issue slice]. "run the tests of all packages changed by the issues's slice" issue isGreen. "authenticate with your google account to change the issues directly from your code" tracker authenticate: 'yourmail@gmail.com' with: 'XXX'. "mark the issue ready for intergation (will update the tracker)" issue fixToInclude. "mark the issue to be review with a comment" issue reviewNeeded: 'Could not load the attached SLICE'.! ! Object subclass: #GoogleToken instanceVariableNames: 'service token user' classVariableNames: '' poolDictionaries: '' category: 'CI-Core'! !GoogleToken commentStamp: '' prior: 0! Used to encapsulate the password to avoid a security breach! !GoogleToken methodsFor: 'accessing' stamp: 'CamilloBruni 9/20/2011 16:48'! id ^ token! ! !GoogleToken methodsFor: 'accessing' stamp: 'CamilloBruni 9/20/2011 13:23'! service ^ service! ! !GoogleToken methodsFor: 'accessing' stamp: 'CamilloBruni 9/20/2011 13:23'! service: anObject service := anObject! ! !GoogleToken methodsFor: 'accessing' stamp: 'CamilloBruni 9/20/2011 13:23'! token ^ token! ! !GoogleToken methodsFor: 'accessing' stamp: 'CamilloBruni 9/20/2011 13:23'! user ^ user! ! !GoogleToken methodsFor: 'accessing' stamp: 'CamilloBruni 9/20/2011 13:23'! user: anObject user := anObject! ! !GoogleToken methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 11/21/2011 13:17'! login: aPasswordString "request a authentification token from google: see http://code.google.com/p/support/wiki/IssueTrackerAPI" | result client| client := ZnClient new url: 'https://www.google.com/accounts/ClientLogin'; yourself. client formAt: #accountType put: #GOOGLE; formAt: #service put: self service; formAt: #source put: 'pharo-googleCI-1.0'; formAt: #Email put: self user email; formAt: #Passwd put: aPasswordString. self handleLoginResult: client post.! ! !GoogleToken methodsFor: 'private' stamp: 'CamilloBruni 9/20/2011 16:31'! handleLoginResult: aResultString "parse the result returned from a google authentification request. see http://code.google.com/apis/accounts/docs/AuthForInstalledApps.html#Request" | tokens | tokens := Character lf split: aResultString contents trimRight. tokens := tokens gather: [ :each | $= split: each ]. tokens := Dictionary newFromPairs: tokens. token := tokens at: #Auth ifAbsent: [ Error signal: 'Invalid login' ].! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GoogleToken class instanceVariableNames: ''! !GoogleToken class methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 9/20/2011 15:58'! service: aGoogleServiceName user: aUserString password: aPasswordString ^ self new service: aGoogleServiceName; user: aUserString; login: aPasswordString! ! Object subclass: #GoogleUser instanceVariableNames: 'email' classVariableNames: '' poolDictionaries: '' category: 'CI-Core'! !GoogleUser commentStamp: '' prior: 0! A user entity needed by Google to ensure authentification! !GoogleUser methodsFor: 'accessing' stamp: 'CamilloBruni 9/20/2011 13:10'! email ^ email! ! !GoogleUser methodsFor: 'accessing' stamp: 'CamilloBruni 9/20/2011 13:10'! email: anObject email := anObject! ! !GoogleUser methodsFor: 'authentification' stamp: 'CamilloBruni 9/20/2011 16:02'! authenticateSerivce: aGoogleServiceName with: aPasswordString ^ GoogleToken service: aGoogleServiceName user: email password: aPasswordString! ! !GoogleUser methodsFor: 'authentification' stamp: 'CamilloBruni 9/20/2011 16:05'! authenticateService: aGoogleServiceName with: aPasswordString " I create a new GoogleToken which is used for identifikation. aGoogleServiceName: a google service name. see http://code.google.com/apis/gdata/faq.html#clientlogin aPasswordString: a password for this user " ^ GoogleToken service: aGoogleServiceName user: self password: aPasswordString! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GoogleUser class instanceVariableNames: ''! !GoogleUser class methodsFor: 'as yet unclassified' stamp: 'MonkeyGalactikalIntegrator 12/13/2011 16:46'! fromXML: entryNode entryNode ifNil: [ ^ nil ]. ^ self email: (entryNode findTag: #name) text! ! !GoogleUser class methodsFor: 'instance creation' stamp: 'CamilloBruni 9/20/2011 13:26'! email: email ^ self new email: email; yourself! ! OrientedFillStyle subclass: #GradientFillStyle instanceVariableNames: 'colorRamp pixelRamp radial isTranslucent' classVariableNames: 'PixelRampCache' poolDictionaries: '' category: 'Balloon-Fills'! !GradientFillStyle commentStamp: 'efc 8/30/2005 21:44' prior: 0! 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: '*morphic-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: '*morphic-balloon' stamp: 'ar 6/18/1999 09:49'! addNewColorIn: aMorph event: evt ^self inform:'not yet implemented'! ! !GradientFillStyle methodsFor: '*morphic-balloon' stamp: 'ar 6/18/1999 07:25'! beLinearGradientIn: aMorph self radial: false. aMorph changed.! ! !GradientFillStyle methodsFor: '*morphic-balloon' stamp: 'ar 6/18/1999 07:25'! beRadialGradientIn: aMorph self radial: true. aMorph changed.! ! !GradientFillStyle methodsFor: '*morphic-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-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-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: '*morphic-balloon' stamp: 'dik 6/28/2010 00:22'! changeFirstColorIn: aMorph event: evt. ^self changeColorOf: aMorph rampIndex: 1! ! !GradientFillStyle methodsFor: '*morphic-balloon' stamp: 'dik 6/28/2010 00:22'! changeSecondColorIn: aMorph event: evt ^self changeColorOf: aMorph rampIndex: 2! ! !GradientFillStyle methodsFor: '*morphic-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: 'accessing' stamp: 'ar 11/7/1998 22:10'! colorRamp ^colorRamp! ! !GradientFillStyle methodsFor: 'accessing' stamp: 'ar 9/2/1999 14:30'! colorRamp: anArray colorRamp := anArray. pixelRamp := nil. isTranslucent := nil.! ! !GradientFillStyle methodsFor: 'accessing' stamp: 'efc 8/30/2005 21:42'! pixelRamp "Compute a pixel ramp, and cache it for future accesses" ^pixelRamp ifNil:[ "Insure the PixelRampCache is in place" PixelRampCache ifNil:[ self class initPixelRampCache ]. "Ask my cache for an existing instance if one is available" pixelRamp := PixelRampCache at: colorRamp ].! ! !GradientFillStyle methodsFor: 'accessing' stamp: 'ar 11/9/1998 14:06'! pixelRamp: aBitmap pixelRamp := aBitmap! ! !GradientFillStyle methodsFor: 'accessing' stamp: 'ar 8/31/2004 11:06'! radial ^radial ifNil:[false]! ! !GradientFillStyle methodsFor: 'accessing' stamp: 'ar 11/7/1998 22:11'! radial: aBoolean radial := aBoolean! ! !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: 'comparing' stamp: 'gvc 7/24/2007 12:22'! hash "Hash is implemented because #= is implemented." ^super hash bitXor: self pixelRamp hash! ! !GradientFillStyle methodsFor: 'converting' stamp: 'ar 8/25/2001 21:02'! asColor "Guess..." ^colorRamp first value mixed: 0.5 with: colorRamp last value! ! !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: 'testing' stamp: 'ar 11/7/1998 22:12'! isGradientFill ^true! ! !GradientFillStyle methodsFor: 'testing' stamp: 'ar 11/7/1998 22:13'! isRadialFill ^radial == true! ! !GradientFillStyle methodsFor: 'testing' stamp: 'ar 9/2/1999 14:29'! isTranslucent ^isTranslucent ifNil:[isTranslucent := self checkTranslucency]! ! !GradientFillStyle methodsFor: 'private' stamp: 'di 11/21/1999 20:18'! checkTranslucency ^colorRamp anySatisfy: [:any| any value isTranslucent]! ! !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: '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 class instanceVariableNames: ''! !GradientFillStyle class methodsFor: 'cleanup' stamp: 'StephaneDucasse 3/9/2010 16:32'! cleanUp "Flush caches" self initPixelRampCache! ! !GradientFillStyle class methodsFor: 'initialization' stamp: 'StephaneDucasse 3/9/2010 16:32'! initPixelRampCache "Create an LRUCache to use for accessing pixel ramps." "Details: 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 size: 32 factory: [:key| (GradientFillStyle new colorRamp: key) computePixelRampOfSize: 512] ! ! !GradientFillStyle class methodsFor: 'initialization' stamp: 'StephaneDucasse 3/9/2010 16:31'! pixelRampCache "Allow access to my cache of pixel ramps. This is mainly for debugging and profiling purposes." ^PixelRampCache ! ! !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: 'instance creation' stamp: 'ar 11/9/1998 14:05'! ramp: colorRamp ^self new colorRamp: colorRamp! ! !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! ! BitBlt subclass: #GrafPort instanceVariableNames: 'alpha fillPattern lastFont lastFontForegroundColor lastFontBackgroundColor' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Support'! !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: 'accessing' stamp: 'ar 2/17/2000 01:07'! alphaBits: a alpha := a! ! !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: 'MarcusDenker 5/25/2011 21:08'! displayScannerFor: para foreground: foreColor background: backColor ignoreColorChanges: shadowMode ^ (MultiDisplayScanner new text: para text textStyle: para textStyle foreground: foreColor background: backColor fillBlt: self ignoreColorChanges: shadowMode) setPort: self shallowCopy! ! !GrafPort methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/3/2012 16:40'! encryptedDisplayScannerFor: para foreground: foreColor background: backColor ignoreColorChanges: shadowMode ^ (EncryptedMultiDisplayScanner new text: para text textStyle: para textStyle foreground: foreColor background: backColor fillBlt: self ignoreColorChanges: shadowMode) setPort: self shallowCopy! ! !GrafPort methodsFor: 'accessing' stamp: 'ar 2/17/2000 01:09'! fillPattern: anObject fillPattern := anObject. self fillColor: anObject.! ! !GrafPort methodsFor: 'accessing' stamp: 'tween 4/5/2007 08:03'! lastFontForegroundColor ^lastFontForegroundColor! ! !GrafPort methodsFor: 'copying' stamp: 'ar 12/30/2001 20:32'! clippedBy: aRectangle ^ self copy clipBy: aRectangle! ! !GrafPort methodsFor: 'copying' stamp: 'GuillermoPolito 9/1/2010 18:39'! copyBits "Override copybits to do translucency if desired" (combinationRule >= 30 and: [combinationRule <= 31]) ifTrue: [self copyBitsTranslucent: (alpha ifNil:[255])] ifFalse: [super 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 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: '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/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: '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: '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: '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: '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).! ! !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: '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: 'private' stamp: 'yo 1/8/2005 09:13'! lastFont ^ lastFont. ! ! Object subclass: #GraphicFontSettings instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Settings-Graphics'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GraphicFontSettings class instanceVariableNames: ''! !GraphicFontSettings class methodsFor: 'fonts' stamp: 'AlainPlantec 9/18/2011 10:14'! fontChoiceButtonForStyle: aSymbol label: aLabel | label | label := StringMorph contents: aLabel asString font: (TextStyle default fontOfPointSize: (StandardFonts pointSizeForStyleNamed: aSymbol)). ^ (UITheme current 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: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 1/10/2010 08:15'! resetAllFontToDefault StandardFonts setAllStandardFontsTo: StandardFonts defaultFont. SettingBrowser refreshAllSettingBrowsers ! ! !GraphicFontSettings class methodsFor: 'fonts' stamp: 'AlainPlantec 9/17/2011 17:52'! 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: self theme smallRedoIcon. self theme buttonLabelForText: 'Force all' translated}); 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/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! ! LanguageEnvironment subclass: #GreekEnvironment instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Multilingual-Languages'! !GreekEnvironment commentStamp: '' prior: 0! This class provides the support for Greek. It is here, but most of the methods are not implemented yet. ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GreekEnvironment class instanceVariableNames: ''! !GreekEnvironment class methodsFor: 'subclass responsibilities' stamp: 'nice 5/1/2011 19:22'! leadingChar ^0! ! !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: 'subclass responsibilities' stamp: 'MarcusDenker 7/12/2012 20:46'! systemConverterClass OSPlatform isWin32 ifTrue: [^CP1253TextConverter ]. ^ ISO88597TextConverter. ! ! Error subclass: #GroupAlreadyExists instanceVariableNames: 'groupName' classVariableNames: '' poolDictionaries: '' category: 'GroupManager'! !GroupAlreadyExists commentStamp: '' prior: 0! 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 ^ groupName! ! !GroupAlreadyExists methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/24/2013 14:34'! groupName: anObject groupName := anObject! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GroupAlreadyExists class instanceVariableNames: ''! !GroupAlreadyExists class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 1/24/2013 14:35'! groupName: groupName ^ self new groupName: groupName; yourself! ! SystemAnnouncer subclass: #GroupAnnouncer instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'GroupManager-Announcements'! MorphTreeModel subclass: #GroupCreatorTreeModel instanceVariableNames: 'model' classVariableNames: '' poolDictionaries: '' category: 'GroupManagerUI'! !GroupCreatorTreeModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/18/2011 15:26'! groupsManager ^ self model groupsManager! ! !GroupCreatorTreeModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/15/2011 13:39'! model ^ model! ! !GroupCreatorTreeModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/15/2011 13:39'! model: anObject model := anObject! ! !GroupCreatorTreeModel methodsFor: 't - accessing' stamp: 'BenjaminVanRyseghem 9/15/2011 09:58'! rootItems ^ self groups! ! !GroupCreatorTreeModel methodsFor: 't - accessing' stamp: 'BenjaminVanRyseghem 3/15/2011 13:43'! rootNodeClassFromItem: anItem ^ GroupNode! ! !GroupCreatorTreeModel methodsFor: 't - accessing' stamp: 'BenjaminVanRyseghem 9/15/2011 16:49'! selection | list | list := self rootItems. (list notEmpty and: [ super selection isNil ]) ifTrue: [ self hardlySelectItem: list first ]. "self changed: #selection." ^ super selection! ! !GroupCreatorTreeModel methodsFor: 't - accessing' stamp: 'BenjaminVanRyseghem 3/15/2011 14:18'! selection: aNode super selection: aNode. self model updateSelectedNode.! ! !GroupCreatorTreeModel methodsFor: 't - accessing' stamp: 'BenjaminVanRyseghem 9/15/2011 16:34'! setSelectedNodeItem: anItem ^ self model setSelectedNodeItem: anItem! ! !GroupCreatorTreeModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/15/2011 13:44'! groups ^ self model groups! ! !GroupCreatorTreeModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 9/15/2011 16:50'! hardlySelectItem: anItem self selectNodePath: ((self setSelectedNodeItem: anItem)collect:#complexContents)! ! MorphTreeNodeModel subclass: #GroupNode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'GroupManagerUI'! !GroupNode methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/15/2011 13:46'! childNodeClassFromItem: anItem ^ ItemNode! ! !GroupNode methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/18/2011 15:27'! childrenItems ^ self item elements! ! !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! ! Morph subclass: #GroupWindowMorph instanceVariableNames: 'tabGroup' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Windows'! !GroupWindowMorph commentStamp: 'LaurentLaffont 7/12/2011 23:33' prior: 0! 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: 'accessing' stamp: 'GaryChambers 6/9/2011 12:36'! tabGroup ^ tabGroup! ! !GroupWindowMorph methodsFor: 'accessing' stamp: 'GaryChambers 6/9/2011 12:36'! tabGroup: anObject tabGroup := anObject! ! !GroupWindowMorph methodsFor: 'controls'! newAlphaImage: aForm help: helpText "Answer an alpha image morph." ^self theme newAlphaImageIn: self image: aForm help: helpText! ! !GroupWindowMorph methodsFor: 'controls'! 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: 'controls'! 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: 'controls'! 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'! 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: 'controls'! 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'! 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'! 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'! 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: 'controls'! 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'! 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'! 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'! 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'! 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'! 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'! 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'! 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'! 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: 'controls'! 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'! 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'! newButtonLabel: aString "Answer a new button text label." ^self newButtonLabelFor: nil label: aString getEnabled: nil! ! !GroupWindowMorph methodsFor: 'controls'! 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'! newCancelButton "Answer a new cancel button." ^self newCancelButtonFor: self! ! !GroupWindowMorph methodsFor: 'controls'! newCancelButtonFor: aModel "Answer a new cancel button." ^self theme newCancelButtonIn: self for: aModel! ! !GroupWindowMorph methodsFor: 'controls'! 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: 'controls'! 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'! newCloseButton "Answer a new close button." ^self newCloseButtonFor: self ! ! !GroupWindowMorph methodsFor: 'controls'! newCloseButtonFor: aModel "Answer a new close button." ^self theme newCloseButtonIn: self for: aModel! ! !GroupWindowMorph methodsFor: 'controls'! newCloseControlFor: aModel action: aValuable help: helpText "Answer a new cancel button." ^self theme newCloseControlIn: self for: aModel action: aValuable help: helpText! ! !GroupWindowMorph methodsFor: 'controls'! 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'! 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'! 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'! newColumn: controls "Answer a morph laid out with a column of controls." ^self theme newColumnIn: self for: controls! ! !GroupWindowMorph methodsFor: 'controls'! newDialogPanel "Answer a new main dialog panel." ^self theme newDialogPanelIn: self! ! !GroupWindowMorph methodsFor: 'controls'! 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: 'controls'! 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'! 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: 'controls'! 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: 'controls'! 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'! newEmbeddedMenu "Answer a new menu." ^self theme newEmbeddedMenuIn: self for: self! ! !GroupWindowMorph methodsFor: 'controls'! newExpander: aString "Answer an expander with the given label." ^self theme newExpanderIn: self label: aString forAll: #()! ! !GroupWindowMorph methodsFor: 'controls'! newExpander: aString for: aControl "Answer an expander with the given label and control." ^self theme newExpanderIn: self label: aString forAll: {aControl}! ! !GroupWindowMorph methodsFor: 'controls'! newExpander: aString forAll: controls "Answer an expander with the given label and controls." ^self theme newExpanderIn: self label: aString forAll: controls! ! !GroupWindowMorph methodsFor: 'controls'! 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'! 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'! 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: 'controls'! newGroupbox "Answer a plain groupbox." ^self theme newGroupboxIn: self! ! !GroupWindowMorph methodsFor: 'controls'! newGroupbox: aString "Answer a groupbox with the given label." ^self theme newGroupboxIn: self label: aString! ! !GroupWindowMorph methodsFor: 'controls'! newGroupbox: aString for: control "Answer a groupbox with the given label and control." ^self theme newGroupboxIn: self label: aString for: control! ! !GroupWindowMorph methodsFor: 'controls'! newGroupbox: aString forAll: controls "Answer a groupbox with the given label and controls." ^self theme newGroupboxIn: self label: aString forAll: controls! ! !GroupWindowMorph methodsFor: 'controls'! newGroupboxFor: control "Answer a plain groupbox with the given control." ^self theme newGroupboxIn: self for: control! ! !GroupWindowMorph methodsFor: 'controls'! newGroupboxForAll: controls "Answer a plain groupbox with the given controls." ^self theme newGroupboxIn: self forAll: controls! ! !GroupWindowMorph methodsFor: 'controls'! newHSVASelector: aColor help: helpText "Answer a hue-saturation-volume selector with the given color." ^self theme newHSVASelectorIn: self color: aColor help: helpText! ! !GroupWindowMorph methodsFor: 'controls'! 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'! 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'! newImage: aForm "Answer a new image." ^self theme newImageIn: self form: aForm! ! !GroupWindowMorph methodsFor: 'controls'! newImage: aForm size: aPoint "Answer a new image." ^self theme newImageIn: self form: aForm size: aPoint! ! !GroupWindowMorph methodsFor: 'controls'! 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: 'controls'! newLabel: aString "Answer a new text label." ^self newLabelFor: nil label: aString getEnabled: nil! ! !GroupWindowMorph methodsFor: 'controls'! newLabelFor: aModel getLabel: labelSel getEnabled: enabledSel "Answer a new text label." ^self theme newLabelIn: self for: aModel getLabel: labelSel getEnabled: enabledSel! ! !GroupWindowMorph methodsFor: 'controls'! newLabelFor: aModel label: aString getEnabled: enabledSel "Answer a new text label." ^self theme newLabelIn: self for: aModel label: aString getEnabled: enabledSel! ! !GroupWindowMorph methodsFor: 'controls'! 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'! 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'! 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'! 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'! newMenu "Answer a new menu." ^self theme newMenuIn: self for: self! ! !GroupWindowMorph methodsFor: 'controls'! newMenuFor: aModel "Answer a new menu." ^self theme newMenuIn: self for: aModel! ! !GroupWindowMorph methodsFor: 'controls'! 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'! 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'! 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: 'controls'! 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'! 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'! 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'! newNoButton "Answer a new No button." ^self newNoButtonFor: self! ! !GroupWindowMorph methodsFor: 'controls'! newNoButtonFor: aModel "Answer a new No button." ^self theme newNoButtonIn: self for: aModel! ! !GroupWindowMorph methodsFor: 'controls'! newOKButton "Answer a new OK button." ^self newOKButtonFor: self! ! !GroupWindowMorph methodsFor: 'controls'! newOKButtonFor: aModel "Answer a new OK button." ^self newOKButtonFor: aModel getEnabled: nil! ! !GroupWindowMorph methodsFor: 'controls'! newOKButtonFor: aModel getEnabled: enabledSel "Answer a new OK button." ^self theme newOKButtonIn: self for: aModel getEnabled: enabledSel! ! !GroupWindowMorph methodsFor: 'controls'! 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'! newPanel "Answer a new panel." ^self theme newPanelIn: self! ! !GroupWindowMorph methodsFor: 'controls'! newPluggableDialogWindow "Answer a new pluggable dialog." ^self newPluggableDialogWindow: 'Dialog'! ! !GroupWindowMorph methodsFor: 'controls'! newPluggableDialogWindow: title "Answer a new pluggable dialog with the given content." ^self newPluggableDialogWindow: title for: nil! ! !GroupWindowMorph methodsFor: 'controls'! newPluggableDialogWindow: title for: contentMorph "Answer a new pluggable dialog with the given content." ^self theme newPluggableDialogWindowIn: self title: title for: contentMorph! ! !GroupWindowMorph methodsFor: 'controls'! 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'! 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'! newRow "Answer a morph laid out as a row." ^self theme newRowIn: self for: #()! ! !GroupWindowMorph methodsFor: 'controls'! newRow: controls "Answer a morph laid out with a row of controls." ^self theme newRowIn: self for: controls! ! !GroupWindowMorph methodsFor: 'controls'! newSVSelector: aColor help: helpText "Answer a saturation-volume selector with the given color." ^self theme newSVSelectorIn: self color: aColor help: helpText! ! !GroupWindowMorph methodsFor: 'controls'! newScrollPaneFor: aMorph "Answer a new scroll pane morph to scroll the given morph." ^self theme newScrollPaneIn: self for: aMorph! ! !GroupWindowMorph methodsFor: 'controls'! newSeparator "Answer an horizontal separator." ^self theme newSeparatorIn: self! ! !GroupWindowMorph methodsFor: 'controls'! 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: 'controls'! 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'! 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: 'controls'! newStack "Answer a morph laid out as a stack." ^self theme newStackIn: self for: #()! ! !GroupWindowMorph methodsFor: 'controls'! newStack: controls "Answer a morph laid out with a stack of controls." ^self theme newStackIn: self for: controls! ! !GroupWindowMorph methodsFor: 'controls'! newString: aStringOrText "Answer a new embossed string." ^self theme newStringIn: self label: aStringOrText font: self theme labelFont style: #plain! ! !GroupWindowMorph methodsFor: 'controls'! newString: aStringOrText font: aFont style: aStyle "Answer a new embossed string." ^self theme newStringIn: self label: aStringOrText font: aFont style: aStyle! ! !GroupWindowMorph methodsFor: 'controls'! newString: aStringOrText style: aStyle "Answer a new embossed string." ^self theme newStringIn: self label: aStringOrText font: self theme labelFont style: aStyle! ! !GroupWindowMorph methodsFor: 'controls'! newTabGroup: labelsAndPages "Answer a tab group with the given tab labels associated with pages." ^self theme newTabGroupIn: self for: labelsAndPages! ! !GroupWindowMorph methodsFor: 'controls'! newText: aStringOrText "Answer a new text." ^self theme newTextIn: self text: aStringOrText! ! !GroupWindowMorph methodsFor: 'controls'! 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'! newTextEditorFor: aModel getText: getSel setText: setSel getEnabled: enabledSel "Answer a text editor for the given model." ^self theme newTextEditorIn: self for: aModel getText: getSel setText: setSel getEnabled: enabledSel ! ! !GroupWindowMorph methodsFor: 'controls'! 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'! 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'! 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'! 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: 'controls'! 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'! newToolDockingBar "Answer a tool docking bar." ^self theme newToolDockingBarIn: self! ! !GroupWindowMorph methodsFor: 'controls'! newToolSpacer "Answer a tool spacer." ^self theme newToolSpacerIn: self! ! !GroupWindowMorph methodsFor: 'controls'! newToolbar "Answer a toolbar." ^self theme newToolbarIn: self! ! !GroupWindowMorph methodsFor: 'controls'! newToolbar: controls "Answer a toolbar with the given controls." ^self theme newToolbarIn: self for: controls! ! !GroupWindowMorph methodsFor: 'controls'! newToolbarHandle "Answer a toolbar handle." ^self theme newToolbarHandleIn: self! ! !GroupWindowMorph methodsFor: 'controls'! 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: 'controls'! newVerticalSeparator "Answer a vertical separator." ^self theme newVerticalSeparatorIn: self! ! !GroupWindowMorph methodsFor: 'controls'! newWindowFor: aModel title: titleString "Answer a new window morph." ^self theme newWindowIn: self for: aModel title: titleString! ! !GroupWindowMorph methodsFor: 'controls'! newWorkArea "Answer a new work area morph." ^self theme newWorkAreaIn: self! ! !GroupWindowMorph methodsFor: 'controls'! newYesButton "Answer a new Yes button." ^self newYesButtonFor: self! ! !GroupWindowMorph methodsFor: 'controls'! newYesButtonFor: aModel "Answer a new yes button." ^self theme newYesButtonIn: self for: aModel! ! !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: '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: '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: 'initialize' 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: 'layout' stamp: 'GaryChambers 6/9/2011 13:12'! acceptDroppingMorph: aSystemWindow event: evt "Add the window." self addWindow: aSystemWindow! ! !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: 'services'! abort: aStringOrText "Open an error dialog." ^self abort: aStringOrText title: 'Error' translated! ! !GroupWindowMorph methodsFor: 'services'! abort: aStringOrText title: aString "Open an error dialog." ^self theme abortIn: self text: aStringOrText title: aString! ! !GroupWindowMorph methodsFor: 'services'! alert: aStringOrText "Open an alert dialog." ^self alert: aStringOrText title: 'Alert' translated! ! !GroupWindowMorph methodsFor: 'services'! alert: aStringOrText title: aString "Open an alert dialog." ^self alert: aStringOrText title: aString configure: [:d | ]! ! !GroupWindowMorph methodsFor: 'services'! 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: 'services'! 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: 'services'! chooseColor "Answer the result of a color selector dialog ." ^self chooseColor: Color black! ! !GroupWindowMorph methodsFor: 'services'! 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: 'services'! 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: 'services'! chooseDirectory: title "Answer the result of a file dialog with the given title, answer a directory." ^self chooseDirectory: title path: nil! ! !GroupWindowMorph methodsFor: 'services'! 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: 'services'! chooseDropList: aStringOrText list: aList "Open a drop list chooser dialog." ^self chooseDropList: aStringOrText title: 'Choose' translated list: aList! ! !GroupWindowMorph methodsFor: 'services'! 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'! 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: 'services'! chooseFont "Answer the result of a font selector dialog." ^self chooseFont: nil! ! !GroupWindowMorph methodsFor: 'services'! 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: 'services'! deny: aStringOrText "Open a denial dialog." ^self deny: aStringOrText title: 'Access Denied' translated! ! !GroupWindowMorph methodsFor: 'services'! deny: aStringOrText title: aString "Open a denial dialog." ^self theme denyIn: self text: aStringOrText title: aString! ! !GroupWindowMorph methodsFor: 'services'! fileOpen: title "Answer the result of a file open dialog with the given title." ^self fileOpen: title extensions: nil! ! !GroupWindowMorph methodsFor: 'services'! 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: 'services'! 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: 'services'! 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: 'services'! fileSave: title "Answer the result of a file save dialog with the given title." ^self fileSave: title extensions: nil path: nil! ! !GroupWindowMorph methodsFor: 'services'! 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: 'services'! 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: 'services'! 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: 'services'! longMessage: aStringOrText title: aString "Open a (long) message dialog." ^self theme longMessageIn: self text: aStringOrText title: aString! ! !GroupWindowMorph methodsFor: 'services'! message: aStringOrText "Open a message dialog." ^self message: aStringOrText title: 'Information' translated! ! !GroupWindowMorph methodsFor: 'services'! message: aStringOrText title: aString "Open a message dialog." ^self theme messageIn: self text: aStringOrText title: aString! ! !GroupWindowMorph methodsFor: 'services'! proceed: aStringOrText "Open a proceed dialog." ^self proceed: aStringOrText title: 'Proceed' translated! ! !GroupWindowMorph methodsFor: 'services'! 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: 'services'! question: aStringOrText "Open a question dialog." ^self question: aStringOrText title: 'Question' translated! ! !GroupWindowMorph methodsFor: 'services'! 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: 'services'! questionWithoutCancel: aStringOrText "Open a question dialog." ^self questionWithoutCancel: aStringOrText title: 'Question' translated! ! !GroupWindowMorph methodsFor: 'services'! 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: 'services'! textEntry: aStringOrText "Open a text entry dialog." ^self textEntry: aStringOrText title: 'Entry' translated! ! !GroupWindowMorph methodsFor: 'services'! textEntry: aStringOrText title: aString "Open a text entry dialog." ^self textEntry: aStringOrText title: aString entryText: ''! ! !GroupWindowMorph methodsFor: 'services'! textEntry: aStringOrText title: aString entryText: defaultEntryText "Open a text entry dialog." ^self theme textEntryIn: self text: aStringOrText title: aString entryText: defaultEntryText! ! !GroupWindowMorph methodsFor: 'testing' stamp: 'LaurentLaffont 7/5/2011 23:37'! isActive ^ false! ! !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: 'theme'! theme "Answer the ui theme that provides controls." ^UITheme current! ! !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: '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: 'windows' stamp: 'PavelKrivanek 7/4/2012 11:51'! 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 do: [:ann | self tabGroup relabelPage: ann window with: (self tabLabelFor: ann window)]! ! !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: 'windows' stamp: 'GaryChambers 6/9/2011 12:35'! newTabGroup "Answer a new tab group." ^(self newTabGroup: #()) cornerStyle: #square! ! !GroupWindowMorph methodsFor: 'windows' stamp: 'GaryChambers 6/9/2011 12:40'! 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: self theme smallWindowIcon. self tabGroup page ifNotNil: [: page | page model addModelItemsToWindowMenu: aMenu]. aMenu popUpEvent: self currentEvent in: self world! ! !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: '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 class uses: TEasilyThemed classTrait instanceVariableNames: ''! MorphicModel subclass: #GroupboxMorph instanceVariableNames: 'contentMorph labelMorph getContentSelector' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !GroupboxMorph commentStamp: 'gvc 5/18/2007 12:36' prior: 0! Groupbox with title with a vertical layout. Appears in a lighter colour than the owner's pane colour.! !GroupboxMorph methodsFor: 'accessing' stamp: 'gvc 8/19/2006 16:31'! contentMorph "Answer the value of contentMorph" ^ contentMorph! ! !GroupboxMorph methodsFor: 'accessing' stamp: 'gvc 8/19/2006 16:31'! contentMorph: anObject "Set the value of contentMorph" contentMorph := anObject! ! !GroupboxMorph methodsFor: 'accessing' stamp: 'gvc 9/8/2006 14:55'! font "Answer the label font" ^self labelMorph font! ! !GroupboxMorph methodsFor: 'accessing' stamp: 'gvc 9/8/2006 14:55'! font: aFont "Set the label font" self labelMorph font: aFont! ! !GroupboxMorph methodsFor: 'accessing' stamp: 'GaryChambers 7/26/2011 10:11'! getContentSelector ^ getContentSelector! ! !GroupboxMorph methodsFor: 'accessing' stamp: 'GaryChambers 7/26/2011 10:11'! getContentSelector: anObject getContentSelector := anObject! ! !GroupboxMorph methodsFor: 'accessing' stamp: 'gvc 8/19/2006 16:31'! labelMorph "Answer the value of labelMorph" ^ labelMorph! ! !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/20/2006 11:24'! addContentMorph: aMorph "Add a morph to the content." ^self contentMorph addMorphBack: aMorph! ! !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: '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: '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: '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: '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: 'as yet unclassified' 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: 'gvc 8/20/2006 11:26'! label "Answer the contents of the label morph." ^self labelMorph contents! ! !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 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: 'as yet unclassified' stamp: 'gvc 1/25/2008 14:33'! newContentMorph "Answer a new content morph" |p| p := PanelMorph new roundedCorners: self roundedCorners; changeTableLayout; layoutInset: (4@4 corner: 4@4); cellInset: 8; vResizing: #spaceFill; hResizing: #spaceFill. p borderStyle: (self theme groupPanelBorderStyleFor: p). ^p! ! !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: '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: 'GaryChambers 12/7/2011 15:26'! replaceContentMorph: aMorph "Replace the content." self contentMorph removeAllMorphs; addMorphBack: aMorph. self adoptPaneColor: super paneColorOrNil. ^aMorph ! ! !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: '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]] ! ! Error subclass: #GroupsAlreadyExists instanceVariableNames: 'groupName' classVariableNames: '' poolDictionaries: '' category: 'GroupManager'! !GroupsAlreadyExists commentStamp: '' prior: 0! A GroupsAlreadyExists is fired when a set of groups already exists firstGroup points to a correct group which was part of the set! !GroupsAlreadyExists methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/24/2013 18:11'! groupName ^ groupName! ! !GroupsAlreadyExists methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/24/2013 18:11'! groupName: anObject groupName := anObject! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GroupsAlreadyExists class instanceVariableNames: ''! !GroupsAlreadyExists class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 1/24/2013 18:11'! groupName: groupName ^ self new groupName: groupName; yourself! ! Object subclass: #GroupsHolder instanceVariableNames: 'groups' classVariableNames: '' poolDictionaries: '' category: 'GroupManager'! !GroupsHolder commentStamp: '' prior: 0! A GroupsHolder is a simple object which manage a collection of groups! !GroupsHolder methodsFor: 'adding' stamp: 'BenjaminVanRyseghem 3/28/2011 14:04'! add: aCollection into: aGroup aGroup ifAllowed: [ aGroup addAll: aCollection ] ifNot: [ self openReadOnlyError ]! ! !GroupsHolder 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 ).! ! !GroupsHolder 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 ].! ! !GroupsHolder 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 ]! ! !GroupsHolder 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]! ! !GroupsHolder 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]! ! !GroupsHolder 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]! ! !GroupsHolder 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]! ! !GroupsHolder 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]! ! !GroupsHolder 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]! ! !GroupsHolder 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]! ! !GroupsHolder 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]! ! !GroupsHolder methodsFor: 'dynamic group' stamp: 'BenjaminVanRyseghem 3/2/2012 17:32'! addAnEmptyDynamicGroupNamed: aName ^ (self addADynamicGroupNamed: aName block: [ {} ]) isFillable: true; yourself! ! !GroupsHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/2/2012 17:24'! addClasses: aCollection into: aGroup aGroup addClasses: aCollection! ! !GroupsHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/18/2011 14:40'! groupNamed: aString ^ self groups detect: [:each | each name = aString]! ! !GroupsHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/18/2011 15:04'! groups ^ groups ifNil: [ groups := OrderedCollection new ]! ! !GroupsHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/18/2011 14:32'! groupsNames ^ self groups collect: [:group | group name ]! ! !GroupsHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/14/2011 16:00'! includes: aGroup ^ self groups includes: aGroup! ! !GroupsHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/18/2011 14:37'! includesAGroupNamed: aName ^ self groupsNames includes: aName! ! !GroupsHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 8/21/2011 11:06'! isEmpty ^ self groups isEmpty.! ! !GroupsHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/18/2011 16:58'! remove: aClass from: aGroup ^ aGroup ifAllowed: [ aGroup remove: aClass ] ifNot: [ self openReadOnlyError ]! ! !GroupsHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/28/2011 17:22'! removeAGroup: aGroup | yesIWantToRemoveTheGroup | yesIWantToRemoveTheGroup := self openRemoveDialogOn: aGroup. yesIWantToRemoveTheGroup ifFalse: [ ^ nil ]. ^ self removeAGroupSilently: aGroup ! ! !GroupsHolder 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! ! !GroupsHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/1/2012 00:55'! removeClass: aClass from: aStaticGroup ^ aStaticGroup ifAllowed: [ aStaticGroup removeClass: aClass ] ifNot: [ self openReadOnlyError ]! ! !GroupsHolder 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 ! ! !GroupsHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/18/2011 14:54'! sort: aBlock ^ groups := self groups sort: aBlock! ! !GroupsHolder methodsFor: 'windows' stamp: 'BenjaminVanRyseghem 1/24/2013 14:40'! openError: name (GroupAlreadyExists groupName: name) signal! ! !GroupsHolder methodsFor: 'windows' stamp: 'BenjaminVanRyseghem 3/22/2011 18:14'! openReadOnlyError UIManager default alert: 'This group is read only' title: 'Access error'! ! !GroupsHolder 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)! ! Object subclass: #GroupsManager instanceVariableNames: 'groups' classVariableNames: 'CurrentManager' poolDictionaries: '' category: 'GroupManager'! !GroupsManager commentStamp: '' prior: 0! A GroupsManager should be a singleton. It manages all the groups of the system, to be able to share groups among tools! !GroupsManager methodsFor: 'protocol' stamp: 'MarianoMartinezPeck 8/5/2012 15:56'! register: aGroup groups add: aGroup. GroupAnnouncer uniqueInstance announce: (AGroupHasBeenRegistered with: aGroup)! ! !GroupsManager methodsFor: 'protocol' stamp: 'MarianoMartinezPeck 8/5/2012 15:56'! unregister: aGroup groups remove: aGroup. GroupAnnouncer uniqueInstance announce: (AGroupHasBeenUnregistered with: aGroup)! ! !GroupsManager methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/21/2011 16:11'! initialize super initialize. groups := OrderedCollection new! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GroupsManager class instanceVariableNames: ''! !GroupsManager class methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/21/2011 16:08'! current ^ CurrentManager ifNil: [ CurrentManager := self new ]! ! !GroupsManager class methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/21/2011 16:08'! setCurrentManager: aManager CurrentManager := aManager! ! !GroupsManager class methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/21/2011 16:09'! register: aGroup self current register: aGroup! ! !GroupsManager class methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/21/2011 16:09'! unregister: aGroup self current unregister: aGroup! ! TextMorph subclass: #GrowlMorph instanceVariableNames: 'dismissHandle vanishTime alpha actionBlock vanishDelay attr labelAttr contentsAttr' classVariableNames: 'DefaultBackgroundColor Position' poolDictionaries: '' category: 'Growl'! !GrowlMorph commentStamp: 'TudorGirba 10/25/2011 17:14' prior: 0! 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: 'accessing' stamp: 'StephaneDucasse 8/7/2011 17:02'! alpha ^ alpha ! ! !GrowlMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/1/2012 23:34'! alpha: newAlpha "self alpha = newAlpha ifTrue: [^ self]." alpha := newAlpha. labelAttr color: (self labelColor alpha: alpha). contentsAttr color: (self labelColor 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: 'accessing' stamp: 'BenjaminVanRyseghem 4/19/2012 23:34'! backgroundColor ^ backgroundColor ifNil: [ backgroundColor := self defaultBackgroundColor ]! ! !GrowlMorph methodsFor: 'accessing' stamp: 'TudorGirba 8/8/2011 11:24'! contentsColor ^ self theme growlContentsColorFor: self! ! !GrowlMorph methodsFor: 'accessing' stamp: 'TudorGirba 8/8/2011 11:26'! labelColor ^ self theme growlLabelColorFor: self! ! !GrowlMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 7/19/2011 19:01'! vanishDelay ^ vanishDelay! ! !GrowlMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/1/2012 23:31'! vanishDelay: aDuration vanishDelay := aDuration. self resetVanishTimer! ! !GrowlMorph methodsFor: 'building' stamp: 'StephaneDucasse 7/19/2011 19:38'! actionBlock: aBlock actionBlock := aBlock! ! !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: 'building' stamp: 'CamilloBruni 7/8/2012 15:22'! 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: 'default' stamp: 'TudorGirba 8/8/2011 11:21'! defaultBackgroundColor ^ self theme growlFillColorFor: self! ! !GrowlMorph methodsFor: 'default' stamp: 'TudorGirba 8/8/2011 11:22'! defaultBorderColor ^ self theme growlBorderColorFor: self! ! !GrowlMorph methodsFor: 'default' stamp: 'StephaneDucasse 7/16/2011 14:33'! defaultTextStyle ^ TextStyle actualTextStyles at: #Accuny! ! !GrowlMorph methodsFor: 'default' stamp: 'BenjaminVanRyseghem 3/1/2012 23:35'! defaultVanishDelay ^ 1 seconds! ! !GrowlMorph methodsFor: 'default' stamp: 'StephaneDucasse 8/7/2011 18:18'! minimumExtent ^ 256@38! ! !GrowlMorph methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 3/2/2012 00:12'! contentsAttributes ^ { contentsAttr. TextAlignment centered. TextFontChange font2. }! ! !GrowlMorph methodsFor: 'initialize' stamp: 'TudorGirba 8/8/2011 11:32'! createDismissHandle | handle | handle := self theme growlDismissHandleFor: self. handle on: #mouseUp send: #delete to: self. ^ handle! ! !GrowlMorph methodsFor: 'initialize' 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: 'initialize' stamp: 'StephaneDucasse 8/7/2011 18:10'! initializeContentsAttributes contentsAttr := TextColor color: self contentsColor. ! ! !GrowlMorph methodsFor: 'initialize' stamp: 'StephaneDucasse 8/7/2011 18:10'! initializeLabelAttributes labelAttr := TextColor color: self labelColor. ! ! !GrowlMorph methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 3/2/2012 00:12'! labelAttributes ^ { labelAttr. TextAlignment centered. TextFontChange font4. TextEmphasis bold. }! ! !GrowlMorph methodsFor: 'initialize' stamp: 'StephaneDucasse 7/19/2011 19:21'! nextColorStep: aColor ^ aColor alpha: self alpha! ! !GrowlMorph methodsFor: 'interaction' stamp: 'StephaneDucasse 7/19/2011 19:32'! handlesMouseDown: evt ^ actionBlock notNil or: [super handlesMouseDown: evt]! ! !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: '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: 'internal' stamp: 'StephaneDucasse 7/19/2011 19:27'! openInWorld self position: self unoccupiedPosition. super openInWorld! ! !GrowlMorph methodsFor: 'internal' stamp: 'StephaneDucasse 7/19/2011 19:12'! resetAlpha ^ self alpha: 0.9! ! !GrowlMorph methodsFor: 'internal' stamp: 'BenjaminVanRyseghem 3/1/2012 23:34'! resetVanishTimer vanishTime := TimeStamp now + self vanishDelay. self resetAlpha.! ! !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: '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: '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: '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: '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: 'stepping' stamp: 'StephaneDucasse 7/19/2011 19:45'! enabled ^ false! ! !GrowlMorph methodsFor: 'stepping' stamp: 'BenjaminVanRyseghem 3/2/2012 01:26'! step (self containsPoint: ActiveHand position) ifTrue: [ self resetAlpha. ^ self]. vanishTime ifNotNil: [TimeStamp now < vanishTime ifTrue: [^self]]. self alpha: self alpha - 0.05.! ! !GrowlMorph methodsFor: 'stepping' stamp: 'TudorGirba 10/25/2011 17:15'! stepTime ^ 100! ! !GrowlMorph methodsFor: 'stepping' stamp: 'StephaneDucasse 7/19/2011 19:03'! wantsSteps ^ true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GrowlMorph class instanceVariableNames: ''! !GrowlMorph class methodsFor: 'instance creation' stamp: 'StephaneDucasse 7/19/2011 19:36'! contents: contentString ^ self new label: '' contents: contentString; yourself! ! !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: 'StephaneDucasse 7/19/2011 19:38'! openWithContents: contentString ^ (self contents: contentString) openInWorld! ! !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: '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: 'position' stamp: 'BenjaminVanRyseghem 3/2/2012 00:51'! position ^ Position ifNil: [ Position := #bottomLeft ]! ! !GrowlMorph class methodsFor: 'position' stamp: 'BenjaminVanRyseghem 3/2/2012 01:05'! position: aSymbol (self possiblePositions includes: aSymbol) ifFalse: [ ^ self ]. Position := aSymbol! ! !GrowlMorph class methodsFor: 'position' stamp: 'BenjaminVanRyseghem 3/2/2012 01:06'! possiblePositions ^ #( bottomRight bottomLeft topRight topLeft )! ! SingleTreeTest subclass: #GuideTest instanceVariableNames: 'guide visited' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Tests-Core'! !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: '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 methodsFor: 'visitor' stamp: 'cwp 10/29/2009 21:54'! visitFile: aReference visited add: aReference.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! GuideTest class instanceVariableNames: ''! !GuideTest class methodsFor: 'testing' stamp: 'EstebanLorenzano 4/3/2012 09:43'! isAbstract ^ self name = #GuideTest! ! BracketSliderMorph subclass: #HColorSelectorMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !HColorSelectorMorph commentStamp: 'gvc 5/18/2007 12:58' prior: 0! ColorComponentSelector showing a hue rainbow palette.! !HColorSelectorMorph methodsFor: 'accessing' stamp: 'gvc 9/19/2006 14:13'! color: aColor "Ignore to preserve fill style." ! ! !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])! ! HDReport subclass: #HDChangeReport instanceVariableNames: 'gofer' classVariableNames: '' poolDictionaries: '' category: 'HudsonBuildTools20'! !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: 'accessing' stamp: 'lr 9/29/2010 13:27'! resolved ^ gofer resolved! ! !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 13:42'! generateChangeAddition: 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: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:41'! generateChangeRemoval: 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 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: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: 'running' stamp: 'CamilloBruni 10/20/2012 22:48'! run 'changelog.xml' asFileReference ensureDeleted writeStreamDo: [ :stream| self generateOn: stream ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HDChangeReport class instanceVariableNames: ''! !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'! runPackage: aString ^ self runPackages: (Array with: aString)! ! !HDChangeReport class methodsFor: 'running' stamp: 'lr 9/29/2010 11:14'! runPackages: aCollectionOfStrings ^ (self new initializeOn: aCollectionOfStrings) run! ! HDTestReport subclass: #HDCoverageReport instanceVariableNames: 'packages wrappers covered' classVariableNames: '' poolDictionaries: '' category: 'HudsonBuildTools20'! !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: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: '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: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! ! !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: '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: '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: 'running' stamp: 'lr 7/5/2010 08:22'! tearDown wrappers do: [ :each | each uninstall ]. super tearDown. self generate! ! !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: 'private' stamp: 'lr 6/9/2010 10:58'! ignoredSelectors ^ #(packageNamesUnderTest classNamesNotUnderTest)! ! !HDCoverageReport methodsFor: 'private' stamp: 'lr 6/9/2010 11:01'! methodsIn: aPackage aPackage isNil ifTrue: [ ^ #() ]. ^ aPackage methods reject: [ :method | (self ignoredSelectors includes: method methodSymbol) 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! ! HDReport subclass: #HDLintReport instanceVariableNames: 'environment rules' classVariableNames: '' poolDictionaries: '' category: 'HudsonBuildTools20'! !HDLintReport methodsFor: 'generating' stamp: 'CamilloBruni 10/20/2012 22:49'! 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 ensureDeleted writeStreamDo: [ :stream | stream nextPutAll: sourceStream contents ]! ! !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: '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: '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 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: '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: 'running' stamp: 'CamilloBruni 10/20/2012 22:49'! run RBSmalllintChecker runRule: (RBCompositeLintRule rules: rules) onEnvironment: environment. (environment name , '-Lint.xml') asFileReference ensureDeleted writeStreamDo: [ :stream| self generateOn: stream ]! ! !HDLintReport methodsFor: 'testing' stamp: 'lr 5/15/2010 14:05'! isClassEnvironment: anEnvironment ^ #(CategoryEnvironment ClassEnvironment VariableEnvironment) includes: anEnvironment class name! ! !HDLintReport methodsFor: 'testing' stamp: 'lr 5/15/2010 14:05'! isSelectorEnvironment: anEnvironment ^ #(SelectorEnvironment ParseTreeEnvironment VariableEnvironment) includes: anEnvironment class name! ! !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 instanceVariableNames: ''! !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! ! Object subclass: #HDReport instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HudsonBuildTools20'! !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 methodsFor: 'private' stamp: 'lr 5/14/2010 08:36'! encode: aString ^ ((aString asString copyReplaceAll: '&' with: '&') copyReplaceAll: '"' with: '"') copyReplaceAll: '<' with: '<'! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HDReport class instanceVariableNames: ''! !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:17'! runCategory: aString ^ self runClasses: (Smalltalk organization classesInCategory: aString) named: aString! ! !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:16'! runPackage: aString self subclassResponsibility! ! !HDReport class methodsFor: 'running' stamp: 'lr 5/14/2010 09:17'! runPackages: aCollectionOfStrings ^ aCollectionOfStrings do: [ :each | self runPackage: each ]! ! ProtoObject subclass: #HDTestCoverage instanceVariableNames: 'hasRun reference method' classVariableNames: '' poolDictionaries: '' category: 'HudsonBuildTools20'! !HDTestCoverage methodsFor: 'accessing' stamp: 'lr 7/5/2010 08:23'! method ^ method! ! !HDTestCoverage methodsFor: 'accessing' stamp: 'lr 7/5/2010 08:24'! reference ^ reference! ! !HDTestCoverage methodsFor: 'actions' stamp: 'lr 3/30/2011 08:30'! install reference actualClass methodDictionary at: reference methodSymbol put: self. self flushCache! ! !HDTestCoverage methodsFor: 'actions' stamp: 'lr 3/30/2011 08:30'! uninstall reference actualClass methodDictionary at: reference methodSymbol put: method. self 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: 'initialization' stamp: 'lr 7/6/2010 11:16'! initializeOn: aMethodReference hasRun := false. reference := aMethodReference. method := reference compiledMethod! ! !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: 'private' stamp: 'lr 3/30/2011 08:30'! flushCache reference methodSymbol flushCache. method flushCache! ! !HDTestCoverage methodsFor: 'private' stamp: 'lr 7/6/2010 11:16'! mark hasRun := true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HDTestCoverage class instanceVariableNames: ''! !HDTestCoverage class methodsFor: 'instance creation' stamp: 'lr 6/9/2010 11:05'! on: aMethodReference ^ self new initializeOn: aMethodReference! ! HDReport subclass: #HDTestReport instanceVariableNames: 'suite stream suitePosition suiteTime suiteFailures suiteErrors progressFile' classVariableNames: '' poolDictionaries: '' category: 'HudsonBuildTools20'! !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: 'IgorStasenko 1/6/2012 15:12'! done "just close the file" [ progressFile close ] on: Error do: []! ! !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: 'running' stamp: 'JohanBrichau 10/25/2010 23:05'! runAll suite tests do: [ :each | each run: self ]! ! !HDTestReport methodsFor: 'running' stamp: 'MarcusDenker 2/15/2013 16:29'! runCase: aTestCase | error time stack | time := [[[ 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..." ]] timeToRun. self beginTestCase: aTestCase time: time. (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: 'running' stamp: 'EstebanLorenzano 2/18/2013 18:39'! 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. [ Smalltalk tools debugger serializeTestFailureContext: context sender toFileNamed: aTestCase class name asString,'-', aTestCase selector, '.fuel' ] on: Error do: [:err| "simply continue..." ] ! ! !HDTestReport methodsFor: 'running' stamp: 'CamilloBruni 7/20/2012 16:33'! setUp progressFile nextPutAll: 'running suite: '; nextPutAll: suite name ; crlf; flush. stream := StandardFileStream forceNewFileNamed: suite name , '-Test.xml'. stream nextPutAll: ''; nextPut: Character 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: $ ); nextPut: Character lf. "Initialize the test resources." suite resources do: [ :each | each isAvailable ifFalse: [ each signalInitializationError ] ]! ! !HDTestReport methodsFor: 'running' stamp: 'CamilloBruni 7/20/2012 16:34'! tearDown suite resources do: [ :each | each reset ]. stream tab; nextPutAll: ''; nextPut: Character lf. stream tab; nextPutAll: ''; nextPut: Character lf. stream nextPutAll: ''. stream position: suitePosition. stream nextPutAll: ' failures="'; print: suiteFailures; nextPutAll: '" errors="'; print: suiteErrors; nextPutAll: '" time="'; print: suiteTime / 1000.0; nextPutAll: '">'. stream close! ! !HDTestReport methodsFor: 'private' stamp: 'CamilloBruni 7/20/2012 16:33'! beginTestCase: aTestCase time: time stream tab; nextPutAll: ''; nextPut: Character lf. progressFile nextPutAll: 'starting testcase: ' ; nextPutAll: aTestCase class name; nextPutAll:'>>'; nextPutAll: aTestCase selector; nextPutAll: ' ... '; flush. ! ! !HDTestReport methodsFor: 'private' stamp: 'CamilloBruni 7/20/2012 16:33'! endTestCase stream tab; nextPutAll: ''; nextPut: Character lf. progressFile nextPutAll: 'finished' ; crlf; flush. ! ! !HDTestReport methodsFor: 'private' stamp: 'pmm 6/6/2010 18:13'! 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; nextPut: Character lf. context := context sender ] ] ! ! !HDTestReport methodsFor: 'private' stamp: 'CamilloBruni 7/20/2012 16:52'! writeError: error stack: stack suiteErrors := suiteErrors + 1. stream tab; tab; nextPutAll: ''; nextPutAll: (self encode: stack).! ! !HDTestReport methodsFor: 'private' stamp: 'CamilloBruni 7/20/2012 16:52'! writeFailure: error stack: stack suiteFailures := suiteFailures + 1. stream tab; tab; nextPutAll: '' prior: 0! 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: 'cmm 12/2/2006 14:57'! destroy key destroy! ! !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: '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: '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: 'printing' stamp: 'len 8/3/2002 02:08'! printOn: aStream aStream nextPutAll: 'HMAC-'; print: hash! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HMAC class instanceVariableNames: ''! !HMAC class methodsFor: 'instance creation' stamp: 'len 8/15/2002 01:42'! on: aHashFunction ^ self new setHash: aHashFunction! ! Morph subclass: #HSVAColorSelectorMorph instanceVariableNames: 'hsvMorph aMorph' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !HSVAColorSelectorMorph commentStamp: 'gvc 5/18/2007 12:55' prior: 0! Colour selector featuring a saturation/volume area, hue selection strip and alpha selection strip.! !HSVAColorSelectorMorph methodsFor: 'accessing' stamp: 'gvc 9/20/2006 14:05'! aMorph "Answer the value of aMorph" ^ aMorph! ! !HSVAColorSelectorMorph methodsFor: 'accessing' stamp: 'gvc 9/20/2006 14:05'! aMorph: anObject "Set the value of aMorph" aMorph := anObject! ! !HSVAColorSelectorMorph methodsFor: 'accessing' stamp: 'gvc 9/20/2006 14:05'! hsvMorph "Answer the value of hsvMorph" ^ hsvMorph! ! !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/22/2006 09:58'! alphaSelected: aFloat "The alpha has changed." self triggerSelectedColor! ! !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 13:44'! defaultColor "Answer the default color/fill style for the receiver." ^Color transparent ! ! !HSVAColorSelectorMorph methodsFor: 'as yet unclassified' 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 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/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: 'as yet unclassified' stamp: 'gvc 9/21/2006 14:18'! selectedColor "Answer the selected color." ^self hsvMorph selectedColor alpha: self aMorph value! ! !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:57'! triggerSelectedColor "Trigger the event for the selected colour" self triggerEvent: #selectedColor with: self selectedColor! ! Morph subclass: #HSVColorSelectorMorph instanceVariableNames: 'svMorph hMorph' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !HSVColorSelectorMorph commentStamp: 'gvc 5/18/2007 12:55' prior: 0! 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: '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 "Answer the value of svMorph" ^ svMorph! ! !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! ! !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/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/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/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: '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 13:41'! selectedColor "Answer the selected color." ^self svMorph selectedColor! ! !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! ! TestCase subclass: #HTTPEncodingTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetworkTests-Protocols'! !HTTPEncodingTest methodsFor: 'as yet unclassified' stamp: 'PavelKrivanek 11/8/2012 12:13'! testEncodeForHTTP self assert: 'aa aa éé aa aa' encodeForHTTP = 'aa%20aa%20%C3%A9%C3%A9%20aa%20aa'! ! !HTTPEncodingTest methodsFor: 'as yet unclassified' stamp: 'PavelKrivanek 11/8/2012 12:13'! testPercentEncodingJa | leading hiraA hiraO hiraAO encodedHiraA encodedHiraO encodedHiraAO | "Make Japanese String from unicode. see http://www.unicode.org/charts/PDF/U3040.pdf" leading := JapaneseEnvironment leadingChar. hiraA := (Character leadingChar: leading code: 16r3042) asString. "HIRAGANA LETTER A" hiraO := (Character leadingChar: leading code: 16r304A) asString. "HIRAGANA LETTER O" hiraAO := hiraA, hiraO. "Percent Encoded Japanese String" encodedHiraA := hiraA encodeForHTTP. self assert: encodedHiraA = '%E3%81%82'. encodedHiraO := hiraO encodeForHTTP. self assert: encodedHiraO = '%E3%81%8A'. encodedHiraAO := hiraAO encodeForHTTP. self assert: encodedHiraAO = '%E3%81%82%E3%81%8A'. "without percent encoded string" self assert: '' unescapePercents = ''. self assert: 'abc' unescapePercents = 'abc'. "latin1 character" self assert: hiraAO unescapePercents = hiraAO. "multibyte character" "encoded latin1 string" self assert: '%61' unescapePercents = 'a'. self assert: '%61%62%63' unescapePercents = 'abc'. "encoded multibyte string" Locale currentPlatform: (Locale isoLanguage: 'ja') during: [ self assert: encodedHiraA unescapePercents = hiraA. self assert: encodedHiraAO unescapePercents = hiraAO]. "mixed string" Locale currentPlatform: (Locale isoLanguage: 'ja') during: [ self assert: (encodedHiraAO,'a') unescapePercents = (hiraAO, 'a'). self assert: ('a', encodedHiraA) unescapePercents = ('a', hiraA). self assert: ('a', encodedHiraA, 'b') unescapePercents = ('a', hiraA, 'b'). self assert: ('a', encodedHiraA, 'b', encodedHiraO) unescapePercents = ('a', hiraA, 'b', hiraO). self assert: (encodedHiraA, encodedHiraO, 'b', encodedHiraA) unescapePercents = (hiraA, hiraO, 'b', hiraA)]. "for Seaside" Locale currentPlatform: (Locale isoLanguage: 'ja') during: [ self assert: (encodedHiraA, '+', encodedHiraO) unescapePercents = (hiraA, ' ', hiraO)]. ! ! Notification subclass: #HTTPProgress instanceVariableNames: 'total amount' classVariableNames: '' poolDictionaries: '' category: 'Network-Protocols'! !HTTPProgress commentStamp: '' prior: 0! 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:37'! amount "Answer the amount that has already been transferred. Can be nil. Should be between 0 and total." ^ amount! ! !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: '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: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: 'SvenVanCaekenberghe 9/16/2012 18:53'! beComplete "Make me complete, i.e. indicate that all bytes were tranferred." amount := total! ! !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: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: 'accessing' stamp: 'SvenVanCaekenberghe 9/16/2012 18:38'! total "Answer the total byte count to transfer. Can be nil." ^ total! ! !HTTPProgress methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 9/16/2012 18:47'! total: byteCount "Set the total byte count to transfer" total := byteCount! ! !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: '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: '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 class instanceVariableNames: ''! !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! ! Socket subclass: #HTTPSocket instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Network-Protocols'! !HTTPSocket commentStamp: '' prior: 0! This class is deprecated in Pharo 2.0 since 2012-10-03T18:02:49Z. Use ZnClient to build, execute and process HTTP client requests.! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HTTPSocket class instanceVariableNames: ''! !HTTPSocket class methodsFor: '*Zinc-Patch-HTTPSocket' stamp: 'SvenVanCaekenberghe 10/3/2012 20:04'! httpGet: url "Forward to Zinc HTTP Components" self deprecated: 'Use ZnClient' on: ' 2012-10-03T18:02:49Z' in: 'Pharo 2.0'. ^ ZnHTTPSocketFacade httpGet: url! ! !HTTPSocket class methodsFor: '*Zinc-Patch-HTTPSocket' stamp: 'SvenVanCaekenberghe 10/3/2012 20:04'! httpGet: url accept: mimeType "Forward to Zinc HTTP Components" self deprecated: 'Use ZnClient' on: ' 2012-10-03T18:02:49Z' in: 'Pharo 2.0'. ^ ZnHTTPSocketFacade httpGet: url accept: mimeType ! ! !HTTPSocket class methodsFor: '*Zinc-Patch-HTTPSocket' stamp: 'SvenVanCaekenberghe 10/3/2012 20:05'! httpGet: url args: queryArguments accept: mimeType "Forward to Zinc HTTP Components" self deprecated: 'Use ZnClient' on: ' 2012-10-03T18:02:49Z' in: 'Pharo 2.0'. ^ ZnHTTPSocketFacade httpGet: url args: queryArguments accept: mimeType ! ! !HTTPSocket class methodsFor: '*Zinc-Patch-HTTPSocket' stamp: 'SvenVanCaekenberghe 10/3/2012 20:05'! httpGet: url args: queryArguments accept: mimeType request: extraHeaders "Forward to Zinc HTTP Components" self deprecated: 'Use ZnClient' on: ' 2012-10-03T18:02:49Z' in: 'Pharo 2.0'. ^ ZnHTTPSocketFacade httpGet: url args: queryArguments accept: mimeType request: extraHeaders ! ! !HTTPSocket class methodsFor: '*Zinc-Patch-HTTPSocket' stamp: 'SvenVanCaekenberghe 10/3/2012 20:05'! httpGet: url args: queryArguments user: username passwd: password "Forward to Zinc HTTP Components" self deprecated: 'Use ZnClient' on: ' 2012-10-03T18:02:49Z' in: 'Pharo 2.0'. ^ ZnHTTPSocketFacade httpGet: url args: queryArguments user: username passwd: password! ! !HTTPSocket class methodsFor: '*Zinc-Patch-HTTPSocket' stamp: 'SvenVanCaekenberghe 10/3/2012 20:05'! httpGetDocument: url "Forward to Zinc HTTP Components" self deprecated: 'Use ZnClient' on: ' 2012-10-03T18:02:49Z' in: 'Pharo 2.0'. ^ ZnHTTPSocketFacade httpGetDocument: url! ! !HTTPSocket class methodsFor: '*Zinc-Patch-HTTPSocket' stamp: 'SvenVanCaekenberghe 10/3/2012 20:05'! httpGetDocument: url accept: mimeType "Forward to Zinc HTTP Components" self deprecated: 'Use ZnClient' on: ' 2012-10-03T18:02:49Z' in: 'Pharo 2.0'. ^ ZnHTTPSocketFacade httpGetDocument: url accept: mimeType ! ! !HTTPSocket class methodsFor: '*Zinc-Patch-HTTPSocket' stamp: 'SvenVanCaekenberghe 10/3/2012 20:05'! httpGetDocument: url args: queryArguments "Forward to Zinc HTTP Components" self deprecated: 'Use ZnClient' on: ' 2012-10-03T18:02:49Z' in: 'Pharo 2.0'. ^ ZnHTTPSocketFacade httpGetDocument: url args: queryArguments! ! !HTTPSocket class methodsFor: '*Zinc-Patch-HTTPSocket' stamp: 'SvenVanCaekenberghe 10/3/2012 20:05'! httpGetDocument: url args: queryArguments accept: mimeType "Forward to Zinc HTTP Components" self deprecated: 'Use ZnClient' on: ' 2012-10-03T18:02:49Z' in: 'Pharo 2.0'. ^ ZnHTTPSocketFacade httpGetDocument: url args: queryArguments accept: mimeType! ! !HTTPSocket class methodsFor: '*Zinc-Patch-HTTPSocket' stamp: 'SvenVanCaekenberghe 10/3/2012 20:05'! httpGetDocument: url args: queryArguments accept: mimeType request: extraHeaders "Forward to Zinc HTTP Components" self deprecated: 'Use ZnClient' on: ' 2012-10-03T18:02:49Z' in: 'Pharo 2.0'. ^ ZnHTTPSocketFacade httpGetDocument: url args: queryArguments accept: mimeType request: extraHeaders! ! !HTTPSocket class methodsFor: '*Zinc-Patch-HTTPSocket' stamp: 'SvenVanCaekenberghe 10/3/2012 20:05'! httpGif: url "Forward to Zinc HTTP Components" self deprecated: 'Use ZnClient' on: ' 2012-10-03T18:02:49Z' in: 'Pharo 2.0'. ^ ZnHTTPSocketFacade httpGif: url! ! !HTTPSocket class methodsFor: '*Zinc-Patch-HTTPSocket' stamp: 'SvenVanCaekenberghe 10/3/2012 20:05'! httpJpeg: url "Forward to Zinc HTTP Components" self deprecated: 'Use ZnClient' on: ' 2012-10-03T18:02:49Z' in: 'Pharo 2.0'. ^ ZnHTTPSocketFacade httpJpeg: url! ! !HTTPSocket class methodsFor: '*Zinc-Patch-HTTPSocket' stamp: 'SvenVanCaekenberghe 10/3/2012 20:05'! httpPng: url "Forward to Zinc HTTP Components" self deprecated: 'Use ZnClient' on: ' 2012-10-03T18:02:49Z' in: 'Pharo 2.0'. ^ ZnHTTPSocketFacade httpPng: url! ! !HTTPSocket class methodsFor: '*Zinc-Patch-HTTPSocket' stamp: 'SvenVanCaekenberghe 10/3/2012 20:05'! httpPost: url args: arguments accept: mimeType "Forward to Zinc HTTP Components" self deprecated: 'Use ZnClient' on: ' 2012-10-03T18:02:49Z' in: 'Pharo 2.0'. ^ ZnHTTPSocketFacade httpPost: url args: arguments accept: mimeType! ! !HTTPSocket class methodsFor: '*Zinc-Patch-HTTPSocket' stamp: 'SvenVanCaekenberghe 10/3/2012 20:06'! httpPost: url args: arguments user: username passwd: password "Forward to Zinc HTTP Components" self deprecated: 'Use ZnClient' on: ' 2012-10-03T18:02:49Z' in: 'Pharo 2.0'. ^ ZnHTTPSocketFacade httpPost: url args: arguments user: username passwd: password! ! !HTTPSocket class methodsFor: '*Zinc-Patch-HTTPSocket' stamp: 'SvenVanCaekenberghe 10/3/2012 20:06'! httpPostDocument: url args: arguments "Forward to Zinc HTTP Components" self deprecated: 'Use ZnClient' on: ' 2012-10-03T18:02:49Z' in: 'Pharo 2.0'. ^ ZnHTTPSocketFacade httpPostDocument: url args: arguments! ! !HTTPSocket class methodsFor: '*Zinc-Patch-HTTPSocket' stamp: 'SvenVanCaekenberghe 10/3/2012 20:06'! httpPostDocument: url args: arguments accept: mimeType "Forward to Zinc HTTP Components" self deprecated: 'Use ZnClient' on: ' 2012-10-03T18:02:49Z' in: 'Pharo 2.0'. ^ ZnHTTPSocketFacade httpPostDocument: url args: arguments accept: mimeType! ! !HTTPSocket class methodsFor: '*Zinc-Patch-HTTPSocket' stamp: 'SvenVanCaekenberghe 10/3/2012 20:06'! httpPostDocument: url args: arguments accept: mimeType request: extraHeaders "Forward to Zinc HTTP Components" self deprecated: 'Use ZnClient' on: ' 2012-10-03T18:02:49Z' in: 'Pharo 2.0'. ^ ZnHTTPSocketFacade httpPostDocument: url args: arguments accept: mimeType request: extraHeaders! ! !HTTPSocket class methodsFor: '*Zinc-Patch-HTTPSocket' stamp: 'SvenVanCaekenberghe 10/3/2012 20:06'! httpPostMultipart: url args: arguments accept: mimeType request: extraHeaders "Forward to Zinc HTTP Components" self deprecated: 'Use ZnClient' on: ' 2012-10-03T18:02:49Z' in: 'Pharo 2.0'. ^ ZnHTTPSocketFacade httpPostMultipart: url args: arguments accept: mimeType request: extraHeaders! ! !HTTPSocket class methodsFor: '*Zinc-Patch-HTTPSocket' stamp: 'SvenVanCaekenberghe 10/3/2012 20:06'! httpPut: stream to: url user: username passwd: password "Forward to Zinc HTTP Components" self deprecated: 'Use ZnClient' on: ' 2012-10-03T18:02:49Z' in: 'Pharo 2.0'. ^ ZnHTTPSocketFacade httpPut: stream to: url user: username passwd: password! ! Morph subclass: #HaloMorph instanceVariableNames: 'target innerTarget positionOffset angleOffset growingOrRotating directionArrowAnchor haloBox originalExtent nameMorph' classVariableNames: 'CurrentHaloSpecifications HaloEnclosesFullBounds HaloWithDebugHandle ShowBoundsInHalo' poolDictionaries: '' category: 'Morphic-Widgets'! !HaloMorph commentStamp: '' prior: 0! 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: '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: 'accessing' stamp: 'sw 1/26/2000 15:36'! haloBox: aBox haloBox := aBox! ! !HaloMorph methodsFor: 'accessing' stamp: 'jm 5/22/1998 16:28'! innerTarget ^ innerTarget ! ! !HaloMorph methodsFor: 'accessing' stamp: 'ar 8/8/2001 14:28'! magicAlpha ^self valueOfProperty: #magicAlpha ifAbsent:[1.0]! ! !HaloMorph methodsFor: 'accessing' stamp: 'ar 8/8/2001 14:42'! magicAlpha: alpha self setProperty: #magicAlpha toValue: alpha. self changed.! ! !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: 'accessing' stamp: 'jm 7/16/97 06:51'! target ^ target ! ! !HaloMorph methodsFor: 'accessing' stamp: 'jm 5/7/1998 15:42'! target: aMorph self setTarget: aMorph. target ifNotNil: [self addHandles]. ! ! !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: '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: '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: '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: '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: '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: '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: '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: 'events' stamp: 'StephaneDucasse 12/29/2011 12:45'! 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 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: '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: '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: '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: '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: 'geometry' stamp: 'AlainPlantec 12/11/2009 23:03'! 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 outsetBy: 2 ]. ^r! ! !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: '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: '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: '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: '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: '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: '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: 'handles' stamp: 'gm 2/22/2003 13:13'! addFontEmphHandle: haloSpec (innerTarget isTextMorph) ifTrue: [self addHandle: haloSpec on: #mouseDown send: #chooseEmphasisOrAlignment to: innerTarget]! ! !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: 'handles' stamp: 'gm 2/22/2003 13:13'! addFontStyleHandle: haloSpec (innerTarget isTextMorph) ifTrue: [self addHandle: haloSpec on: #mouseDown send: #chooseStyle to: innerTarget]! ! !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: '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: '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: 'sw 1/26/2000 16:05'! addMenuHandle: haloSpec self addHandle: haloSpec on: #mouseDown send: #doMenu:with: to: self! ! !HaloMorph methodsFor: 'handles' stamp: 'SeanDeNigris 1/24/2013 00:55'! addRecolorHandle: haloSpec "Add a recolor handle to the receiver, if appropriate" | recolorHandle | "since this halo now opens a more general properties panel, allow it in all cases" "innerTarget canSetColor ifTrue:" recolorHandle := self addHandle: haloSpec on: #mouseUp send: #doRecolor: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: '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: '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: 'initialization' stamp: 'gvc 3/17/2009 10:42'! defaultColor "Answer the default color/fill style for the receiver." ^Color transparent! ! !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: 'menu' stamp: 'dgd 9/20/2004 19:35'! wantsYellowButtonMenu "Answer true if the receiver wants a yellow button menu" ^ false! ! !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: 'meta-actions' stamp: 'ar 9/15/2000 16:42'! handlerForBlueButtonDown: anEvent "Blue button was clicked within the receiver" ^self! ! !HaloMorph methodsFor: 'settings' stamp: 'MarcusDenker 10/26/2011 14:57'! gradientHalo ^ true! ! !HaloMorph methodsFor: 'settings' stamp: 'AlainPlantec 12/11/2009 23:01'! haloEnclosesFullBounds ^ self class haloEnclosesFullBounds! ! !HaloMorph methodsFor: 'settings' stamp: 'AlainPlantec 12/11/2009 23:02'! showBoundsInHalo ^ self class showBoundsInHalo! ! !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: '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: '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: 'testing' stamp: 'jm 7/16/97 06:54'! stepTime ^ 0 "every cycle" ! ! !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: '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: '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: '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: 'AlainPlantec 1/7/2010 22:09'! addFullHandles self addCircleHandles! ! !HaloMorph methodsFor: 'private' stamp: 'FernandoOlivero 4/12/2011 09:46'! addGraphicalHandleFrom: formKey at: aPoint "Add the supplied form as a graphical handle centered at the given point. Return the handle." | handle aForm | aForm :=self theme iconNamed: formKey ifNone: [ self theme iconNamed: #solidMenuIcon]. handle := ImageMorph new image: 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: '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: '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: '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: 'AlainPlantec 5/7/2010 22:52'! addHandles self addCircleHandles. ! ! !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: '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: '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: 'MarcusDenker 9/7/2010 16:56'! 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 useStringFormat; target: innerTarget; putSelector: #renameTo:. 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: '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: '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: '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 10/26/2011 14:59'! 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 := self theme iconNamed: iconName ifNone: []. form isNil ifFalse: [| image | image := ImageMorph new. image image: form. image color: aColor makeForegroundColor. image lock. handle addMorphCentered: image]]. "" ^ handle! ! !HaloMorph methodsFor: 'private' stamp: 'di 9/26/2000 15:16'! directionArrowLength ^ 25! ! !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: 'ar 10/24/2000 18:41'! doDirection: anEvent with: directionHandle anEvent hand obtainHalo: self. self removeAllHandlesBut: directionHandle! ! !HaloMorph methodsFor: 'private' stamp: 'tk 7/14/2001 11:04'! doDrag: evt with: dragHandle | thePoint | evt hand obtainHalo: self. thePoint := target point: evt position - positionOffset from: owner. target setConstrainedPosition:(target griddedPoint: thePoint) hangOut: true. ! ! !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: '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: 'private' stamp: 'AlainPlantec 5/5/2010 18:04'! doGrow: evt with: growHandle "Called while the mouse is down in the grow handle" | newExtent extentToUse scale | evt hand obtainHalo: self. newExtent := (target pointFromWorld: (target griddedPoint: 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: '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: '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: 'private' stamp: 'AlainPlantec 5/8/2010 00:00'! 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 makeForegroundColor]. 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 21:37'! 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 makeForegroundColor]. scaleHandle position: newHandlePos. ! ! !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: 'sw 1/27/2000 18:42'! handleAllowanceForIconicHalos ^ 12! ! !HaloMorph methodsFor: 'private' stamp: 'AlainPlantec 12/11/2009 22:50'! handleSize ^ 20! ! !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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: 'private' stamp: 'dgd 2/22/2003 19:04'! showingDirectionHandles ^directionArrowAnchor notNil! ! !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: '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: '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: '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: '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: 'private' stamp: 'ar 10/24/2000 18:43'! trackDirectionArrow: anEvent with: shaft anEvent hand obtainHalo: self. shaft setVertices: {directionArrowAnchor. anEvent cursorPoint}. self layoutChanged! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HaloMorph class instanceVariableNames: ''! !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: '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:55'! currentHaloSpecifications ^ CurrentHaloSpecifications ifNil: [self installHaloTheme: #iconicHaloSpecifications] ! ! !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) " ! ! !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: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: '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: 'halo theme' stamp: 'StephaneDucasse 2/20/2010 21:57'! initialize "self initialize" super initialize. self installHaloTheme: #iconicHaloSpecifications ! ! !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'! 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:58'! haloEnclosesFullBounds ^ HaloEnclosesFullBounds ifNil: [HaloEnclosesFullBounds := false]! ! !HaloMorph class methodsFor: 'settings' stamp: 'AlainPlantec 12/11/2009 22:58'! haloEnclosesFullBounds: aBoolean HaloEnclosesFullBounds := aBoolean! ! !HaloMorph class methodsFor: 'settings' stamp: 'AlainPlantec 12/6/2009 21:07'! haloWithDebugHandle ^ HaloWithDebugHandle ifNil: [HaloWithDebugHandle := true]! ! !HaloMorph class methodsFor: 'settings' stamp: 'AlainPlantec 12/6/2009 21:13'! haloWithDebugHandle: aBoolean HaloWithDebugHandle := aBoolean! ! !HaloMorph class methodsFor: 'settings' stamp: 'AlainPlantec 12/11/2009 22:58'! showBoundsInHalo ^ ShowBoundsInHalo ifNil: [ShowBoundsInHalo := false]! ! !HaloMorph class methodsFor: 'settings' stamp: 'AlainPlantec 12/11/2009 22:59'! showBoundsInHalo: aBoolean ShowBoundsInHalo := aBoolean! ! Object subclass: #HaloSpec instanceVariableNames: 'addHandleSelector horizontalPlacement verticalPlacement color iconSymbol' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Widgets'! !HaloSpec commentStamp: 'kfr 10/27/2003 16:23' prior: 0! Sets spec's for how handles are layed out in a halo.! !HaloSpec methodsFor: 'accessing' stamp: 'sw 1/25/2000 18:41'! color ^ color! ! !HaloSpec methodsFor: 'accessing' stamp: 'sw 1/25/2000 18:41'! horizontalPlacement ^ horizontalPlacement! ! !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: 'actions' stamp: 'sw 1/25/2000 19:54'! addHandleSelector ^ addHandleSelector! ! !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! ! Exception subclass: #Halt instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Exceptions'! !Halt commentStamp: '' prior: 0! Halt is provided to support Object>>halt.! !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 instanceVariableNames: 'isHaltOnceEnabled callsUntilHaltOnCount'! !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:41'! halt: aString "backward compatible method with self halt:" self signal: aString! ! !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 12:16'! ifShiftPressed self if: [Sensor shiftPressed]! ! !Halt class methodsFor: 'halting' stamp: 'SeanDeNigris 8/29/2011 10:43'! now 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: '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 ].! ! !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: 'once-enabling/disabling' stamp: 'SeanDeNigris 8/29/2011 16:04'! disableHaltOnce isHaltOnceEnabled := false.! ! !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: '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: '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:43'! haltIfCallChainContains: aSelector | cntxt | cntxt := thisContext. [cntxt sender isNil] whileFalse: [ cntxt := cntxt sender. (cntxt selector = aSelector) ifTrue: [self signal]].! ! !Halt class methodsFor: 'private' stamp: 'SeanDeNigris 8/29/2011 17:18'! isCounting ^ callsUntilHaltOnCount > 0.! ! !Halt class methodsFor: 'private' stamp: 'SeanDeNigris 8/29/2011 17:19'! stopCounting callsUntilHaltOnCount := 0.! ! TestCase subclass: #HandBugs instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Bugs'! !HandBugs methodsFor: 'as yet unclassified' stamp: 'wiz 4/18/2007 00:57'! testTargetPoint "self new testTargetPoint" "self run: #testTargetPoint" self shouldnt: [ ActiveHand targetPoint ] raise: Error . ! ! Morph subclass: #HandMorph instanceVariableNames: 'mouseFocus keyboardFocus eventListeners mouseListeners keyboardListeners mouseClickState mouseOverHandler lastMouseEvent targetOffset damageRecorder cacheCanvas cachedCanvasHasHoles temporaryCursor temporaryCursorOffset hardwareCursor hasChanged savedPatch lastEventBuffer lastKeyScanCode combinedChar eventSource lastSystemEvent captureBlock recentModifiers' classVariableNames: 'DoubleClickTime EventSource EventStats NormalCursor PasteBuffer ShowEvents' poolDictionaries: 'EventSensorConstants' category: 'Morphic-Kernel'! !HandMorph commentStamp: '' prior: 0! 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: '*EventModel' stamp: 'StephaneDucasse 12/26/2011 09:57'! eventSource ^ eventSource ifNil: [ Sensor ]! ! !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: '*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: '*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: '*SUnit-UITesting' stamp: 'SeanDeNigris 11/22/2011 18:57'! simulateKeyStroke: aCharacterOrShortcut | shortcut | shortcut := aCharacterOrShortcut asShortcut. 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: '*SUnit-UITesting' stamp: 'SeanDeNigris 11/22/2011 18:56'! simulateKeyStrokes: aString aString do: [ :c | self simulateKeyStroke: c ].! ! !HandMorph methodsFor: 'accessing' stamp: 'tk 10/20/2004 15:54'! anyButtonPressed ^lastMouseEvent anyButtonPressed! ! !HandMorph methodsFor: 'accessing' stamp: 'IgorStasenko 1/22/2012 18:24'! anyModifierKeyPressed ^recentModifiers anyMask: 16r0E "cmd | opt | ctrl"! ! !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: 'accessing' stamp: 'di 3/14/1999 10:03'! cursorBounds temporaryCursor == nil ifTrue: [^ self position extent: NormalCursor extent] ifFalse: [^ self position + temporaryCursorOffset extent: temporaryCursor extent]! ! !HandMorph methodsFor: 'accessing' stamp: 'ar 10/5/2000 23:17'! lastEvent ^ lastMouseEvent! ! !HandMorph methodsFor: 'accessing' stamp: 'ar 9/25/2000 14:24'! mouseOverHandler ^mouseOverHandler ifNil:[mouseOverHandler := MouseOverHandler new].! ! !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: 'accessing' stamp: 'ar 12/22/2008 12:04'! shiftPressed ^lastMouseEvent shiftPressed! ! !HandMorph methodsFor: 'accessing'! 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: '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: 'accessing' stamp: 'ar 10/26/2000 15:18'! userPicture ^self valueOfProperty: #remoteUserPicture ! ! !HandMorph methodsFor: 'accessing' stamp: 'ar 10/26/2000 15:34'! userPicture: aFormOrNil ^self setProperty: #remoteUserPicture toValue: aFormOrNil ! ! !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: 'balloon help' stamp: 'ar 10/3/2000 16:51'! balloonHelp: aBalloonMorph "Return the balloon morph associated with this hand" | oldHelp | oldHelp := self balloonHelp. oldHelp ifNotNil:[oldHelp delete]. aBalloonMorph ifNil:[self removeProperty: #balloonHelpMorph] ifNotNil:[self setProperty: #balloonHelpMorph toValue: aBalloonMorph]! ! !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: '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: 'balloon help' stamp: 'ar 10/3/2000 17:15'! spawnBalloonFor: aMorph aMorph showBalloon: aMorph balloonText hand: self.! ! !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: '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: '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: 'classification'! isHandMorph ^ true! ! !HandMorph methodsFor: 'copying' stamp: 'ar 10/6/2000 00:11'! veryDeepCopyWith: deepCopier "Return self. Do not copy hands this way." ^ self! ! !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: 'cursor' stamp: 'StephaneDucasse 12/26/2011 10:39'! 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 isNil ifTrue: [temporaryCursor := temporaryCursorOffset := hardwareCursor := nil] ifFalse: [temporaryCursor := cursorOrNil asCursorForm. temporaryCursorOffset := temporaryCursor offset - hotSpotOffset. (cursorOrNil isKindOf: Cursor) ifTrue: [hardwareCursor := cursorOrNil]]. bounds := self cursorBounds. self layoutChanged; changed! ! !HandMorph methodsFor: 'cursor' stamp: 'NS 2/17/2001 11:01'! temporaryCursor ^ temporaryCursor! ! !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: '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: '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: 'drawing' stamp: 'StephaneDucasse 12/26/2011 10:18'! drawOn: aCanvas "Draw the hand itself (i.e., the cursor)." temporaryCursor isNil ifTrue: [aCanvas paintImage: NormalCursor at: bounds topLeft] ifFalse: [aCanvas paintImage: temporaryCursor at: bounds topLeft]. ! ! !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: '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: '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: '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: '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: '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: '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: 'drawing' stamp: 'nk 10/24/2003 22:12'! visible: aBoolean self needsToBeDrawn ifFalse: [ ^self ]. super visible: aBoolean! ! !HandMorph methodsFor: 'drop shadows'! shadowOffset ^ 6@8! ! !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: 'event handling' stamp: 'ar 9/25/2000 14:27'! noticeMouseOver: aMorph event: anEvent mouseOverHandler ifNil:[^self]. mouseOverHandler noticeMouseOver: aMorph event: anEvent.! ! !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: '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: 'events-processing' stamp: 'IgorStasenko 1/2/2012 18:46'! handleEvent: anEvent | evt ofs | 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:[ self position: evt position. 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: '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: 'events-processing' stamp: 'StephaneDucasse 12/26/2011 10:49'! showDebugEvent: evt ShowEvents == true ifTrue: [ | ofs| Display fill: (0@0 extent: 250@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: '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: 'events-processing' stamp: 'IgorStasenko 1/2/2012 18:41'! waitButton self captureEventsUntil: [:evt | self anyButtonPressed ] ! ! !HandMorph methodsFor: 'focus handling' stamp: 'ar 10/6/2000 00:09'! keyboardFocus ^ keyboardFocus! ! !HandMorph methodsFor: 'focus handling' stamp: 'ar 10/26/2000 01:30'! keyboardFocus: aMorphOrNil keyboardFocus := aMorphOrNil! ! !HandMorph methodsFor: 'focus handling' stamp: 'ar 10/6/2000 00:10'! mouseFocus ^mouseFocus! ! !HandMorph methodsFor: 'focus handling' stamp: 'nk 2/14/2004 18:44'! mouseFocus: aMorphOrNil mouseFocus := aMorphOrNil! ! !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: '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: 'focus handling' stamp: 'dgd 2/21/2003 22:48'! newMouseFocus: aMorph event: event aMorph isNil ifFalse: [targetOffset := event cursorPoint - aMorph position]. ^self newMouseFocus: aMorph! ! !HandMorph methodsFor: 'focus handling' stamp: 'ar 10/6/2000 00:09'! releaseAllFoci mouseFocus := nil. keyboardFocus := nil. ! ! !HandMorph methodsFor: 'focus handling' stamp: 'ar 10/6/2000 00:09'! releaseKeyboardFocus "Release the current keyboard focus unconditionally" self newKeyboardFocus: nil. ! ! !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: 'focus handling' stamp: 'ar 10/6/2000 00:10'! releaseMouseFocus "Release the current mouse focus unconditionally." self newMouseFocus: 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: 'geometry' stamp: 'ar 3/20/2001 20:34'! position ^temporaryCursor ifNil: [bounds topLeft] ifNotNil: [bounds topLeft - temporaryCursorOffset]! ! !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: '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: 'grabbing/dropping' stamp: 'ar 10/5/2000 16:23'! dropMorphs "Drop the morphs at the hands position" self dropMorphs: lastMouseEvent.! ! !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: '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: '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: '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: 'halo handling' stamp: 'ar 10/24/2000 18:40'! obtainHalo: aHalo "Used for transfering halos between hands" | formerOwner | self halo == aHalo ifTrue:[^self]. "Find former owner" formerOwner := self world hands detect:[:h| h halo == aHalo] ifNone:[nil]. formerOwner ifNotNil:[formerOwner releaseHalo: aHalo]. self halo: aHalo! ! !HandMorph methodsFor: 'halo handling' stamp: 'ar 10/24/2000 18:40'! releaseHalo: aHalo "Used for transfering halos between hands" self removeProperty: #halo! ! !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: '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: '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: '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: '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: '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: '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: '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: '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: '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: 'listeners' stamp: 'ar 10/26/2000 01:27'! eventListeners ^eventListeners! ! !HandMorph methodsFor: 'listeners' stamp: 'ar 10/26/2000 01:27'! eventListeners: anArrayOrNil eventListeners := anArrayOrNil! ! !HandMorph methodsFor: 'listeners' stamp: 'ar 10/26/2000 01:28'! keyboardListeners ^keyboardListeners! ! !HandMorph methodsFor: 'listeners' stamp: 'ar 10/26/2000 01:28'! mouseListeners ^mouseListeners! ! !HandMorph methodsFor: 'listeners' stamp: 'ar 10/26/2000 01:27'! mouseListeners: anArrayOrNil mouseListeners := anArrayOrNil! ! !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: '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:41'! removeMouseListener: anObject "Remove anObject from the current mouse listeners." self mouseListeners: (self removeListener: anObject from: self mouseListeners).! ! !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: '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: '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 methodsFor: 'paste buffer' stamp: 'ar 10/5/2000 19:10'! pasteBuffer "Return the paste buffer associated with this hand" ^ PasteBuffer! ! !HandMorph methodsFor: 'paste buffer' stamp: 'ar 10/5/2000 19:11'! pasteBuffer: aMorphOrNil "Set the contents of the paste buffer." PasteBuffer := aMorphOrNil. ! ! !HandMorph methodsFor: 'selected object' stamp: 'dgd 8/28/2004 16:30'! selectedObject "answer the selected object for the hand or nil is none" | halo | halo := self halo. halo isNil ifTrue: [^ nil]. ^ halo target renderedMorph! ! !HandMorph methodsFor: 'updating' stamp: 'jm 2/20/98 19:54'! changed hasChanged := true. ! ! !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: 'private events' stamp: 'HenrikSperreJohansen 5/9/2011 12:46'! 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. "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]. 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]]. (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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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 class instanceVariableNames: ''! !HandMorph class methodsFor: 'accessing'! doubleClickTime ^ DoubleClickTime ! ! !HandMorph class methodsFor: 'accessing'! doubleClickTime: milliseconds DoubleClickTime := milliseconds. ! ! !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: 'initialization' stamp: 'michael.rueger 1/27/2009 17:41'! startUp self clearCompositionWindowManager! ! !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: 'utilities' stamp: 'nk 7/20/2003 10:03'! showEvents: aBool "HandMorph showEvents: true" "HandMorph showEvents: false" ShowEvents := aBool. aBool ifFalse: [ ActiveWorld invalidRect: (0@0 extent: 250@120) ].! ! EllipseMorph subclass: #HandleMorph instanceVariableNames: 'pointBlock lastPointBlock' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Widgets'! !HandleMorph commentStamp: '' prior: 0! A HandleMorph provides mouse-up control behavior.! !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: '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: '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 11/3/97 16:34'! forEachPointDo: aBlock pointBlock := aBlock! ! !HandleMorph methodsFor: 'initialize' stamp: 'di 8/30/2000 21:48'! forEachPointDo: aBlock lastPointDo: otherBlock pointBlock := aBlock. lastPointBlock := otherBlock! ! !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:"! ! !HandleMorph methodsFor: 'stepping and presenter' stamp: 'di 11/3/97 16:34'! step pointBlock value: self center! ! !HandleMorph methodsFor: 'testing' stamp: 'JMM 10/21/2003 18:15'! stepTime "Update every hundredth of a second." ^ 10 ! ! TestCase subclass: #HashAndEqualsTestCase instanceVariableNames: 'prototypes' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Core-Utilities'! !HashAndEqualsTestCase commentStamp: 'mjr 8/20/2003 17:37' prior: 0! 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: 'running' stamp: 'stephaneducasse 2/3/2006 22:39'! setUp "subclasses will add their prototypes into this collection" prototypes := OrderedCollection new ! ! !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]] ! ! Object subclass: #HashFunction instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Hashing-Core'! !HashFunction methodsFor: 'accessing' stamp: 'len 8/15/2002 01:43'! blockSize ^ self class blockSize! ! !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: '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/9/2002 13:17'! hashSize ^ self class hashSize! ! !HashFunction methodsFor: 'accessing' stamp: 'len 8/2/2002 02:21'! hashStream: aStream ^ self subclassResponsibility! ! !HashFunction methodsFor: 'converting' stamp: 'len 8/3/2002 02:42'! hmac ^ HMAC on: self! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HashFunction class instanceVariableNames: ''! !HashFunction class methodsFor: 'accessing' stamp: 'len 8/15/2002 01:43'! blockSize ^ self subclassResponsibility! ! !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'! hashMessage: aStringOrByteArray ^ self new hashMessage: aStringOrByteArray! ! !HashFunction class methodsFor: 'hashing' stamp: 'len 8/2/2002 02:20'! hashStream: aPositionableStream ^ self new hashStream: aPositionableStream! ! Object subclass: #HashTableSizes instanceVariableNames: 'candidate goodPrimes primesToAvoid valuesNotToDivide limit' classVariableNames: '' poolDictionaries: '' category: 'Collections-Unordered'! !HashTableSizes commentStamp: 'MartinMcClure 3/18/2010 21:44' prior: 0! 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: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: '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/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: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 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 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 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 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 class instanceVariableNames: 'sizes'! !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: '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! ! !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: 'private' stamp: 'MartinMcClure 1/17/2010 09:35'! sizes sizes ~~ nil ifFalse: [ sizes := self new computeSizes ]. ^ sizes! ! PrototypeTester subclass: #HashTester instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Core-Utilities'! !HashTester commentStamp: 'mjr 8/20/2003 12:48' prior: 0! 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 ! ! TestCase subclass: #HashTesterTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Core-Utilities'! !HashTesterTest commentStamp: 'mjr 8/20/2003 12:48' prior: 0! 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] ! ! Collection subclass: #HashedCollection instanceVariableNames: 'tally array' classVariableNames: '' poolDictionaries: '' category: 'Collections-Abstract'! !HashedCollection commentStamp: 'StephaneDucasse 11/29/2011 22:22' prior: 0! 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: '*Monticello-Storing' stamp: 'StephaneDucasse 10/18/2010 14:54'! comeFullyUpOnReload: smartRefStream "Symbols have new hashes in this image." self compact. "^ self" ! ! !HashedCollection methodsFor: 'accessing' stamp: 'TristanBourgois 4/30/2010 16:13'! capacity "Answer the current capacity of the receiver." ^ array size! ! !HashedCollection methodsFor: 'accessing' stamp: 'TristanBourgois 4/30/2010 16:13'! size ^ tally! ! !HashedCollection methodsFor: 'accessing' stamp: 'TristanBourgois 4/30/2010 16:13'! someElement "Deprecated. Use anyOne." ^ self anyOne! ! !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: 'copying' stamp: 'TristanBourgois 4/30/2010 16:13'! copyEmpty "Answer an empty copy of this collection" "Note: this code could be moved to super" ^self species new! ! !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: 'explorer' stamp: 'TristanBourgois 4/30/2010 16:13'! hasContentsInExplorer ^self notEmpty! ! !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'! array ^ array! ! !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: 'private' stamp: 'HenrikSperreJohansen 9/1/2010 21:58'! errorNoFreeSpace self error: 'There is no free space in this collection!!'! ! !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: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: '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: '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: '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: 'TristanBourgois 4/30/2010 16:13'! initialize: n "Initialize array to an array size of n" array := Array new: n. tally := 0! ! !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: 'HenrikSperreJohansen 9/1/2010 23:21'! rehash self growTo: self capacity! ! !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 class instanceVariableNames: ''! !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: 'initialization' stamp: 'HenrikSperreJohansen 9/1/2010 23:39'! compactAll "HashedCollection rehashAll" self allSubclassesDo: #compactAllInstances! ! !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: '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 ]! ! !HashedCollection class methodsFor: 'instance creation' stamp: 'HenrikSperreJohansen 9/1/2010 22:25'! new ^ self basicNew initialize: 5! ! !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: '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: '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! ! Object subclass: #HazelKernelAnalyzer instanceVariableNames: 'list dependencies originalList' classVariableNames: '' poolDictionaries: '' category: 'ScriptLoader20'! !HazelKernelAnalyzer commentStamp: '' prior: 0! Usage: (HazelKernelAnalyzer forPackageNamed: 'Kernel') analyze dependentPackages ! !HazelKernelAnalyzer methodsFor: 'accessing' stamp: 'GuillermoPolito 5/14/2012 11:38'! dependentClasses ^dependencies! ! !HazelKernelAnalyzer methodsFor: 'accessing' stamp: 'GuillermoPolito 5/14/2012 11:40'! dependentPackages ^(dependencies collect: [ :c | PackageOrganizer default packageOfClass: c ]) asSet! ! !HazelKernelAnalyzer methodsFor: 'accessing' stamp: 'GuillermoPolito 5/14/2012 11:35'! initialize list := OrderedCollection new. dependencies := Set new.! ! !HazelKernelAnalyzer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/19/2010 11:17'! list ^list! ! !HazelKernelAnalyzer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/19/2010 11:17'! list: aCollection list := aCollection! ! !HazelKernelAnalyzer methodsFor: 'analyzing' stamp: 'BenjaminVanRyseghem 11/19/2010 11:27'! analyze | dependents | self list do: [:class | self analyzeClassVar: class. self analyzeMethods: class]! ! !HazelKernelAnalyzer methodsFor: 'private' stamp: 'GuillermoPolito 5/14/2012 11:35'! analyzeClassVar: aClass "analyze dependencies of class vars" | collection | collection := aClass classSide classPool. collection associations do: [:association || key value toAnalyze | key := association key. value := association value. (value isKindOf: Class) ifTrue: [toAnalyze := value] ifFalse:[toAnalyze := value class]. (self list includes: toAnalyze) ifFalse:[dependencies add: toAnalyze] ]! ! !HazelKernelAnalyzer methodsFor: 'private' stamp: 'GuillermoPolito 5/14/2012 11:44'! analyzeMethod: aMethod | associations | "we don't care so far about extension methods" (aMethod category beginsWith: '*') ifTrue: [ ^self ]. associations := aMethod literals select: [:each | each isVariableBinding ]. associations do: [:association || value toAnalyze | value := association value. (value isKindOf: Class) ifTrue: [toAnalyze := value] ifFalse:[toAnalyze := value class]. (self list includes: toAnalyze) ifFalse: [dependencies add: toAnalyze]. ]! ! !HazelKernelAnalyzer methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/23/2010 15:43'! analyzeMethods: aClass aClass methodDict do:[:method | self analyzeMethod: method]. aClass classSide methodDict do:[:method | self analyzeMethod: method]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HazelKernelAnalyzer class instanceVariableNames: ''! !HazelKernelAnalyzer class methodsFor: 'instance creation' stamp: 'GuillermoPolito 5/14/2012 11:36'! forPackageNamed: aPackageName ^self new list: (PackageInfo named: aPackageName) classes! ! !HazelKernelAnalyzer class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 11/23/2010 15:20'! using: aCollection ^self new list: aCollection! ! Collection subclass: #Heap uses: TSortable instanceVariableNames: 'array tally sortBlock indexUpdateBlock' classVariableNames: '' poolDictionaries: '' category: 'Collections-Sequenceable'! !Heap commentStamp: 'StephaneDucasse 10/2/2010 17:42' prior: 0! 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: 'accessing' stamp: 'nice 3/26/2011 17:38'! at: index "Heap are not designed to be accessed sequentially." self shouldNotImplement.! ! !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: 'accessing' stamp: 'CamilloBruni 10/20/2012 18:23'! defaultSortBlock ^ self class defaultSortBlock! ! !Heap methodsFor: 'accessing' stamp: 'md 1/19/2006 09:56'! first "Return the first element in the receiver" ^array at: 1! ! !Heap methodsFor: 'accessing' stamp: 'stephane.ducasse 4/13/2009 21:05'! indexUpdateBlock: aBlockOrNil indexUpdateBlock := aBlockOrNil. ! ! !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: 'accessing' stamp: 'sma 5/12/2000 11:37'! size "Answer how many elements the receiver contains." ^ tally! ! !Heap methodsFor: 'accessing' stamp: 'CamilloBruni 10/20/2012 18:23'! sortBlock ^ sortBlock ifNil: [ sortBlock := self defaultSortBlock ]! ! !Heap methodsFor: 'accessing' stamp: 'stephane.ducasse 4/13/2009 21:05'! sortBlock: aBlock sortBlock := aBlock. self reSort.! ! !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: '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: '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: 'copying' stamp: 'nice 10/5/2009 08:47'! postCopy super postCopy. array := array copy! ! !Heap methodsFor: 'enumerating' stamp: 'nice 8/21/2010 15:40'! collect: aBlock ^self collect: aBlock as: Array! ! !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: 'enumerating' stamp: 'nice 8/21/2010 15:49'! select: aBlock "Evaluate aBlock with each of my elements as the argument. Collect into a new collection like the receiver, only those elements for which aBlock evaluates to true." | newCollection | newCollection := self copyEmpty. self do: [:each | (aBlock value: each) ifTrue: [newCollection add: each]]. ^ newCollection! ! !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: '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: '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: 'removing' stamp: 'klub 9/14/2009 19:10'! removeAll array atAllPut: nil. 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: '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: 'sorting'! 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: 'sorting'! 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: 'sorting'! 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'! 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'! 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: 'sorting'! sort "Sort this collection into ascending order using the '<=' operator." self sort: [:a :b | a <= b]! ! !Heap methodsFor: 'sorting'! 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: 'testing' stamp: 'ar 9/10/1999 13:03'! isEmpty "Answer whether the receiver contains any elements." ^tally = 0! ! !Heap methodsFor: 'testing' stamp: 'rhi 8/14/2003 08:51'! isHeap ^ true! ! !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: 'private' stamp: 'ar 7/1/1999 04:19'! array ^array! ! !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: '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: 'private' stamp: 'ar 7/1/1999 04:35'! setCollection: aCollection array := aCollection. tally := 0.! ! !Heap methodsFor: 'private' stamp: 'ar 9/10/1999 13:18'! setCollection: aCollection tally: newTally array := aCollection. tally := newTally.! ! !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: '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: '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: '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 class uses: TSortable classTrait instanceVariableNames: 'sortBlock'! !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 7/1/1999 04:20'! new ^self new: 10! ! !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: 'ar 9/10/1999 14:13'! sortBlock: aBlock "Create a new heap sorted by the given block" ^self new sortBlock: aBlock! ! !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! ! !Heap class methodsFor: 'instance creation' stamp: 'ar 5/23/2001 17:22'! withAll: aCollection sortBlock: sortBlock "Create a new heap with all the elements from aCollection" ^(self basicNew) setCollection: aCollection asArray copy tally: aCollection size; sortBlock: sortBlock; yourself! ! CollectionRootTest subclass: #HeapTest uses: TAddTest + TGrowableTest + TConvertTest + TConvertAsSortedTest + TConvertAsSetForMultiplinessIdentityTest + TCopyTest + TSetArithmetic + TRemoveForMultiplenessTest + TOccurrencesForMultiplinessTest + TCreationWithTest - {#testOfSize} + TIncludesWithIdentityCheckTest instanceVariableNames: 'collectionWithElement otherCollection nonEmpty empty elementNotIn collectResult expectedElementByDetect speciesClass elementTwiceIn doWithoutNumber element expectedSizeAfterReject collectionNotIncluded nonEmpty5ElementsWithoutDuplicate sameAtEndAndBegining nonEmpty1Element floatCollection indexArray subCollection duplicateElement collectionWithDuplicateElement collectionWith4Elements' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Sequenceable'! !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: '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: '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: '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: 'basic tests' stamp: 'stephane.ducasse 5/20/2009 18:11'! testRemove "self run: #testRemove" | heap | heap := Heap new. self should: [heap removeFirst] raise: Error. heap add: 5. self shouldnt: [heap removeFirst] raise: Error. self assert: heap size = 0. heap add: 5. self should: [heap removeAt: 2] raise: Error.! ! !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: '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: '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: 'parameters' stamp: 'cyrille.delaunay 3/20/2009 13:22'! valuePutIn "the value that we will put in the non empty collection" ^ 7! ! !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: 'delaunay 5/4/2009 10:12'! accessCollection ^ nonEmpty5ElementsWithoutDuplicate! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 15:44'! anotherElementNotIn " return an element different of 'elementNotIn' not included in 'nonEmpty' " ^ 9999! ! !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: '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: 'cyrille.delaunay 12/18/2009 13:07'! collection ^ collectionWith4Elements.! ! !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 09:55'! collectionMoreThan1NoDuplicates " return a collection of size > 1 without equal elements" ^ nonEmpty5ElementsWithoutDuplicate ! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 14:00'! collectionMoreThan5Elements " return a collection including at least 5 elements" ^nonEmpty5ElementsWithoutDuplicate ! ! !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 5/11/2009 10:34'! collectionOfSize5 " return a collection of size 5" ^ nonEmpty5ElementsWithoutDuplicate ! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:01'! collectionWith5Elements " return a collection of size 5 including 5 elements" ^ nonEmpty5ElementsWithoutDuplicate ! ! !HeapTest methodsFor: 'requirements'! 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/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: 'requirements' stamp: 'cyrille.delaunay 3/18/2009 15:07'! collectionWithElement ^ collectionWithElement! ! !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: 'delaunay 5/13/2009 16:06'! collectionWithEqualElements " return a collecition including atLeast two elements equal" ^ collectionWithDuplicateElement ! ! !HeapTest methodsFor: 'requirements'! 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/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: '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: 'requirements' stamp: 'delaunay 5/11/2009 10:13'! collectionWithSortableElements " return a collection elements that can be sorte ( understanding message ' < ' or ' > ')" ^ nonEmpty5ElementsWithoutDuplicate ! ! !HeapTest methodsFor: 'requirements' stamp: 'CamilloBruni 9/9/2011 12:11'! collectionWithoutEqualElements " return a collection not including equal elements " ^ nonEmpty5ElementsWithoutDuplicate ! ! !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: 'requirements' stamp: 'cyrille.delaunay 3/20/2009 13:37'! element ^ element! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/4/2009 10:10'! elementInForElementAccessing " return an element inculded in 'moreThan4Elements'" ^ self moreThan4Elements anyOne.! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 09:57'! elementInForIndexAccessing " return an element included in 'collectionMoreThan1NoDuplicates' " ^ self collectionMoreThan1NoDuplicates anyOne.! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:18'! elementInForOccurrences ^self nonEmpty anyOne! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/4/2009 10:15'! elementNotIn ^ elementNotIn ! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/4/2009 10:11'! elementNotInForElementAccessing " return an element not included in 'moreThan4Elements' " ^ elementNotIn ! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 09:56'! elementNotInForIndexAccessing " return an element not included in 'collectionMoreThan1NoDuplicates' " ^ elementNotIn ! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 4/2/2009 11:53'! elementNotInForOccurrences ^ elementNotIn! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:28'! elementToAdd " return an element of type 'nonEmpy' elements'type'" ^ elementNotIn ! ! !HeapTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 3/20/2009 11:33'! elementTwiceIn ^elementTwiceIn! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 16:06'! elementTwiceInForOccurrences " return an element included exactly two time in # collectionWithEqualElements" ^ duplicateElement ! ! !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: 'cyrille.delaunay 3/18/2009 15:24'! empty ^empty.! ! !HeapTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 3/20/2009 11:19'! expectedElementByDetect "Returns the first even element of #collection" ^ expectedElementByDetect. ! ! !HeapTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 3/20/2009 13:46'! expectedSizeAfterReject "Number of even elements in #collection" ^ expectedSizeAfterReject.! ! !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: 'requirements' stamp: 'delaunay 5/11/2009 11:05'! firstIndex " return an index between 'nonEmpty' bounds that is < to 'second index' " ^2! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:19'! indexArray " return a Collection including indexes between bounds of 'nonEmpty' " ^ indexArray ! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:39'! indexInForCollectionWithoutDuplicates " return an index between 'collectionWithoutEqualsElements' bounds" ^ 2! ! !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:12'! integerCollectionWithoutEqualElements " return a collection of integer without equal elements" ^ nonEmpty5ElementsWithoutDuplicate ! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:07'! moreThan3Elements " return a collection including atLeast 3 elements" ^ nonEmpty5ElementsWithoutDuplicate ! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/4/2009 10:12'! moreThan4Elements " return a collection including at leat 4 elements" ^ nonEmpty5ElementsWithoutDuplicate ! ! !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: 'cyrille.delaunay 3/18/2009 15:23'! nonEmpty ^nonEmpty.! ! !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:44'! nonEmptyMoreThan1Element " return a collection that don't includes equal elements'" ^nonEmpty5ElementsWithoutDuplicate .! ! !HeapTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 10:53'! nonEmptyWithoutEqualElements " return a collection without equal elements " ^ nonEmpty5ElementsWithoutDuplicate ! ! !HeapTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 3/18/2009 15:08'! otherCollection ^ otherCollection! ! !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 11:09'! replacementCollectionSameSize " return a collection of size (secondIndex - firstIndex + 1)" ^subCollection ! ! !HeapTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 12/18/2009 12:05'! result ^ collectResult.! ! !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 11:06'! secondIndex " return an index between 'nonEmpty' bounds that is > to 'second index' " ^3! ! !HeapTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 12/18/2009 13:08'! sizeCollection "Answers a collection whose #size is 4" ^collectionWith4Elements ! ! !HeapTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 3/20/2009 11:26'! speciesClass ^ speciesClass! ! !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: 'requirements' stamp: 'delaunay 5/11/2009 10:13'! withEqualElements ^ sameAtEndAndBegining ! ! !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: 'test - creation'! testWith "self debug: #testWith" | aCol anElement | anElement := self collectionMoreThan5Elements anyOne. aCol := self collectionClass with: anElement. self assert: (aCol includes: anElement).! ! !HeapTest methodsFor: 'test - creation'! 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: 'test - creation'! 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: 'test - creation'! 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: 'test - creation'! 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: 'test - creation'! 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: 'test - remove'! 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: '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: 'testing' stamp: 'md 2/12/2006 15:35'! testExamples self shouldnt: [self heapExample] raise: Error. self shouldnt: [self heapSortExample] raise: Error.! ! !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 - adding'! 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 - adding'! 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'! 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'! 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 - adding'! 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 - adding'! 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: 'tests - adding'! 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 - adding'! 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 - as identity set'! 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: 'tests - as identity set'! 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 - as set tests'! 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 - as set tests'! testAsSetWithEqualsElements | result | result := self withEqualElements asSet. self withEqualElements do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. self assert: result class = Set! ! !HeapTest methodsFor: 'tests - as sorted collection' stamp: 'hfm 4/2/2010 13:37'! 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: 'tests - as sorted collection'! 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 - as sorted collection'! 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'! 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: 'tests - converting'! 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: 'tests - converting'! assertSameContents: aCollection whenConvertedTo: aClass | result | result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass. self assert: result size = aCollection size! ! !HeapTest methodsFor: 'tests - converting'! testAsArray "self debug: #testAsArray3" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Array! ! !HeapTest methodsFor: 'tests - converting'! testAsBag self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! ! !HeapTest methodsFor: 'tests - converting'! testAsByteArray | res | self shouldnt: [self integerCollectionWithoutEqualElements ] raise: Error. 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: 'tests - converting'! testAsIdentitySet "test with a collection without equal elements :" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: IdentitySet. ! ! !HeapTest methodsFor: 'tests - converting'! testAsOrderedCollection self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! ! !HeapTest methodsFor: 'tests - converting'! testAsSet | | "test with a collection without equal elements :" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Set. ! ! !HeapTest methodsFor: 'tests - copy'! 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: 'tests - copy'! 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: 'tests - copy'! 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 - copy'! 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: 'tests - copy'! 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'! 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'! 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 - copy'! 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: 'tests - copy'! 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 - copy'! 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 - copy'! 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: 'tests - fixture'! test0CopyTest self shouldnt: [ self empty ]raise: Error. self assert: self empty size = 0. self shouldnt: [ self nonEmpty ]raise: Error. self assert: (self nonEmpty size = 0) not. self shouldnt: [ self collectionWithElementsToRemove ]raise: Error. self assert: (self collectionWithElementsToRemove size = 0) not. self collectionWithElementsToRemove do: [:each | self assert: ( self nonEmpty includes: each)]. self shouldnt: [ self elementToAdd ]raise: Error. self deny: (self nonEmpty includes: self elementToAdd ). self shouldnt: [ self collectionNotIncluded ]raise: Error. self collectionNotIncluded do: [ :each | self deny: (self nonEmpty includes: each) ]! ! !HeapTest methodsFor: 'tests - fixture'! test0FixtureAsSetForIdentityMultiplinessTest "a collection (of elements for which copy is not identical ) without equal elements:" | anElement res | self shouldnt: [ self elementsCopyNonIdenticalWithoutEqualElements ]raise: Error. 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: 'tests - fixture'! test0FixtureConverAsSortedTest self shouldnt: [self collectionWithSortableElements ] raise: Error. self deny: self collectionWithSortableElements isEmpty .! ! !HeapTest methodsFor: 'tests - fixture'! test0FixtureCreationWithTest self shouldnt: [ self collectionMoreThan5Elements ] raise: Error. self assert: self collectionMoreThan5Elements size >= 5.! ! !HeapTest methodsFor: 'tests - fixture'! test0FixtureIncludeTest | anElementIn | self shouldnt: [ self nonEmpty ]raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self elementNotIn ]raise: Error. anElementIn := true. self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self shouldnt: [ self anotherElementNotIn ]raise: Error. anElementIn := true. self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self shouldnt: [ self empty ] raise: Error. self assert: self empty isEmpty. ! ! !HeapTest methodsFor: 'tests - fixture'! test0FixtureIncludeWithIdentityTest | anElement | self shouldnt: [ self collectionWithCopyNonIdentical ]raise: Error. anElement := self collectionWithCopyNonIdentical anyOne. self deny: anElement == anElement copy.! ! !HeapTest methodsFor: 'tests - fixture'! test0FixtureOccurrencesForMultiplinessTest | cpt anElement collection | self shouldnt: [ self collectionWithEqualElements ] raise: Error. self shouldnt: [ self collectionWithEqualElements ] raise: Error. self shouldnt: [ self elementTwiceInForOccurrences ] raise: Error. 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 - fixture'! test0FixtureOccurrencesTest | tmp | self shouldnt: [self empty ]raise: Error. self assert: self empty isEmpty. self shouldnt: [ self collectionWithoutEqualElements ] raise: Error. self deny: self collectionWithoutEqualElements isEmpty. tmp := OrderedCollection new. self collectionWithoutEqualElements do: [ :each | self deny: (tmp includes: each). tmp add: each. ]. self shouldnt: [ self elementNotInForOccurrences ] raise: Error. self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! ! !HeapTest methodsFor: 'tests - fixture'! test0FixtureRequirementsOfTAddTest self shouldnt: [ self collectionWithElement ] raise: Exception. self shouldnt: [ self otherCollection ] raise: Exception. self shouldnt: [ self element ] raise: Exception. self assert: (self collectionWithElement includes: self element). self deny: (self otherCollection includes: self element)! ! !HeapTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/2/2009 11:53'! test0FixtureRequirementsOfTGrowableTest self shouldnt: [ self empty ] raise: Exception. self shouldnt: [ self nonEmpty ] raise: Exception. self shouldnt: [ self element ] raise: Exception. self shouldnt: [ self elementNotInForOccurrences ] raise: Exception. 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'! test0FixtureSetAritmeticTest self shouldnt: [ self collection ] raise: Error. self deny: self collection isEmpty. self shouldnt: [ self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self anotherElementOrAssociationNotIn ] raise: Error. self collection isDictionary ifTrue: [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ] ifFalse: [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ]. self shouldnt: [ self collectionClass ] raise: Error! ! !HeapTest methodsFor: 'tests - fixture'! test0FixtureTConvertAsSetForMultiplinessTest "a collection with equal elements:" | res | self shouldnt: [ self withEqualElements] raise: Error. res := true. self withEqualElements detect: [ :each | (self withEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = true. ! ! !HeapTest methodsFor: 'tests - fixture'! test0FixtureTConvertTest "a collection of number without equal elements:" | res | self shouldnt: [ self collectionWithoutEqualElements ]raise: Error. res := true. self collectionWithoutEqualElements detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false. ! ! !HeapTest methodsFor: 'tests - fixture'! test0FixtureTRemoveTest | duplicate | self shouldnt: [ self empty ]raise: Error. self shouldnt: [ self nonEmptyWithoutEqualElements] raise:Error. self deny: self nonEmptyWithoutEqualElements isEmpty. duplicate := true. self nonEmptyWithoutEqualElements detect: [:each | (self nonEmptyWithoutEqualElements occurrencesOf: each) > 1] ifNone: [duplicate := false]. self assert: duplicate = false. self shouldnt: [ self elementNotIn ] raise: Error. self assert: self empty isEmpty. self deny: self nonEmptyWithoutEqualElements isEmpty. self deny: (self nonEmptyWithoutEqualElements includes: self elementNotIn)! ! !HeapTest methodsFor: 'tests - growable'! testAddEmptyGrows "self debug: #testAddEmptyGrows" | oldSize | oldSize := self empty size. self empty add: self element. self assert: (self empty size) = (oldSize + 1).! ! !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: 'tests - includes'! 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 - includes'! testIncludesAllNoneThere "self debug: #testIncludesAllOfNoneThere'" self deny: (self empty includesAll: self nonEmpty ). self deny: (self nonEmpty includesAll: { self elementNotIn. self anotherElementNotIn })! ! !HeapTest methodsFor: 'tests - includes'! 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: 'tests - includes'! testIncludesAnyNoneThere "self debug: #testIncludesAnyOfNoneThere'" self deny: (self nonEmpty includesAny: self empty). self deny: (self nonEmpty includesAny: { self elementNotIn. self anotherElementNotIn })! ! !HeapTest methodsFor: 'tests - includes'! 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: 'tests - includes'! testIncludesElementIsThere "self debug: #testIncludesElementIsThere" self assert: (self nonEmpty includes: self nonEmpty anyOne).! ! !HeapTest methodsFor: 'tests - including with identity'! 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: 'tests - occurrencesOf'! testOccurrencesOf | collection | collection := self collectionWithoutEqualElements . collection do: [ :each | self assert: (collection occurrencesOf: each) = 1 ].! ! !HeapTest methodsFor: 'tests - occurrencesOf'! testOccurrencesOfEmpty | result | result := self empty occurrencesOf: (self collectionWithoutEqualElements anyOne). self assert: result = 0! ! !HeapTest methodsFor: 'tests - occurrencesOf'! testOccurrencesOfNotIn | result | result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences. self assert: result = 0! ! !HeapTest methodsFor: 'tests - occurrencesOf for multipliness'! testOccurrencesOfForMultipliness | collection elem | collection := self collectionWithEqualElements . elem := self elementTwiceInForOccurrences . self assert: (collection occurrencesOf: elem ) = 2. ! ! !HeapTest methodsFor: 'tests - remove'! testRemoveAll "self debug: #testRemoveElementThatExists" | el aSubCollection collection | collection := self nonEmptyWithoutEqualElements. el := collection anyOne. aSubCollection := collection copyWithout: el. self shouldnt: [ | res | res := collection removeAll: aSubCollection ] raise: Error. self assert: collection size = 1. self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! ! !HeapTest methodsFor: 'tests - remove'! testRemoveAllError "self debug: #testRemoveElementThatExists" | el aSubCollection | el := self elementNotIn. aSubCollection := self nonEmptyWithoutEqualElements copyWith: el. self should: [ | res | res := self nonEmptyWithoutEqualElements removeAll: aSubCollection ] raise: Error! ! !HeapTest methodsFor: 'tests - remove'! testRemoveAllFoundIn "self debug: #testRemoveElementThatExists" | el aSubCollection | el := self nonEmptyWithoutEqualElements anyOne. aSubCollection := (self nonEmptyWithoutEqualElements copyWithout: el) copyWith: self elementNotIn. self shouldnt: [ | res | res := self nonEmptyWithoutEqualElements removeAllFoundIn: aSubCollection ] raise: Error. self assert: self nonEmptyWithoutEqualElements size = 1. self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! ! !HeapTest methodsFor: 'tests - remove'! 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: 'tests - remove'! testRemoveElementFromEmpty "self debug: #testRemoveElementFromEmpty" self should: [ self empty remove: self nonEmptyWithoutEqualElements anyOne ] raise: Error! ! !HeapTest methodsFor: 'tests - remove'! 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 - remove'! testRemoveElementThatExists "self debug: #testRemoveElementThatExists" | el res | el := self nonEmptyWithoutEqualElements anyOne. self shouldnt: [ res := self nonEmptyWithoutEqualElements remove: el ] raise: Error. self assert: res == el! ! !HeapTest methodsFor: 'tests - remove'! testRemoveIfAbsent "self debug: #testRemoveElementThatExists" | el res | el := self elementNotIn. self shouldnt: [ res := self nonEmptyWithoutEqualElements remove: el ifAbsent: [ 33 ] ] raise: Error. self assert: res = 33! ! !HeapTest methodsFor: 'tests - set arithmetic'! 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 - set arithmetic'! numberOfSimilarElementsInIntersection ^ self collection occurrencesOf: self anotherElementOrAssociationIn! ! !HeapTest methodsFor: 'tests - set arithmetic'! 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 - set arithmetic'! 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: 'tests - set arithmetic'! 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 = 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 = separateCol! ! !HeapTest methodsFor: 'tests - set arithmetic'! 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'! 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: 'tests - set arithmetic'! 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: 'tests - set arithmetic'! 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: 'tests - set arithmetic'! 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: 'tests - set arithmetic'! testUnionOfEmpties "self debug: #testUnionOfEmpties" self assert: (self empty union: self empty) isEmpty. ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HeapTest class uses: TAddTest classTrait + TGrowableTest classTrait + TConvertTest classTrait + TConvertAsSortedTest classTrait + TConvertAsSetForMultiplinessIdentityTest classTrait + TCopyTest classTrait + TSetArithmetic classTrait + TRemoveForMultiplenessTest classTrait + TCreationWithTest classTrait + TIncludesWithIdentityCheckTest classTrait + TOccurrencesForMultiplinessTest classTrait instanceVariableNames: ''! HelpOnHelp subclass: #HelpAPIDocumentation instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Help'! !HelpAPIDocumentation commentStamp: 'tbn 4/30/2010 15:12' prior: 0! This class represents the browsable package API help for the help system. Instance Variables ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HelpAPIDocumentation class instanceVariableNames: ''! !HelpAPIDocumentation class methodsFor: 'accessing' stamp: 'tbn 3/29/2010 14:50'! bookName ^'API Documentation'! ! !HelpAPIDocumentation class methodsFor: 'accessing' stamp: 'tbn 3/11/2010 23:55'! packages ^#('HelpSystem-Core-Model' 'HelpSystem-Core-Utilities' 'HelpSystem-Core-UI')! ! !HelpAPIDocumentation class methodsFor: 'defaults' stamp: 'tbn 3/11/2010 23:57'! builder ^PackageAPIHelpBuilder! ! Object subclass: #HelpBrowser instanceVariableNames: 'rootTopic window treeMorph contentMorph helpTopicCache' classVariableNames: 'DefaultHelpBrowser' poolDictionaries: '' category: 'HelpSystem-Core-UI'! !HelpBrowser commentStamp: 'tbn 3/8/2010 09:33' prior: 0! 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: '*Shout-Styling' stamp: 'AlainPantec 2/23/2012 08:30'! shoutAboutToStyle: aPluggableShoutMorphOrView ^ (self rootTopic respondsTo: #canHaveSyntaxHighlighting) and: [self rootTopic canHaveSyntaxHighlighting]! ! !HelpBrowser methodsFor: 'accessing' stamp: 'tbn 3/5/2010 22:56'! rootTopic ^rootTopic! ! !HelpBrowser methodsFor: 'accessing' stamp: 'tbn 3/6/2010 00:11'! rootTopic: aHelpTopic rootTopic := aHelpTopic. self refresh ! ! !HelpBrowser methodsFor: 'actions' stamp: 'AlexandreBergel 4/29/2011 21:05'! helpTopic ^ helpTopicCache ifNil: [ helpTopicCache := rootTopic asHelpTopic ]! ! !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: 'defaults' stamp: 'tbn 4/30/2010 12:39'! defaultViewerClass ^PluggableTextMorph! ! !HelpBrowser methodsFor: 'events' stamp: 'tbn 9/20/2010 09:52'! onItemClicked: anItem anItem isNil ifTrue: [^contentMorph setText: rootTopic asHelpTopic contents]. contentMorph setText: anItem contents! ! !HelpBrowser methodsFor: 'initialize-release' stamp: 'tbn 3/5/2010 23:39'! initialize super initialize. self initWindow. ! ! !HelpBrowser methodsFor: 'ui' stamp: 'tbn 2/12/2010 12:57'! close window notNil ifTrue: [window delete]! ! !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: 'ui' stamp: 'tbn 3/3/2010 23:32'! open "Open the receivers window" self refresh. window openInWorld. ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HelpBrowser class instanceVariableNames: ''! !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: 'tbn 5/3/2010 18:37'! defaultHelpBrowser DefaultHelpBrowser isNil ifTrue: [DefaultHelpBrowser := self]. ^DefaultHelpBrowser ! ! !HelpBrowser class methodsFor: 'accessing' stamp: 'tbn 5/3/2010 18:42'! defaultHelpBrowser: aClass "Use a new help browser implementation" DefaultHelpBrowser := aClass ! ! !HelpBrowser class methodsFor: 'accessing' stamp: 'FernandoOlivero 4/12/2011 09:51'! theme ^ UITheme current ! ! !HelpBrowser class methodsFor: 'instance creation' stamp: 'tbn 5/3/2010 18:37'! open ^self openOn: SystemHelp! ! !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: 'world menu' stamp: 'FernandoOlivero 4/12/2011 09:46'! menuCommandOn: aBuilder (aBuilder item: #'Help Browser') parent: #Help; action: [self open]; icon: self theme smallHelpIcon! ! TestCase subclass: #HelpBrowserTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Tests-Core-UI'! !HelpBrowserTest methodsFor: 'accessing' stamp: 'tbn 5/3/2010 19:35'! defaultTestClass ^HelpBrowser! ! !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: '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! ! !HelpBrowserTest methodsFor: 'testing' stamp: 'tbn 12/20/2010 17:05'! testOpen |block| block := [ |browser| browser := self defaultTestClass open. World doOneCycleNow. browser close ]. self shouldnt: block raise: Error ! ! Object subclass: #HelpBuilder instanceVariableNames: 'topicToBuild rootToBuildFrom' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Builders'! !HelpBuilder commentStamp: 'tbn 2/12/2010 14:54' prior: 0! This is an utility class that builds the books for a help system. Instance Variables rootTopics: rootTopics - a collection of books ! !HelpBuilder methodsFor: 'accessing' stamp: 'tbn 2/12/2010 14:53'! rootToBuildFrom: anObject rootToBuildFrom := anObject! ! !HelpBuilder methodsFor: 'accessing' stamp: 'tbn 3/5/2010 23:15'! topicToBuild ^topicToBuild! ! !HelpBuilder methodsFor: 'building' stamp: 'tbn 3/3/2010 22:55'! build self subclassResponsibility ! ! !HelpBuilder methodsFor: 'initialize-release' stamp: 'tbn 3/5/2010 23:12'! initialize "Initializes the receiver" super initialize. topicToBuild := self topicClass new. ! ! !HelpBuilder methodsFor: 'private accessing' stamp: 'tbn 3/5/2010 23:13'! topicClass ^HelpTopic! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HelpBuilder class instanceVariableNames: ''! !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 ! ! HelpOnHelp subclass: #HelpHowToHelpTopics instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Help'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HelpHowToHelpTopics class instanceVariableNames: ''! !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 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. '! ! !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: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 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 subclass: #HelpHowToHelpTopicsFromCode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Help'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HelpHowToHelpTopicsFromCode class instanceVariableNames: ''! !HelpHowToHelpTopicsFromCode class methodsFor: 'accessing' stamp: 'tbn 3/29/2010 14:06'! bookName ^'Custom help from code'! ! !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/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: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: '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: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, ...) ' ! ! !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/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: '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 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. ' ! ! Object subclass: #HelpIcons instanceVariableNames: '' classVariableNames: 'Icons' poolDictionaries: '' category: 'HelpSystem-Core-UI'! !HelpIcons commentStamp: 'tbn 3/8/2010 09:29' prior: 0! 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 instanceVariableNames: ''! !HelpIcons class methodsFor: 'accessing' stamp: 'tbn 2/12/2010 15:54'! iconNamed: aSymbol ^self icons at: aSymbol ifAbsentPut: [self perform: aSymbol]! ! !HelpIcons class methodsFor: 'accessing' stamp: 'tbn 2/12/2010 15:55'! icons Icons isNil ifTrue: [Icons := Dictionary new]. ^Icons! ! !HelpIcons class methodsFor: 'private icons' stamp: 'tbn 3/3/2010 23:53'! blankIcon ^Form extent: 12 @ 1 depth:8! ! !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: '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 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)! ! TestCase subclass: #HelpIconsTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Tests-Core-UI'! !HelpIconsTest methodsFor: 'accessing' stamp: 'tbn 2/12/2010 14:23'! defaultTestClass ^HelpIcons! ! !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. ] ! ! CustomHelp subclass: #HelpOnHelp instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Help'! !HelpOnHelp commentStamp: 'tbn 2/12/2010 14:27' prior: 0! Welcome to Pharo Smalltalk Help System! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HelpOnHelp class instanceVariableNames: ''! !HelpOnHelp class methodsFor: 'accessing' stamp: 'tbn 2/19/2010 14:21'! bookName ^'Help on Help'! ! !HelpOnHelp class methodsFor: 'accessing' stamp: 'tbn 3/5/2010 23:56'! key ^'HelpOnHelp'! ! !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! ! Object subclass: #HelpTopic instanceVariableNames: 'title key icon contents subtopics' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Model'! !HelpTopic commentStamp: 'tbn 3/29/2010 14:53' prior: 0! 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/8/2010 16:40'! addSubtopic: aTopic "Adds the given topic to the receivers collection of subtopics" self subtopics add: aTopic. ^aTopic! ! !HelpTopic methodsFor: 'accessing' stamp: 'tbn 3/6/2010 00:19'! contents "Returns the receivers contents" ^ contents! ! !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: 'tbn 3/6/2010 00:19'! icon "Returns the receivers icon" ^icon! ! !HelpTopic methodsFor: 'accessing' stamp: 'tbn 3/6/2010 00:20'! icon: aSymbol "Sets the receivers icon" icon := aSymbol ! ! !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:20'! key: aUniqueKey "Sets a unique key identifying the receiver in the help system" key := aUniqueKey ! ! !HelpTopic methodsFor: 'accessing' stamp: 'tbn 3/6/2010 00:21'! subtopics "Returns the receivers list of subtopics" subtopics isNil ifTrue: [subtopics := OrderedCollection new]. ^subtopics! ! !HelpTopic methodsFor: 'accessing' stamp: 'tbn 3/6/2010 00:22'! subtopics: aCollection "Sets the receivers subtopics" subtopics := aCollection ! ! !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: 'comparing' stamp: 'tbn 3/8/2010 09:11'! <= anotherHelpTopic "Use sorting by title as the default sort order" ^self title <= anotherHelpTopic title ! ! !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: 'initialize-release' stamp: 'tbn 3/8/2010 08:44'! initialize "Initializes the receiver" super initialize. self title: self defaultTitle. self contents: ''. self key: '' ! ! !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 class instanceVariableNames: ''! !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 contents: aText "Create a new instance with given title and content" ^(self new) title: aTitle; contents: aText; 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. ! ! PluggableListItemWrapper subclass: #HelpTopicListItemWrapper instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-UI'! !HelpTopicListItemWrapper commentStamp: 'tbn 3/8/2010 09:30' prior: 0! This class implements a list item wrapper for help topics. Instance Variables ! !HelpTopicListItemWrapper methodsFor: 'accessing' stamp: 'tbn 3/8/2010 17:25'! asString "Returns a string used as a label" ^item title! ! !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/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! ! TestCase subclass: #HelpTopicListItemWrapperTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Tests-Core-UI'! !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' ! ! TestCase subclass: #HelpTopicTest instanceVariableNames: 'topic' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Tests-Core-Model'! !HelpTopicTest methodsFor: 'accessing' stamp: 'tbn 3/5/2010 21:47'! defaultTestClass ^HelpTopic ! ! !HelpTopicTest methodsFor: 'running' stamp: 'tbn 3/5/2010 21:49'! setUp super setUp. topic := self defaultTestClass new.! ! !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: '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: '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. ! ! URI subclass: #HierarchicalURI instanceVariableNames: 'authority query pathComponents' classVariableNames: '' poolDictionaries: '' category: 'Network-URI'! !HierarchicalURI commentStamp: 'LaurentLaffont 6/8/2011 22:17' prior: 0! See URI comment.! !HierarchicalURI methodsFor: 'accessing' stamp: 'mir 3/6/2002 14:46'! absolutePath ^self schemeSpecificPart isEmpty ifTrue: ['/'] ifFalse: [self schemeSpecificPart]! ! !HierarchicalURI methodsFor: 'accessing' stamp: 'mir 2/25/2002 18:37'! authority ^authority! ! !HierarchicalURI methodsFor: 'accessing' stamp: 'mir 3/22/2007 12:46'! baseName "returns the last component stripped of its extension" | baseName i | baseName := self name. i := baseName findLast: [:c | c = $.]. ^i = 0 ifTrue: [baseName] ifFalse: [baseName copyFrom: 1 to: i-1]. ! ! !HierarchicalURI methodsFor: 'accessing' stamp: 'marcus.denker 2/20/2009 16:29'! baseNameUnescaped "returns the last component stripped of its extension" ^self baseName unescapePercents! ! !HierarchicalURI methodsFor: 'accessing' stamp: 'JMM 8/2/2007 11:54'! baseNameWithExtension "returns the last component foo.bar" ^self pathComponents last. ! ! !HierarchicalURI methodsFor: 'accessing' stamp: 'marcus.denker 2/20/2009 16:29'! baseNameWithExtensionUnescaped "returns the last component foo.bar as unescaped " ^self pathComponents last unescapePercents. ! ! !HierarchicalURI methodsFor: 'accessing' stamp: 'JMM 5/8/2006 16:28'! extension "This method assumes a $. as extension delimiter" | i leafName | self pathComponents ifEmpty: [^'']. leafName := self pathComponents last. i := leafName findLast: [:c | c = $.]. ^i = 0 ifTrue: [''] ifFalse: [leafName copyFrom: i + 1 to: leafName size]. ! ! !HierarchicalURI methodsFor: 'accessing' stamp: 'mir 2/20/2002 17:26'! host ^self authority host! ! !HierarchicalURI methodsFor: 'accessing' stamp: 'mir 4/18/2007 21:52'! name "returns the last component" ^self pathComponents last unescapePercents! ! !HierarchicalURI methodsFor: 'accessing' stamp: 'mir 2/27/2002 14:21'! path " ^self schemeSpecificPart isEmpty ifTrue: ['/'] ifFalse: [self schemeSpecificPart]" ^self schemeSpecificPart! ! !HierarchicalURI methodsFor: 'accessing' stamp: 'mir 3/17/2007 18:28'! pathAndQuery ^query ifNil: [self path] ifNotNil: [self path , self query]! ! !HierarchicalURI methodsFor: 'accessing' stamp: 'mir 4/18/2007 22:12'! pathComponents ^pathComponents ifNil: [pathComponents := (self path findTokens: $/) collect: [:each | each unescapePercents]]! ! !HierarchicalURI methodsFor: 'accessing' stamp: 'JMM 8/2/2007 11:50'! pathComponentsUnescaped ^(self path findTokens: $/) collect: [:e | e unescapePercents].! ! !HierarchicalURI methodsFor: 'accessing' stamp: 'mir 2/20/2002 17:26'! port ^self authority port! ! !HierarchicalURI methodsFor: 'accessing' stamp: 'mir 2/20/2002 17:27'! query ^query! ! !HierarchicalURI methodsFor: 'accessing' stamp: 'jannik.laval 2/5/2010 21:45'! resolveRelativeURI: aURI | relativeURI newAuthority newPath pathParts newURI relComps | relativeURI := aURI asURI. relativeURI isAbsolute ifTrue: [^relativeURI]. relativeURI authority ifNil: [ newAuthority := self authority. (relativeURI path beginsWith: '/') ifTrue: [newPath := relativeURI path] ifFalse: [ pathParts := (self path copyUpToLast: $/) findTokens: $/. relComps := relativeURI pathComponents. relComps removeAllSuchThat: [:each | each = '.']. pathParts addAll: relComps. pathParts removeAllSuchThat: [:each | each = '.']. self removeComponentDotDotPairs: pathParts. newPath := self buildAbsolutePath: pathParts. ((relComps isEmpty or: [relativeURI path last == $/ or: [(relativeURI path endsWith: '/..') or: [relativeURI path = '..' or: [relativeURI path endsWith: '/.' ]]]]) and: [newPath size > 1]) ifTrue: [newPath := newPath , '/']]] ifNotNil: [ newAuthority := relativeURI authority. newPath := relativeURI path]. newURI := String streamContents: [:stream | stream nextPutAll: self scheme. stream nextPut: $: . newAuthority notNil ifTrue: [ stream nextPutAll: '//'. newAuthority printOn: stream]. newPath notNil ifTrue: [stream nextPutAll: newPath]. relativeURI query notNil ifTrue: [stream nextPutAll: relativeURI query]. relativeURI fragment notNil ifTrue: [ stream nextPut: $# . stream nextPutAll: relativeURI fragment]]. ^newURI asURI! ! !HierarchicalURI methodsFor: 'accessing' stamp: 'mir 2/20/2002 17:27'! userInfo ^self authority userInfo! ! !HierarchicalURI methodsFor: 'converting' stamp: 'CamilloBruni 5/7/2012 01:01'! asFileReference "convert this FileUrl to a FileReference" ^ FileSystem disk root resolve: self absolutePath unescapePercents! ! !HierarchicalURI methodsFor: 'directory operations' stamp: 'mir 3/8/2002 10:51'! assureExistance ! ! !HierarchicalURI methodsFor: 'printing' stamp: 'mir 2/27/2002 12:51'! printSchemeSpecificPartOn: stream self isAbsolute ifTrue: [stream nextPutAll: '//']. authority ifNotNil: [self authority printOn: stream]. super printSchemeSpecificPartOn: stream. query ifNotNil: [stream nextPutAll: query]! ! !HierarchicalURI methodsFor: 'private' stamp: 'mir 6/20/2005 18:49'! absoluteFromString: aString scheme: schemeName | remainder | super absoluteFromString: aString scheme: schemeName. "We now have the interesting part in schemeSpecficPart and can parse it further" "This check is somewhat redundant, just in case somebody calls this directly." remainder := schemeSpecificPart. (remainder isEmpty or: [remainder first ~~ $/]) ifTrue: [(IllegalURIException new uriString: remainder) signal: 'Invalid absolute URI']. (aString beginsWith: '//') ifTrue: [remainder := self extractAuthority: (remainder copyFrom: 3 to: remainder size)]. self extractSchemeSpecificPartAndFragment: remainder! ! !HierarchicalURI methodsFor: 'private' stamp: 'mir 4/18/2007 22:10'! buildAbsolutePath: pathParts ^String streamContents: [:stream | stream nextPut: $/. pathParts do: [:pathPart | stream nextPutAll: pathPart] separatedBy: [stream nextPut: $/]]! ! !HierarchicalURI methodsFor: 'private' stamp: 'mir 2/27/2002 12:46'! extractAuthority: aString | endAuthorityIndex authorityString | endAuthorityIndex := (aString indexOf: $/ ) - 1. endAuthorityIndex < 0 ifTrue: [endAuthorityIndex := aString size]. authorityString := aString copyFrom: 1 to: endAuthorityIndex. authority := URIAuthority fromString: authorityString. ^aString copyFrom: endAuthorityIndex+1 to: aString size! ! !HierarchicalURI methodsFor: 'private' stamp: 'StephaneDucasse 4/3/2010 13:02'! extractQuery: remainder | queryIndex | queryIndex := remainder indexOf: $?. queryIndex > 0 ifFalse: [^remainder]. query := remainder copyFrom: queryIndex to: remainder size. ^remainder copyFrom: 1 to: queryIndex-1! ! !HierarchicalURI methodsFor: 'private' stamp: 'mir 2/26/2002 14:13'! extractSchemeSpecificPartAndFragment: remainder super extractSchemeSpecificPartAndFragment: remainder. schemeSpecificPart := self extractQuery: schemeSpecificPart! ! !HierarchicalURI methodsFor: 'private' stamp: 'StephaneDucasse 5/28/2011 13:33'! relativeFromString: aString | remainder authorityEnd | remainder := (aString beginsWith: '//') ifTrue: [ authorityEnd := aString indexOf: $/ startingAt: 3. authorityEnd = 0 ifTrue: [authorityEnd := aString size+1]. self extractAuthority: (aString copyFrom: 3 to: authorityEnd-1)] ifFalse: [aString]. self extractSchemeSpecificPartAndFragment: remainder! ! !HierarchicalURI methodsFor: 'private' stamp: 'mir 4/18/2007 22:11'! removeComponentDotDotPairs: pathParts | dotDotIndex | dotDotIndex := pathParts indexOf: '..'. [dotDotIndex > 1] whileTrue: [ pathParts removeAt: dotDotIndex; removeAt: dotDotIndex-1. dotDotIndex := pathParts indexOf: '..']! ! Url subclass: #HierarchicalUrl instanceVariableNames: 'schemeName authority path query port username password' classVariableNames: '' poolDictionaries: '' category: 'Network-Url'! !HierarchicalUrl commentStamp: '' prior: 0! A URL which has a hierarchical encoding. For instance, http and ftp URLs are hierarchical.! !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: 'access' stamp: 'ls 6/20/1998 19:58'! authority ^authority! ! !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: '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: 'access' stamp: 'ls 6/15/2003 13:13'! password "http://user:pword@foo.com' asUrl password" ^password! ! !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: 'gk 10/21/2005 11:15'! path: aCollection "Set the collection of path elements." path := aCollection! ! !HierarchicalUrl methodsFor: 'access' stamp: 'mir 7/30/1999 13:05'! port ^port! ! !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: 'ls 6/20/1998 19:58'! schemeName ^schemeName! ! !HierarchicalUrl methodsFor: 'access' stamp: 'ls 6/15/2003 13:13'! username "http://user:pword@foo.com' asUrl username" ^username! ! !HierarchicalUrl methodsFor: 'classification' stamp: 'FBS 11/20/2003 13:07'! scheme ^ self schemeName.! ! !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: 'downloading' stamp: 'ls 8/4/1998 20:44'! hasContents "most of these do...." ^true! ! !HierarchicalUrl methodsFor: 'parsing' stamp: 'StephaneDucasse 5/9/2010 20:26'! privateInitializeFromText: aString | remainder ind specifiedSchemeName | remainder := aString. schemeName ifNil: [specifiedSchemeName := Url 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) unescapePercents. username := (username copyUpTo: $:) unescapePercents]]. "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: 'ls 6/15/2003 13:40'! 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" (remainder beginsWith: '/') ifTrue: [ basePath := #() ] ifFalse: [ basePath := aUrl path ]. path := self privateParsePath: remainder relativeTo: basePath. ! ! !HierarchicalUrl methodsFor: 'parsing' stamp: 'PeterHugossonMiller 9/3/2009 02:00'! 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 unescapePercents. 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: 'printing' stamp: 'PeterHugossonMiller 9/3/2009 02:00'! fullPath | ans | ans := String new writeStream. path do: [ :pathElem | ans nextPut: $/. ans nextPutAll: pathElem encodeForHTTP. ]. self query isNil ifFalse: [ ans nextPut: $?. ans nextPutAll: self query. ]. self fragment isNil ifFalse: [ ans nextPut: $#. ans nextPutAll: self fragment encodeForHTTP. ]. ^ans contents! ! !HierarchicalUrl methodsFor: 'printing' stamp: 'StephaneDucasse 5/9/2010 20:19'! printOn: aStream aStream nextPutAll: self schemeName. aStream nextPutAll: '://'. self username ifNotNil: [ aStream nextPutAll: self username encodeForHTTP. self password ifNotNil: [ aStream nextPutAll: ':'. aStream nextPutAll: self password encodeForHTTP]. aStream nextPutAll: '@' ]. aStream nextPutAll: self authority. port ifNotNil: [aStream nextPut: $:; print: port]. path do: [ :pathElem | aStream nextPut: $/. aStream nextPutAll: pathElem encodeForHTTP. ]. self query isNil ifFalse: [ aStream nextPut: $?. aStream nextPutAll: self query. ]. self fragment isNil ifFalse: [ aStream nextPut: $#. aStream nextPutAll: self fragment encodeForHTTP. ].! ! !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 class instanceVariableNames: ''! !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! ! ClassTestCase subclass: #HierarchicalUrlTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetworkTests-Url'! !HierarchicalUrlTest methodsFor: 'testing' stamp: 'fbs 2/2/2005 13:03'! testAsString | url | url := HierarchicalUrl new schemeName: 'ftp' authority: 'localhost' path: #('path' 'to' 'file') query: 'aQuery'. self assert: url asString = 'ftp://localhost/path/to/file?aQuery'.! ! Browser subclass: #HierarchyBrowser instanceVariableNames: 'classList centralClass' classVariableNames: '' poolDictionaries: '' category: 'Tools-Browser'! !HierarchyBrowser methodsFor: 'class list' stamp: 'sd 11/20/2005 21:27'! assureSelectionsShow "This is a workaround for the fact that a hierarchy browser, when launched, often does not show the selected class" | saveCatIndex saveMsgIndex | saveCatIndex := messageCategoryListIndex. saveMsgIndex := messageListIndex. self classListIndex: classListIndex. self messageCategoryListIndex: saveCatIndex. self messageListIndex: saveMsgIndex! ! !HierarchyBrowser methodsFor: 'class list' stamp: 'SvenVanCaekenberghe 1/8/2012 14:45'! classList classList := classList select: [ :each | Smalltalk globals includesKey: each trimBoth asSymbol ]. ^ classList! ! !HierarchyBrowser methodsFor: 'initialization' stamp: 'sw 5/8/2000 01:28'! changed: sym sym == #classList ifTrue: [self updateAfterClassChange]. super changed: sym! ! !HierarchyBrowser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:27'! classListIndex: newIndex "Cause system organization to reflect appropriate category" | newClassName ind | newIndex ~= 0 ifTrue: [newClassName := (classList at: newIndex) copyWithout: $ . systemCategoryListIndex := systemOrganizer numberOfCategoryOfElement: newClassName]. ind := super classListIndex: newIndex. self changed: #systemCategorySingleton. ^ ind! ! !HierarchyBrowser methodsFor: 'initialization' stamp: 'dew 9/15/2001 16:19'! defaultBrowserTitle ^ 'Hierarchy Browser'! ! !HierarchyBrowser methodsFor: 'initialization' stamp: 'nice 1/5/2010 15:59'! initHierarchyForClass: aClassOrMetaClass | index nonMetaClass tab | centralClass := aClassOrMetaClass. nonMetaClass := aClassOrMetaClass theNonMetaClass. self systemOrganizer: SystemOrganization. metaClassIndicated := aClassOrMetaClass isMeta. classList := OrderedCollection new. tab := ''. nonMetaClass allSuperclasses reverseDo: [:aClass | classList add: tab , aClass name. tab := tab , ' ']. index := classList size + 1. nonMetaClass allSubclassesWithLevelDo: [:aClass :level | | stab | stab := ''. 1 to: level do: [:i | stab := stab , ' ']. classList add: tab , stab , aClass name] startingLevel: 0. self classListIndex: index! ! !HierarchyBrowser methodsFor: 'initialization' stamp: 'tk 4/5/98 10:29'! openEditString: aString "Create a pluggable version of all the views for a HierarchyBrowser, including views and controllers. The top list view is of the currently selected system class category--a single item list." ^ self openSystemCatEditString: aString! ! !HierarchyBrowser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:27'! selectClass: classNotMeta | name | name := classNotMeta name. self classListIndex: (self classList findFirst: [:each | (each endsWith: name) and: [each size = name size or: [(each at: each size - name size) isSeparator]]])! ! !HierarchyBrowser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:27'! selectedClassName "Answer the name of the class currently selected. di bug fix for the case where name cannot be found -- return nil rather than halt" | aName | aName := super selectedClassName. ^ aName == nil ifTrue: [aName] ifFalse: [(aName copyWithout: $ ) asSymbol]! ! !HierarchyBrowser methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:27'! systemCategorySingleton | cls | cls := self selectedClass. ^ cls ifNil: [Array new] ifNotNil: [Array with: cls category]! ! !HierarchyBrowser methodsFor: 'initialization' stamp: 'rhi 12/2/2001 21:32'! updateAfterClassChange "It is possible that some the classes comprising the hierarchy have changed, so reinitialize the entire browser." (centralClass notNil and: [centralClass isObsolete not]) ifTrue: [self initHierarchyForClass: centralClass]! ! !HierarchyBrowser methodsFor: 'menu messages' stamp: 'tk 4/7/98 13:53'! buildClassBrowserEditString: aString "Create and schedule a new class browser for the current selection, if one exists, with initial textual contents set to aString." self spawnHierarchy! ! !HierarchyBrowser methodsFor: 'menu messages' stamp: 'tk 4/3/98 11:22'! 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." self inform: 'Use a normal Browser, in which you can see the entire category you are trying to remove.'! ! !HierarchyBrowser methodsFor: 'menu messages' stamp: 'sw 11/8/1999 13:35'! systemCatSingletonKey: aChar from: aView ^ self systemCatListKey: aChar from: aView! ! !HierarchyBrowser methodsFor: 'menu messages' stamp: 'MarcusDenker 10/7/2012 11:33'! systemCatSingletonMenu: aMenu ^aMenu addList: #( ('Find class... (f)' findClass) - ('Browse' buildSystemCategoryBrowser) ('FileOut' fileOutSystemCategory) ('Update' updateSystemCategories) - ('Rename...' renameSystemCategory) ('Remove' removeSystemCategory)).! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HierarchyBrowser class instanceVariableNames: ''! !HierarchyBrowser class methodsFor: 'instance creation' stamp: 'IgorStasenko 3/6/2011 18:54'! newFor: aClass "Open a new HierarchyBrowser on the given class" | newBrowser | newBrowser := self new initHierarchyForClass: aClass. Smalltalk tools browser openBrowserView: (newBrowser openSystemCatEditString: nil) label: newBrowser labelString "HierarchyBrowser newFor: Boolean"! ! Object subclass: #HistoryCollection instanceVariableNames: 'storage maxSize' classVariableNames: '' poolDictionaries: '' category: 'Nautilus-History'! !HistoryCollection commentStamp: 'BenjaminVanRyseghem 3/17/2011 13:41' prior: 0! 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: 'accessing' stamp: 'BenjaminVanRyseghem 3/17/2011 13:31'! maxSize ^ maxSize! ! !HistoryCollection methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/17/2011 13:32'! maxSize: anInteger maxSize := anInteger! ! !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: 'protocol' stamp: 'BenjaminVanRyseghem 3/17/2011 13:43'! at: anElement ^ storage detect: [:each | each 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:38'! identityIncludes: anElement ^ storage anySatisfy: [:association | association key == anElement ]! ! !HistoryCollection methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/17/2011 13:37'! includes: anElement ^ storage anySatisfy: [:association | association key = anElement ]! ! !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 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 9/14/2012 15:48'! mostViewedElements ^ (storage copy sort: [:a :b | a value >= b value]) collect: [:each | each key ]! ! !HistoryCollection methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/17/2011 14:03'! oldest ^ storage last 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 13:49'! size ^ storage size! ! !HistoryCollection methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/17/2011 14:03'! youngest ^ storage first key! ! !HistoryCollection methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/17/2011 13:47'! initialize super initialize. maxSize := 5. storage := OrderedCollection new: maxSize.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HistoryCollection class instanceVariableNames: ''! !HistoryCollection class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 3/17/2011 13:47'! maxSize: anInteger ^ self new maxSize: anInteger! ! Object subclass: #HistoryIterator instanceVariableNames: 'index plugged recorder maxSize' classVariableNames: '' poolDictionaries: '' category: 'System-History'! !HistoryIterator commentStamp: 'AlainPlantec 12/14/2010 23:40' prior: 0! 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:03'! at: anInteger ^ self recorder at: anInteger! ! !HistoryIterator methodsFor: 'accessing' stamp: 'AlainPlantec 12/14/2010 19:59'! at: anInteger put: anItem self recorder at: anInteger put: anItem! ! !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! ! !HistoryIterator methodsFor: 'accessing' stamp: 'AlainPlantec 12/14/2010 19:08'! first ^ self recorder first! ! !HistoryIterator methodsFor: 'accessing' stamp: 'AlainPlantec 12/14/2010 12:54'! index ^ index ifNil: [index := self size]! ! !HistoryIterator methodsFor: 'accessing' stamp: 'AlainPlantec 12/14/2010 19:06'! last ^ self recorder last! ! !HistoryIterator methodsFor: 'accessing' stamp: 'AlainPlantec 12/14/2010 18:46'! maxSize ^ maxSize ifNil: [maxSize := self defaultMaximumSize]! ! !HistoryIterator methodsFor: 'accessing' stamp: 'AlainPlantec 12/14/2010 18:54'! maxSize: anInteger maxSize := anInteger! ! !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: '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 12:54'! previous "previous item in history" ^ self hasPrevious ifTrue: [index := self index - 1. self current]! ! !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 14:37'! recorder ^ recorder ifNil: [recorder := UndoRedoGroup new]! ! !HistoryIterator methodsFor: 'accessing' stamp: 'AlainPlantec 12/14/2010 13:02'! reset self recorder reset. index := nil.! ! !HistoryIterator methodsFor: 'accessing' stamp: 'AlainPlantec 12/14/2010 13:00'! size ^ self recorder size! ! !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: 'adding' stamp: 'AlainPlantec 12/14/2010 12:54'! addRecord: anItem ^ self addItem: anItem ! ! !HistoryIterator methodsFor: 'adding' stamp: 'AlainPlantec 12/14/2010 18:51'! updateIndex self size <= self maxSize ifFalse: [self removeFirst]. index := self size. ! ! !HistoryIterator methodsFor: 'compatibility' stamp: 'AlainPlantec 12/14/2010 12:54'! closeRecordGroup ^ self closeGroup! ! !HistoryIterator methodsFor: 'compatibility' stamp: 'AlainPlantec 12/14/2010 12:54'! openRecordGroup ^ self openGroup! ! !HistoryIterator methodsFor: 'grouping' stamp: 'AlainPlantec 12/14/2010 14:33'! closeGroup self recorder closeGroup ! ! !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: 'grouping' stamp: 'AlainPlantec 12/14/2010 18:52'! openGroup self recorder openGroup. self updateIndex. ! ! !HistoryIterator methodsFor: 'removing' stamp: 'AlainPlantec 12/14/2010 19:58'! removeAt: anIndex self recorder removeAt: anIndex! ! !HistoryIterator methodsFor: 'removing' stamp: 'AlainPlantec 12/14/2010 18:51'! removeFirst self recorder removeFirst! ! !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: 'testing' stamp: 'AlainPlantec 12/14/2010 12:54'! hasPrevious "is there an item before current index" ^ self index > 0! ! !HistoryIterator methodsFor: 'testing' stamp: 'AlainPlantec 12/14/2010 12:54'! isPlugged ^ plugged ifNil: [plugged := true]! ! !HistoryIterator methodsFor: 'undo-undo' stamp: 'AlainPlantec 12/14/2010 18:31'! do ^ self redo! ! !HistoryIterator methodsFor: 'undo-undo' stamp: 'AlainPlantec 12/14/2010 22:27'! doAndAddRecord: anUndoRedoRecord | result | result := anUndoRedoRecord do. self addItem: anUndoRedoRecord. ^ result! ! !HistoryIterator methodsFor: 'undo-undo' stamp: 'AlainPlantec 12/14/2010 13:03'! redo self unplugWhile: [ self hasNext ifFalse: [^false]. self next redo]. ^ true! ! !HistoryIterator methodsFor: 'undo-undo' stamp: 'AlainPlantec 12/14/2010 22:27'! redo: doMessageSend undo: undoMessageSend self addItem: (UndoRedoRecord redo: doMessageSend undo: undoMessageSend)! ! !HistoryIterator methodsFor: 'undo-undo' stamp: 'AlainPlantec 12/14/2010 22:28'! redoArray: doArray undoArray: undoArray self addItem: (UndoRedoRecord redoArray: doArray undoArray: undoArray)! ! !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 12:54'! unplugWhile: aBlock | wasPlugged | wasPlugged := self isPlugged. plugged := false. aBlock ensure: [ plugged := wasPlugged ]! ! TestCase subclass: #HistoryIteratorTest instanceVariableNames: 'historyList' classVariableNames: '' poolDictionaries: '' category: 'Tests-SystemHistory'! !HistoryIteratorTest methodsFor: 'running' stamp: 'AlainPlantec 12/14/2010 23:38'! setUp historyList := HistoryIterator new.! ! !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: '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: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.! ! !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: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.! ! Object subclass: #HistoryLeaf instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-History'! !HistoryLeaf commentStamp: 'AlainPlantec 12/14/2010 23:06' prior: 0! 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: 'adding' stamp: 'AlainPlantec 12/13/2010 13:07'! addItem: anHistoryItem ^ false! ! !HistoryLeaf methodsFor: 'testing' stamp: 'AlainPlantec 12/13/2010 13:04'! isComposite ^ false! ! !HistoryLeaf methodsFor: 'testing' stamp: 'AlainPlantec 12/13/2010 11:54'! opened ^ false! ! HistoryLeaf subclass: #HistoryNode instanceVariableNames: 'history opened' classVariableNames: '' poolDictionaries: '' category: 'System-History'! !HistoryNode commentStamp: 'AlainPlantec 12/15/2010 00:04' prior: 0! 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: 'accessing' stamp: 'AlainPlantec 12/12/2010 19:01'! at: aPosition ^ self history at: aPosition! ! !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/13/2010 15:05'! current ^ self history isEmpty ifFalse: [self history last] ! ! !HistoryNode methodsFor: 'accessing' stamp: 'AlainPlantec 12/14/2010 19:08'! first ^ self history first! ! !HistoryNode methodsFor: 'accessing' stamp: 'AlainPlantec 12/13/2010 10:39'! groupClass ^ self class! ! !HistoryNode methodsFor: 'accessing' stamp: 'AlainPlantec 12/12/2010 18:37'! history ^ history ifNil: [history := OrderedCollection new] ! ! !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: '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: 'copying' stamp: 'AlainPlantec 12/14/2010 13:06'! copyFrom: start to: stop ^ self history copyFrom: start to: stop! ! !HistoryNode methodsFor: 'opening-closing' stamp: 'AlainPlantec 12/13/2010 11:53'! close opened := false! ! !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: 'opening-closing' stamp: 'AlainPlantec 12/13/2010 11:53'! open opened := true! ! !HistoryNode methodsFor: 'opening-closing' stamp: 'AlainPlantec 12/13/2010 13:07'! openGroup ^ self addItem: self groupClass new! ! !HistoryNode methodsFor: 'opening-closing' stamp: 'AlainPlantec 12/13/2010 22:00'! reset history := nil. 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: 'removing' stamp: 'AlainPlantec 12/14/2010 12:59'! removeLast: count self history removeLast: count! ! !HistoryNode methodsFor: 'testing' stamp: 'AlainPlantec 12/14/2010 19:04'! closed ^ self opened not! ! !HistoryNode methodsFor: 'testing' stamp: 'AlainPlantec 12/13/2010 13:04'! isComposite ^ true! ! !HistoryNode methodsFor: 'testing' stamp: 'AlainPlantec 12/13/2010 15:59'! isEmpty ^ self history isEmpty! ! !HistoryNode methodsFor: 'testing' stamp: 'AlainPlantec 12/13/2010 11:54'! opened ^ opened ifNil: [opened := true]! ! !HistoryNode methodsFor: 'private ' stamp: 'AlainPlantec 12/12/2010 19:06'! removeFirst self history removeFirst! ! TestCase subclass: #HistoryNodeTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-SystemHistory'! !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! ! !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: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'! 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: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 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 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. ! ! HierarchicalUrl subclass: #HttpUrl instanceVariableNames: 'realm' classVariableNames: 'Passwords' poolDictionaries: '' category: 'Network-Url'! !HttpUrl commentStamp: 'ls 6/15/2003 13:44' prior: 0! 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 instanceVariableNames: ''! !HttpUrl class methodsFor: 'constants' stamp: 'SeanDeNigris 1/30/2011 11:32'! schemeName ^ 'http'.! ! TestCase subclass: #HttpUrlTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetworkTests-Url'! !HttpUrlTest methodsFor: 'testing' stamp: 'MarcusDenker 4/16/2011 18:58'! testHttps self assert: 'https://encrypted.google.com' asUrl scheme = 'https'.! ! !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')! ! HttpUrl subclass: #HttpsUrl instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Network-Url'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! HttpsUrl class instanceVariableNames: ''! !HttpsUrl class methodsFor: 'constants' stamp: 'CamilloBruni 12/16/2011 11:17'! schemeName ^ 'https'.! ! ByteTextConverter subclass: #ISO885915TextConverter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Multilingual-TextConversion'! !ISO885915TextConverter commentStamp: '' prior: 0! 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 instanceVariableNames: ''! !ISO885915TextConverter class methodsFor: 'accessing' stamp: 'pmm 8/16/2010 10:30'! encodingNames ^ #('iso-8859-15') copy ! ! !ISO885915TextConverter class methodsFor: 'accessing' stamp: 'pmm 8/16/2010 10:30'! languageEnvironment ^Latin9Environment! ! !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 )! ! !ISO885915TextConverter class methodsFor: 'initialization' stamp: 'pmm 8/16/2010 10:58'! initialize self initializeTables! ! ByteTextConverter subclass: #ISO88592TextConverter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Multilingual-TextConversion'! !ISO88592TextConverter commentStamp: '' prior: 0! Text converter for ISO 8859-2. An international encoding used in Eastern Europe.! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ISO88592TextConverter class instanceVariableNames: ''! !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 )! ! !ISO88592TextConverter class methodsFor: 'accessing' stamp: 'michael.rueger 2/2/2009 18:48'! languageEnvironment ^Latin2Environment! ! !ISO88592TextConverter class methodsFor: 'initialization' stamp: 'SvenVanCaekenberghe 3/7/2012 21:46'! initialize self initializeTables! ! !ISO88592TextConverter class methodsFor: 'utilities' stamp: 'yo 1/18/2005 09:17'! encodingNames ^ #('iso-8859-2') copy ! ! ByteTextConverter subclass: #ISO88597TextConverter instanceVariableNames: '' classVariableNames: 'FromTable' poolDictionaries: '' category: 'Multilingual-TextConversion'! !ISO88597TextConverter commentStamp: '' prior: 0! Text converter for ISO 8859-7. An international encoding used for Greek.! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ISO88597TextConverter class instanceVariableNames: ''! !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 )! ! !ISO88597TextConverter class methodsFor: 'accessing' stamp: 'michael.rueger 2/2/2009 18:49'! languageEnvironment ^GreekEnvironment! ! !ISO88597TextConverter class methodsFor: 'initialization' stamp: 'SvenVanCaekenberghe 3/7/2012 21:46'! initialize self initializeTables! ! !ISO88597TextConverter class methodsFor: 'utilities' stamp: 'yo 2/10/2004 06:32'! encodingNames ^ #('iso-8859-7' 'greek-iso-8859-8bit') copy ! ! Object subclass: #ISOLanguageDefinition instanceVariableNames: 'iso3 iso2 iso3Alternate language' classVariableNames: 'ISO2Countries ISO2Table ISO3Countries ISO3Table' poolDictionaries: '' category: 'System-Localization'! !ISOLanguageDefinition methodsFor: 'accessing' stamp: 'mir 7/1/2004 18:20'! iso2 ^iso2 ifNil: [self iso3]! ! !ISOLanguageDefinition methodsFor: 'accessing' stamp: 'mir 7/1/2004 18:21'! iso3 ^iso3 ifNil: ['']! ! !ISOLanguageDefinition methodsFor: 'accessing' stamp: 'mir 6/30/2004 15:47'! iso3Alternate ^iso3Alternate ifNil: ['']! ! !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: 'initialize' stamp: 'mir 6/30/2004 15:54'! iso3: aString iso3 := aString ifEmpty: [nil] ifNotEmpty: [aString]! ! !ISOLanguageDefinition methodsFor: 'initialize' stamp: 'mir 6/30/2004 15:54'! iso3Alternate: aString iso3Alternate := aString ifEmpty: [nil] ifNotEmpty: [aString]! ! !ISOLanguageDefinition methodsFor: 'initialize' stamp: 'mir 8/15/2003 13:40'! language: aString language := aString! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ISOLanguageDefinition class instanceVariableNames: ''! !ISOLanguageDefinition class methodsFor: 'accessing' stamp: 'mir 7/1/2004 18:06'! iso2LanguageDefinition: aString ^self iso2LanguageTable at: aString! ! !ISOLanguageDefinition class methodsFor: 'accessing' stamp: 'mir 7/1/2004 18:06'! iso3LanguageDefinition: aString ^self iso3LanguageTable at: aString! ! !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: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 9/1/2005 14:14'! extraCountryDefinitions ^{ {'Kids'. 'KIDS'. 'KIDS'.}. }! ! !ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 7/15/2004 18:14'! extraISO3Definitions ^self readISOLanguagesFrom: 'jpk Japanese (Kids) ' readStream! ! !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 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:18'! iso2Countries "ISOLanguageDefinition iso2Countries" "ISO2Countries := nil. ISO3Countries := nil" ISO2Countries ifNil: [self initISOCountries]. ^ISO2Countries! ! !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! ! !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 9/1/2005 14:18'! iso3Countries "ISOLanguageDefinition iso3Countries" "ISO2Countries := nil. ISO3Countries := nil" ISO3Countries ifNil: [self initISOCountries]. ^ISO3Countries! ! !ISOLanguageDefinition class methodsFor: 'private' stamp: 'mir 7/21/2004 13:10'! iso3LanguageTable "ISOLanguageDefinition iso3LanguageTable" ^ISO3Table ifNil: [ISO3Table := self initISO3LanguageTable]! ! !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 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! ! TestCase subclass: #IVsAndClassVarNamesConflictTest instanceVariableNames: 'class className' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Classes'! !IVsAndClassVarNamesConflictTest methodsFor: 'setup' stamp: 'oscar.nierstrasz 10/18/2009 17:11'! setUp super setUp. className := #ClassForTestToBeDeleted.! ! !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: 'tests' stamp: 'Noury 10/26/2008 18:40'! testOneCanProceedWhenIntroducingCapitalizedInstanceVariables self shouldnt: [ [Object subclass: className instanceVariableNames: 'X Y' classVariableNames: '' poolDictionaries: '' category: self class category] on: Exception do: [:ex| ex resume] ] raise: Exception. self assert: (Smalltalk keys includes: className) ! ! !IVsAndClassVarNamesConflictTest methodsFor: 'tests' stamp: 'adrian_lienhard 3/7/2009 17:54'! testOneCanProceedWhenIntroducingClasseVariablesBeginingWithLowerCaseCharacters self shouldnt: [ [Object subclass: className instanceVariableNames: '' classVariableNames: 'a BVariableName' poolDictionaries: '' category: self class category] on: Exception do: [:ex| ex resume] ] raise: Exception. self assert: (Smalltalk keys includes: className) ! ! ListComposableModel subclass: #IconListModel instanceVariableNames: 'iconHolder' classVariableNames: '' poolDictionaries: '' category: 'Spec-Widgets'! !IconListModel commentStamp: '' prior: 0! An IconListModel is a spec model for icon list! !IconListModel methodsFor: 'initialization'! initialize "Initialization code for IconListModel" super initialize. iconHolder := [:item | nil ] asValueHolder.! ! !IconListModel methodsFor: 'morphic'! getIconFor: anItem ^ iconHolder contents cull: anItem cull: self! ! !IconListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 02:51'! icons "Return the block which takes an item as argument and returns the icon to display in the list" ^ iconHolder contents! ! !IconListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 02:50'! icons: aBlock "Set a block which takes an item as argument and returns the icon to display in the list" iconHolder contents: aBlock! ! !IconListModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/13/2012 02:51'! whenIconsChanged: aBlock iconHolder whenChangedDo: aBlock ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! IconListModel class instanceVariableNames: ''! !IconListModel class methodsFor: 'example' stamp: 'BenjaminVanRyseghem 7/10/2012 15:50'! example self new icons: [:e | UITheme current forwardIcon ]; items: (1 to: 10) asArray; openWithSpec! ! !IconListModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 2/8/2013 14:24'! defaultSpec ^ {#IconListSpec. #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). #setBalloonText:. { #model . #help}. #hResizing:. #spaceFill. #vResizing:. #spaceFill}! ! ListSpec subclass: #IconListSpec instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Spec-Core-Specs'! !IconListSpec commentStamp: '' prior: 0! An IconListSpec is a spec use to describe a list with icons! !IconListSpec methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/24/2012 03:15'! classSymbol ^ #IconList! ! SimpleButtonMorph subclass: #IconicButton instanceVariableNames: 'graphicalMorph' classVariableNames: 'DefaultGraphics' poolDictionaries: '' category: 'Morphic-Widgets'! !IconicButton commentStamp: '' prior: 0! A "Simple Button" in which the appearance is provided by a Form.! !IconicButton methodsFor: '*Nautilus'! graphicalMorph ^ graphicalMorph! ! !IconicButton methodsFor: '*Nautilus'! graphicalMorph: aMorph self addMorph: aMorph. aMorph lock.! ! !IconicButton methodsFor: '*Nautilus'! labelGraphic ^ graphicalMorph image! ! !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: '*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: '*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: '*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: '*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: '*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: '*Polymorph-Widgets-override' stamp: 'BenjaminVanRyseghem 4/12/2011 17:08'! extraBorder ^ 6! ! !IconicButton methodsFor: '*Polymorph-Widgets-override' stamp: 'BenjaminVanRyseghem 4/12/2011 17:08'! labelGraphic: aForm "Changed to look for any image morph rather than just a sketch." | oldLabel | graphicalMorph ifNotNil: [graphicalMorph delete]. graphicalMorph := ImageMorph new image: aForm. self extent: graphicalMorph extent + (self borderWidth + self extraBorder). graphicalMorph position: self center - (graphicalMorph extent // 2). self addMorph: graphicalMorph. graphicalMorph lock! ! !IconicButton methodsFor: 'accessing' stamp: 'ar 12/12/2001 01:38'! borderInset self borderStyle: (BorderStyle inset width: 2).! ! !IconicButton methodsFor: 'accessing' stamp: 'ar 12/12/2001 01:41'! borderRaised self borderStyle: (BorderStyle raised width: 2).! ! !IconicButton methodsFor: 'accessing' stamp: 'StephaneDucasse 5/17/2012 16:33'! defaultGraphics ^ DefaultGraphics ! ! !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: 'accessing' stamp: 'sw 11/29/1999 20:56'! shedSelvedge self extent: (self extent - (6@6))! ! !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: 'initialization' stamp: 'ar 12/12/2001 01:38'! borderNormal self borderStyle: (BorderStyle width: 2 color: Color transparent).! ! !IconicButton methodsFor: 'initialization' stamp: 'ar 12/17/2001 21:17'! borderThick self borderStyle: (BorderStyle width: 2 color: self raisedColor twiceDarker).! ! !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: 'initialization' stamp: 'sw 11/29/1999 20:52'! initialize super initialize. self useSquareCorners! ! !IconicButton methodsFor: 'initialization' stamp: 'StephaneDucasse 5/17/2012 16:36'! setDefaultLabel self labelGraphic: self class defaultGraphics! ! !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: '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: 'updating' stamp: 'BenjaminVanRyseghem 8/23/2011 14:31'! interactSelector ^ #interact! ! !IconicButton methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 8/23/2011 15:04'! update: aSelector aSelector = self interactSelector ifTrue: [ ^ self doButtonAction ]. super update: aSelector! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! IconicButton class instanceVariableNames: ''! !IconicButton class methodsFor: 'initialize' stamp: 'StephaneDucasse 5/17/2012 16:40'! defaultGraphics ^ DefaultGraphics ifNil: [ DefaultGraphics := (Form extent: 20 @ 1 depth: 8)].! ! !IconicButton class methodsFor: 'initialize' stamp: 'StephaneDucasse 5/17/2012 16:33'! initialize "self initialize" DefaultGraphics := self defaultGraphics! ! Object subclass: #IconicButtonStateHolder instanceVariableNames: 'target actionSelector arguments labelGraphic color extent helpText borderWidth' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon'! !IconicButtonStateHolder commentStamp: '' prior: 0! 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'! actionSelector ^ actionSelector! ! !IconicButtonStateHolder methodsFor: 'accessing'! actionSelector: anObject actionSelector := anObject! ! !IconicButtonStateHolder methodsFor: 'accessing'! arguments ^ arguments! ! !IconicButtonStateHolder methodsFor: 'accessing'! arguments: anObject arguments := anObject! ! !IconicButtonStateHolder methodsFor: 'accessing'! borderWidth ^ borderWidth! ! !IconicButtonStateHolder methodsFor: 'accessing'! borderWidth: anObject borderWidth := anObject! ! !IconicButtonStateHolder methodsFor: 'accessing'! color ^ color! ! !IconicButtonStateHolder methodsFor: 'accessing'! color: anObject color := anObject! ! !IconicButtonStateHolder methodsFor: 'accessing'! extent ^ extent! ! !IconicButtonStateHolder methodsFor: 'accessing'! extent: anObject extent := anObject! ! !IconicButtonStateHolder methodsFor: 'accessing'! helpText ^ helpText! ! !IconicButtonStateHolder methodsFor: 'accessing'! helpText: anObject helpText := anObject! ! !IconicButtonStateHolder methodsFor: 'accessing'! labelGraphic ^ labelGraphic! ! !IconicButtonStateHolder methodsFor: 'accessing'! labelGraphic: anObject labelGraphic := anObject! ! !IconicButtonStateHolder methodsFor: 'accessing'! target ^ target! ! !IconicButtonStateHolder methodsFor: 'accessing'! target: anObject target := anObject! ! !IconicButtonStateHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/14/2012 15:24'! asIcon | strong | strong := Array new: self arguments size. self arguments doWithIndex: [:e :i | strong at: i put: e ]. ^ IconicButton new target: self target; actionSelector: self actionSelector; arguments: strong; labelGraphic: self labelGraphic; color: self color; helpText: self helpText; extent: self extent; borderWidth: self borderWidth! ! !IconicButtonStateHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/14/2012 15:23'! asIconTargetting: newTarget ^self asIcon target: newTarget; yourself! ! !IconicButtonStateHolder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 9/14/2012 15:22'! forIcon: icon | weak | weak := WeakArray new: icon arguments size. icon arguments doWithIndex: [:e :i | weak at: i put: e ]. self target: icon target; actionSelector: icon actionSelector; arguments: weak; labelGraphic: icon labelGraphic; color: icon color; helpText: icon helpText; extent: icon extent; borderWidth: icon borderWidth! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! IconicButtonStateHolder class instanceVariableNames: ''! !IconicButtonStateHolder class methodsFor: 'instance creation'! forIcon: icon ^ self new forIcon: icon; yourself ! ! !IconicButtonStateHolder class methodsFor: 'instance creation'! forNautilus: icon ^ self new forIcon: icon; target: nil; yourself ! ! RectangleMorph subclass: #IconicListItem instanceVariableNames: 'originalObject' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !IconicListItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/7/2011 15:19'! originalObject ^ originalObject! ! !IconicListItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/7/2011 15:19'! originalObject: anObject originalObject := anObject! ! BorderedMorph subclass: #IdentifierChooserMorph instanceVariableNames: 'requestor labels choiceMenus chooseBlock maxLines choicesMorph scrollPaneWidth baseColor' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !IdentifierChooserMorph commentStamp: 'AlainPlantec 11/29/2010 10:50' prior: 0! 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: 'accessing' stamp: 'AlainPlantec 11/26/2010 09:33'! allowedArea ^ self class allowedArea! ! !IdentifierChooserMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/29/2010 09:22'! baseColor ^ baseColor ifNil: [baseColor := self defaultBaseColor]! ! !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 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/21/2010 13:41'! choiceMenus "Answer the value of choiceMenus" ^ choiceMenus! ! !IdentifierChooserMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/21/2010 13:41'! choiceMenus: anObject "Set the value of choiceMenus" choiceMenus := anObject! ! !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/21/2010 13:41'! labels "Answer the value of labels" ^ labels! ! !IdentifierChooserMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/29/2010 10:55'! labels: aCollectionOfString "Set the value of labels" labels := aCollectionOfString! ! !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/26/2010 09:01'! listMorph "Answer the height for the list." ^ choicesMorph! ! !IdentifierChooserMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/21/2010 16:31'! maxLines ^ maxLines ifNil: [maxLines := 6]! ! !IdentifierChooserMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/21/2010 16:32'! maxLines: anInteger maxLines := anInteger! ! !IdentifierChooserMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/26/2010 16:54'! requestor ^ requestor! ! !IdentifierChooserMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/26/2010 16:32'! requestor: aTextMorph requestor := aTextMorph! ! !IdentifierChooserMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/21/2010 13:41'! theme ^ UITheme current! ! !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/29/2010 10:53'! activate: evt "Backstop." ! ! !IdentifierChooserMorph methodsFor: 'event handling' stamp: 'AlainPlantec 11/21/2010 13:41'! deleteIfPopUp: evt "For compatibility with MenuMorph."! ! !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: '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: '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'! selectFirstItem "Select the first item in the embedded menus" self choiceMenus first selectItem: self choiceMenuItems first event: nil. self activeHand newKeyboardFocus: self.! ! !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: '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: '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: '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 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: '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: 'ui-building' stamp: 'AlainPlantec 11/29/2010 09:27'! initialize super initialize. self borderWidth: 1. self layoutInset: 0@0. self changeTableLayout. self hResizing: #shrinkWrap. self vResizing: #shrinkWrap. self color: self defaultBaseColor. ! ! !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/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/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: 'ui-building' stamp: 'AlainPlantec 11/21/2010 22:04'! newMenu ^ self theme newEmbeddedMenuIn: self for: self! ! !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: '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: 'ui-building' stamp: 'AlainPlantec 11/21/2010 13:41'! newScrollPaneFor: aMorph ^ self theme newScrollPaneIn: self for: aMorph! ! !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: 'ui-building' stamp: 'AlainPlantec 11/27/2010 12:41'! oneMenuOfWidth: anInteger self maxLines: 999999999. scrollPaneWidth := anInteger. ! ! !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: '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 class instanceVariableNames: ''! !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]. ! ! Bag subclass: #IdentityBag instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Unordered'! !IdentityBag commentStamp: '' prior: 0! 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 instanceVariableNames: ''! !IdentityBag class methodsFor: 'instance creation' stamp: 'nk 3/17/2001 09:53'! contentsClass ^IdentityDictionary! ! BagTest subclass: #IdentityBagTest instanceVariableNames: 'equalNotIdenticalElement elementToCopy identityBagNonEmptyNoDuplicate5Elements elementAlreadyIncluded identityBagWithoutElement' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Unordered'! !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: '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: '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: '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: '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)! ! Dictionary subclass: #IdentityDictionary instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Unordered'! !IdentityDictionary commentStamp: 'ls 06/15/02 22:35' prior: 0! Like a Dictionary, except that keys are compared with #== instead of #= . See the comment of IdentitySet for more information.! !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: '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: '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! ! DictionaryTest subclass: #IdentityDictionaryTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Unordered'! !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 instanceVariableNames: ''! !IdentityDictionaryTest class methodsFor: 'building suites' stamp: 'cyrille.delaunay 6/29/2009 11:41'! shouldInheritSelectors ^true! ! MorphTreeListManager subclass: #IdentityMorphTreeListManager instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Nautilus-MorphTreeWidget-Extension'! !IdentityMorphTreeListManager commentStamp: '' prior: 0! An IdentityMorphTreeListManager is a MorphTreeListManager which always check for identity between items ! !IdentityMorphTreeListManager methodsFor: 'accessing'! nodeMorphsWithAllNodeItems: aNodeItemList ^ self allNodeMorphs select: [:m | aNodeItemList identityIncludes: m complexContents withoutListWrapper]! ! MorphTreeMorph subclass: #IdentityMorphTreeMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Nautilus-MorphTreeWidget-Extension'! !IdentityMorphTreeMorph commentStamp: '' prior: 0! An IdentityMorphTreeMorph is a MorphTreeMorph which always check for identity between items ! !IdentityMorphTreeMorph methodsFor: 'accessing'! listManager: aManager listManager := aManager! ! !IdentityMorphTreeMorph methodsFor: 'expanding-collapsing'! 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]! ! !IdentityMorphTreeMorph methodsFor: 'expanding-collapsing'! notExpandedFormForMorph: aMorph ^ ((self selectedMorphList identityIncludes: aMorph) and: [self theme selectionColor luminance < 0.6]) ifTrue: [self theme whiteTreeUnexpandedForm] ifFalse: [self theme treeUnexpandedForm]! ! Set subclass: #IdentitySet instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Unordered'! !IdentitySet commentStamp: 'sw 1/14/2003 22:35' prior: 0! 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: 'converting' stamp: 'ar 9/22/2000 10:13'! asIdentitySet ^self! ! !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: '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! ! SetTest subclass: #IdentitySetTest instanceVariableNames: 'floatCollection' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Unordered'! !IdentitySetTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 6/29/2009 10:58'! classToBeTested ^ IdentitySet! ! !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 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 class instanceVariableNames: ''! !IdentitySetTest class methodsFor: 'building suites' stamp: 'cyrille.delaunay 6/29/2009 10:51'! shouldInheritSelectors ^true! ! DisplayTransform subclass: #IdentityTransform instanceVariableNames: '' classVariableNames: 'Default' poolDictionaries: '' category: 'Graphics-Transformations'! !IdentityTransform methodsFor: 'accessing' stamp: 'di 9/29/2000 09:04'! angle ^ 0.0! ! !IdentityTransform methodsFor: 'accessing' stamp: 'ar 9/11/2000 21:18'! inverseTransformation "Return the inverse transformation of the receiver" ^self! ! !IdentityTransform methodsFor: 'accessing' stamp: 'ar 4/19/2001 06:01'! offset ^0@0! ! !IdentityTransform methodsFor: 'composing' stamp: 'ar 9/11/2000 21:27'! composedWith: aTransform ^aTransform! ! !IdentityTransform methodsFor: 'composing' stamp: 'ar 9/11/2000 21:19'! composedWithGlobal: aTransformation ^aTransformation! ! !IdentityTransform methodsFor: 'composing' stamp: 'ar 9/11/2000 21:19'! composedWithLocal: aTransformation ^aTransformation! ! !IdentityTransform methodsFor: 'converting' stamp: 'ar 9/11/2000 21:21'! asMatrixTransform2x3 "Represent the receiver as a 2x3 matrix transformation" ^MatrixTransform2x3 identity! ! !IdentityTransform methodsFor: 'initialize' stamp: 'ar 9/11/2000 21:18'! setIdentity "I *am* the identity transform" ^self! ! !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: 'testing' stamp: 'ar 9/11/2000 21:19'! isPureTranslation "Return true if the receiver specifies no rotation or scaling." ^true! ! !IdentityTransform methodsFor: 'transforming points' stamp: 'ar 9/11/2000 21:19'! globalPointToLocal: aPoint "Transform aPoint from global coordinates into local coordinates" ^aPoint! ! !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 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'! localPointToGlobal: aPoint "Transform aPoint from local coordinates into global coordinates" ^aPoint! ! !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: 'transforming rects' stamp: 'ar 9/11/2000 21:20'! globalBoundsToLocal: aRectangle "Transform aRectangle from global coordinates into local coordinates" ^aRectangle! ! !IdentityTransform methodsFor: 'transforming rects' stamp: 'ar 9/11/2000 21:20'! localBoundsToGlobal: aRectangle "Transform aRectangle from local coordinates into global coordinates" ^aRectangle! ! !IdentityTransform methodsFor: 'transforming rects' stamp: 'ar 9/11/2000 21:21'! sourceQuadFor: aRectangle ^ aRectangle innerCorners! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! IdentityTransform class instanceVariableNames: ''! !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! ! TestCase subclass: #IfNotNilTests instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CompilerTests'! !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: '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! ! !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: 'GabrielOmarCotelli 5/25/2010 21:22'! testIfNotNil0Arg self assert: (5 ifNotNil: [ #foo ]) = #foo. self assert: (nil ifNotNil: [ #foo ]) isNil! ! !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: '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: '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: '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: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: '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! ! URLPlugin subclass: #IgorsPlugin instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Plugin'! !IgorsPlugin commentStamp: '' prior: 0! 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 instanceVariableNames: ''! !IgorsPlugin class methodsFor: 'as yet unclassified' stamp: 'BenjaminVanRyseghem 2/17/2012 16:39'! description ^ 'Display the information of the selected class/method'! ! FileSystemError subclass: #IllegalName instanceVariableNames: 'name' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Core-Kernel'! !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 instanceVariableNames: ''! !IllegalName class methodsFor: 'instance creation' stamp: 'DamienPollet 2/28/2011 17:04'! name: aName ^ self basicNew initializeWithName: aName! ! !IllegalName class methodsFor: 'instance creation' stamp: 'DamienPollet 2/28/2011 17:03'! signalWith: aName ^ (self name: aName) signal! ! Exception subclass: #IllegalResumeAttempt instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Exceptions'! !IllegalResumeAttempt commentStamp: '' prior: 0! 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: 'ajh 2/1/2003 00:57'! isResumable ^ false! ! !IllegalResumeAttempt methodsFor: 'comment' stamp: 'tfei 6/2/1999 14:59'! readMe "Never handle this exception!!"! ! Error subclass: #IllegalURIException instanceVariableNames: 'uriString' classVariableNames: '' poolDictionaries: '' category: 'Network-URI'! !IllegalURIException methodsFor: 'accessing' stamp: 'mir 2/20/2002 17:21'! uriString ^uriString! ! !IllegalURIException methodsFor: 'accessing' stamp: 'mir 2/20/2002 17:20'! uriString: aString uriString := aString! ! Object subclass: #ImageCleaner instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tools-ImageCleaner'! !ImageCleaner methodsFor: 'api' stamp: 'EstebanLorenzano 2/19/2013 16:00'! cleanUpForProduction "self new cleanUpForProduction" "trim MC ancestory information" MCVersionInfo allInstances do: [ :each | each instVarNamed: 'ancestors' put: nil ]. "delete logo" PolymorphSystemSettings showDesktopLogo: false. "unload packages" self classesForCleanUpInProduction do: [ :eachPattern | (Smalltalk allClassesAndTraits select: [ :each | eachPattern match: each name ]) do: [ :each | each removeFromSystem: true ] ]. self packagesForCleanUpInProduction do: [ :each | (MCPackage named: each) unload ]. Smalltalk globals at: #SUnitUnloader ifPresent:[ :unloader | unloader new unloadAll ]. (MCPackage named: 'HudsonBuildTools20') unload. (MCPackage named: 'Announcements-Help') unload. (MCPackage named: 'Regex-Help') unload. (MCPackage named: 'Deprecated20') unload. (MCPackage named: 'ScriptLoader20') unload. World resetWorldMenu. self cleanUpForRelease. ! ! !ImageCleaner methodsFor: 'api' stamp: 'EstebanLorenzano 2/19/2013 16:24'! cleanUpForRelease "self new cleanUpForRelease" Author fullName: 'Mr.Cleaner'. self cleanUpMethods. ExternalDropHandler resetRegisteredHandlers. 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. Nautilus cleanUpForProduction. Author reset! ! !ImageCleaner methodsFor: 'cleaning' stamp: 'MarcusDenker 11/16/2012 16:30'! classesForCleanUpInProduction "A list of classes who will be unloaded when going to production. WARNING, ORDER CAN BE IMPORTANT" ^#( "Configurations" 'ConfigurationOf*' "Manifest & Critics Browser" 'Manifest*') ! ! !ImageCleaner methodsFor: 'cleaning' stamp: 'MarcusDenker 12/21/2012 12:01'! 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 ]. ExternalDropHandler initialize. ProcessBrowser initialize. Smalltalk garbageCollect. Delay startTimerEventLoop! ! !ImageCleaner methodsFor: 'cleaning' stamp: 'MarcusDenker 2/19/2013 15:05'! fixObsoleteReferences "self new fixObsoleteReferences" CompiledMethod allInstances do: [ :method | | obsoleteBindings | obsoleteBindings := method literals select: [ :literal | literal isVariableBinding and: [ literal value isBehavior and: [ literal value isObsolete ]] ]. obsoleteBindings do: [ :binding | | realClass obsName realName | obsName := binding value name. Transcript show: obsName; cr. realName := obsName copyReplaceAll: 'AnObsolete' with: ''. realClass := Smalltalk globals at: realName asSymbol ifAbsent: [ UndefinedObject ]. binding key: binding key value: realClass ] ]. Behavior flushObsoleteSubclasses. Smalltalk garbageCollect.! ! !ImageCleaner methodsFor: 'cleaning' stamp: 'EstebanLorenzano 2/19/2013 14:13'! 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' "CI" 'CI-Core-SliceSubmitter' 'CI-Loader' 'CI-Core') ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ImageCleaner class instanceVariableNames: ''! !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! ! OrientedFillStyle subclass: #ImageFillStyle instanceVariableNames: 'form extent offset' classVariableNames: '' poolDictionaries: '' category: 'Balloon-Fills'! !ImageFillStyle commentStamp: 'gvc 9/23/2008 11:55' prior: 0! Simple fillstyle that draws a (potentially translucent) form at the specified origin. Direction and normal are unused.! !ImageFillStyle methodsFor: 'accessing' stamp: 'gvc 10/3/2008 11:57'! extent "Answer the value of extent" ^ extent! ! !ImageFillStyle methodsFor: 'accessing' stamp: 'gvc 10/3/2008 11:57'! extent: anObject "Set the value of extent" extent := anObject! ! !ImageFillStyle methodsFor: 'accessing' stamp: 'gvc 3/26/2008 19:18'! form "Answer the value of form" ^ form! ! !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: 'accessing' stamp: 'gvc 1/28/2009 17:40'! offset "Answer the value of offset" ^ offset! ! !ImageFillStyle methodsFor: 'accessing' stamp: 'gvc 1/28/2009 17:40'! offset: anObject "Set the value of offset" offset := anObject! ! !ImageFillStyle methodsFor: 'as yet unclassified' stamp: 'gvc 12/8/2008 18:54'! = anOrientedFillStyle "Answer whether equal." ^super = anOrientedFillStyle and: [self form = anOrientedFillStyle form]! ! !ImageFillStyle methodsFor: 'as yet unclassified' stamp: 'gvc 3/2/2010 17:16'! asColor "Answer transparent, no other reasonable interpretation." ^Color transparent! ! !ImageFillStyle methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'gvc 12/8/2008 18:53'! hash "Hash is implemented because #= is implemented." ^super hash bitXor: self form hash! ! !ImageFillStyle methodsFor: 'initialize-release' stamp: 'gvc 1/28/2009 17:40'! initialize "Initialize the receiver." super initialize. self origin: 0@0; offset: 0@0! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ImageFillStyle class instanceVariableNames: ''! !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! ! Morph subclass: #ImageMorph uses: TAbleToRotate instanceVariableNames: 'image' classVariableNames: 'DefaultForm' poolDictionaries: '' category: 'Morphic-Basic'! !ImageMorph commentStamp: 'efc 3/7/2003 17:48' prior: 0! 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: '*NautilusCommon' stamp: 'BenjaminVanRyseghem 1/21/2012 21:36'! imageExport ^ self image bits asArray! ! !ImageMorph methodsFor: '*Polymorph-Widgets' 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: '*Polymorph-Widgets' 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: '*Polymorph-Widgets' stamp: 'StephaneDucasse 5/28/2011 13:40'! 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: '*Polymorph-Widgets' stamp: 'gvc 4/18/2007 11:52'! 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: '*Polymorph-Widgets' stamp: 'StephaneDucasse 10/12/2010 13:02'! image: anImage "Fixed to take account of border width. Use raw image, only change depth 1 forms to ColorForm with transparency if #color: is sent." image := anImage. super extent: (2 * self borderWidth) asPoint + image extent. self changed! ! !ImageMorph methodsFor: 'accessing' stamp: 'ar 12/12/2001 01:11'! borderWidth: bw | newExtent | newExtent := 2 * bw + image extent. bounds extent = newExtent ifFalse:[super extent: newExtent]. super borderWidth: bw! ! !ImageMorph methodsFor: 'accessing'! form "For compatability with SketchMorph." ^ image ! ! !ImageMorph methodsFor: 'accessing' stamp: 'jm 9/27/97 20:16'! image ^ image ! ! !ImageMorph methodsFor: 'accessing' stamp: 'dgd 2/16/2003 20:01'! isOpaque "Return true if the receiver is marked as being completely opaque" ^ self valueOfProperty: #isOpaque ifAbsent: [false]! ! !ImageMorph methodsFor: 'accessing' stamp: 'ar 11/7/2000 14:57'! 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: 'accessing' stamp: 'FernandoOlivero 4/12/2011 09:46'! setNewImageFrom: formOrNil "Change the receiver's image to be one derived from the supplied form. If nil is supplied, clobber any existing image in the receiver, and in its place put a default graphic, either the one known to the receiver as its default value, else a squeaky mouse" | defaultImage | formOrNil ifNotNil: [^ self image: formOrNil]. defaultImage := self theme squeakyMouseIcon. self image: defaultImage ! ! !ImageMorph methodsFor: 'accessing' stamp: 'wiz 4/7/2004 15:10'! withSnapshotBorder self borderStyle: ((ComplexBorder style: #complexFramed) color: (Color r: 0.613 g: 1.0 b: 0.516); width: 1; yourself)! ! !ImageMorph methodsFor: 'as yet unclassified' stamp: 'StephaneDucasse 5/28/2011 13:40'! wantsRecolorHandle ^ image notNil and: [image depth = 1]! ! !ImageMorph methodsFor: 'caching'! releaseCachedState super releaseCachedState. image hibernate. ! ! !ImageMorph methodsFor: 'geometry'! extent: aPoint "Do nothing; my extent is determined by my image Form." ! ! !ImageMorph methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:36'! defaultImage "Answer the default image for the receiver." ^ DefaultForm! ! !ImageMorph methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 09:36'! initialize super initialize. self image: self defaultImage. ! ! !ImageMorph methodsFor: 'menu' stamp: 'ar 11/7/2000 14:57'! changeOpacity self isOpaque: self isOpaque not! ! !ImageMorph methodsFor: 'menu' stamp: 'StephaneDucasse 4/22/2012 16:48'! opacityString ^ (self isOpaque) -> 'opaque' translated! ! !ImageMorph methodsFor: 'menu commands'! grabFromScreen self image: Form fromUser. ! ! !ImageMorph methodsFor: 'menu commands' stamp: 'DamienCassou 9/29/2009 12:58'! readFromFile | fileName | fileName := UIManager default request: 'Please enter the image file name' translated initialAnswer: 'fileName'. fileName isEmptyOrNil ifTrue: [^ self]. self image: (Form fromFileNamed: fileName). ! ! !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: 'other' stamp: 'sw 12/17/1998 12:11'! newForm: aForm self image: aForm! ! !ImageMorph methodsFor: 't-rotating'! forwardDirection "Return the receiver's forward direction (in eToy terms)" ^self valueOfProperty: #forwardDirection ifAbsent:[0.0]! ! !ImageMorph methodsFor: 't-rotating'! forwardDirection: newDirection "Set the receiver's forward direction (in eToy terms)" self setProperty: #forwardDirection toValue: newDirection.! ! !ImageMorph methodsFor: 't-rotating'! heading "Return the receiver's heading" ^ self owner ifNil: [self forwardDirection] ifNotNil: [self forwardDirection + self owner degreesOfFlex]! ! !ImageMorph methodsFor: 't-rotating'! 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'! rotationDegrees "Default implementation." ^ 0.0 ! ! !ImageMorph methodsFor: 't-rotating'! rotationDegrees: degrees "redefined in all morphs which are using myself"! ! !ImageMorph methodsFor: 't-rotating'! setDirectionFrom: aPoint | delta degrees | delta := (self transformFromWorld globalPointToLocal: aPoint) - self referencePosition. degrees := delta degrees + 90.0. self forwardDirection: (degrees \\ 360) rounded. ! ! !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: 'testing' stamp: 'WilliamSix 1/14/2013 19:44'! shouldFlex ^ true.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ImageMorph class uses: TAbleToRotate classTrait instanceVariableNames: ''! !ImageMorph class methodsFor: 'accessing' stamp: 'ar 6/25/1999 11:59'! defaultForm ^DefaultForm! ! !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: 'StephaneDucasse 3/3/2010 15:16'! fromStream: aStream ^self withForm: (ImageReadWriter formFromStream: aStream)! ! !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: 'sw 10/23/2000 18:21'! fromString: aString font: aFont "Create a new ImageMorph showing the given string in the given font" ^ self new image: (StringMorph contents: aString font: aFont) imageForm! ! !ImageMorph class methodsFor: 'instance creation' stamp: 'StephaneDucasse 3/3/2010 15:13'! withForm: aForm ^ self new image: aForm ; yourself! ! Morph subclass: #ImagePreviewMorph instanceVariableNames: 'imageMorph textMorph defaultImageForm' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !ImagePreviewMorph commentStamp: 'gvc 5/18/2007 12:51' prior: 0! 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 "Answer the value of imageMorph" ^ imageMorph! ! !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'! 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 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 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 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: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: 'as yet unclassified' stamp: 'gvc 10/9/2006 14:34'! newTextMorph "Answer a new text morph." ^StringMorph contents: ''! ! Object subclass: #ImageReadWriter instanceVariableNames: 'stream' classVariableNames: 'ImageNotStoredSignal MagicNumberErrorSignal' poolDictionaries: '' category: 'Graphics-Files'! !ImageReadWriter commentStamp: '' prior: 0! 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: 'accessing'! nextImage "Dencoding an image on stream and answer the image." ^self subclassResponsibility! ! !ImageReadWriter methodsFor: 'accessing'! nextPutImage: anImage "Encoding anImage on stream." ^self subclassResponsibility! ! !ImageReadWriter methodsFor: 'stream access'! atEnd ^stream atEnd! ! !ImageReadWriter methodsFor: 'stream access' stamp: 'sd 1/30/2004 15:18'! close stream close! ! !ImageReadWriter methodsFor: 'stream access'! contents ^stream contents! ! !ImageReadWriter methodsFor: 'stream access'! cr ^stream nextPut: Character cr asInteger! ! !ImageReadWriter methodsFor: 'stream access'! lf "PPM and PBM are used LF as CR." ^stream nextPut: Character lf asInteger! ! !ImageReadWriter methodsFor: 'stream access'! next ^stream next! ! !ImageReadWriter methodsFor: 'stream access'! next: size ^stream next: size! ! !ImageReadWriter methodsFor: 'stream access'! 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'! 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'! nextPut: aByte ^stream nextPut: aByte! ! !ImageReadWriter methodsFor: 'stream access'! nextPutAll: aByteArray ^stream nextPutAll: aByteArray! ! !ImageReadWriter methodsFor: 'stream access'! nextWord "Read a 16-bit quantity from the input stream." ^(stream next bitShift: 8) + stream next! ! !ImageReadWriter methodsFor: 'stream access'! 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 methodsFor: 'stream access' stamp: 'tao 10/23/97 18:00'! peekFor: aValue ^stream peekFor: aValue! ! !ImageReadWriter methodsFor: 'stream access'! position ^stream position! ! !ImageReadWriter methodsFor: 'stream access'! position: anInteger ^stream position: anInteger! ! !ImageReadWriter methodsFor: 'stream access'! size ^stream size! ! !ImageReadWriter methodsFor: 'stream access'! skip: anInteger ^stream skip: anInteger! ! !ImageReadWriter methodsFor: 'stream access'! space ^stream nextPut: Character space asInteger! ! !ImageReadWriter methodsFor: 'stream access'! tab ^stream nextPut: Character tab asInteger! ! !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: '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: '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: '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: '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 class instanceVariableNames: ''! !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: '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: '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 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! ! !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: '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: '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'! on: aStream "Answer an instance of the receiver for encoding and/or decoding images on the given." ^ self new on: aStream ! ! Notification subclass: #InMidstOfFileinNotification instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Exceptions'! !InMidstOfFileinNotification commentStamp: '' prior: 0! 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: 'as yet unclassified' stamp: 'RAA 5/28/2001 17:07'! defaultAction self resume: false! ! MorphicModel subclass: #IncrementalSliderMorph instanceVariableNames: 'sliderMorph getValueSelector setValueSelector getEnabledSelector' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !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: '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/10/2009 13:37'! getEnabledSelector "Answer the value of getEnabledSelector" ^ getEnabledSelector! ! !IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/10/2009 13:37'! getEnabledSelector: aSymbol "Set the value of getEnabledSelector" getEnabledSelector := aSymbol. self updateEnabled! ! !IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2009 13:57'! getValueSelector "Answer the value of getValueSelector" ^ getValueSelector! ! !IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2009 13:57'! getValueSelector: anObject "Set the value of getValueSelector" getValueSelector := anObject! ! !IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2009 14:31'! max "Answer the max value." ^(self sliderMorph ifNil: [^0]) max! ! !IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2009 14:55'! max: aNumber "Set the max value." (self sliderMorph ifNil: [^self]) max: 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/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'! quantum "Answer the quantum value." ^(self sliderMorph ifNil: [^0]) quantum! ! !IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2009 14:55'! quantum: aNumber "Set the quantum value." (self sliderMorph ifNil: [^self]) quantum: aNumber! ! !IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2009 13:57'! setValueSelector "Answer the value of setValueSelector" ^ setValueSelector! ! !IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2009 13:57'! setValueSelector: anObject "Set the value of setValueSelector" setValueSelector := anObject! ! !IncrementalSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/2/2009 14:18'! sliderMorph "Answer the value of sliderMorph" ^ sliderMorph! ! !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/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: '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: '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 14:56'! decrement "Decrement the value." self value: self value - self quantum! ! !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/2/2009 14:56'! increment "Increment the value." self value: self value + self quantum! ! !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: '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: '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: 'as yet unclassified' stamp: 'gvc 9/2/2009 14:50'! 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: '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 14:35'! notAtMin "Answer whether the value is not at the minimum," ^self value > self min! ! !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: '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/8/2009 13:26'! updateEnabled "Update the enablement state." self model ifNotNil: [ self getEnabledSelector ifNotNil: [ self enabled: (self model perform: self getEnabledSelector)]]! ! !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: '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: '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: 'initialize-release' 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: '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: '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: '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 class instanceVariableNames: ''! !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! ! StringMorph subclass: #IndentingListItemMorph instanceVariableNames: 'indentLevel isExpanded complexContents firstChild container nextSibling icon' classVariableNames: '' poolDictionaries: '' category: 'Tools-Explorer'! !IndentingListItemMorph commentStamp: 'AlainPlantec 1/7/2010 22:16' prior: 0! 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: '*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: '*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: '*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: '*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: '*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: '*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: '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: '*Polymorph-Widgets' stamp: 'gvc 9/5/2007 15:07'! theme "Answer the ui theme that provides controls. Done directly here to avoid performance hit of looking up in window." ^UITheme current! ! !IndentingListItemMorph methodsFor: 'accessing' stamp: 'RAA 7/21/2000 11:00'! balloonText ^complexContents balloonText ifNil: [super balloonText]! ! !IndentingListItemMorph methodsFor: 'accessing' stamp: 'RAA 3/31/1999 17:44'! canExpand ^complexContents hasContents! ! !IndentingListItemMorph methodsFor: 'accessing' stamp: 'panda 4/28/2000 15:30'! children | children | children := OrderedCollection new. self childrenDo: [:each | children add: each]. ^children! ! !IndentingListItemMorph methodsFor: 'accessing' stamp: 'RAA 8/2/1999 16:48'! firstChild ^firstChild! ! !IndentingListItemMorph methodsFor: 'accessing' stamp: 'dgd 9/25/2004 22:25'! hasIcon "Answer whether the receiver has an icon." ^ icon notNil! ! !IndentingListItemMorph methodsFor: 'accessing' stamp: 'dgd 9/25/2004 22:27'! icon "answer the receiver's icon" ^ icon! ! !IndentingListItemMorph methodsFor: 'accessing' stamp: 'RAA 7/30/2000 19:15'! indentLevel ^indentLevel! ! !IndentingListItemMorph methodsFor: 'accessing' stamp: 'RAA 7/31/1998 00:30'! isExpanded ^isExpanded! ! !IndentingListItemMorph methodsFor: 'accessing' stamp: 'RAA 7/31/1998 00:48'! isExpanded: aBoolean isExpanded := aBoolean! ! !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: 'accessing' stamp: 'nk 3/8/2004 09:15'! isSoleItem ^self isFirstItem and: [ owner submorphs size = 1 ]! ! !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: '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: 'accessing' stamp: 'RAA 7/11/1998 12:15'! nextSibling ^nextSibling! ! !IndentingListItemMorph methodsFor: 'accessing' stamp: 'RAA 8/1/1998 01:05'! nextSibling: anotherMorph nextSibling := anotherMorph! ! !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: 'action' stamp: 'gvc 4/25/2007 19:42'! toggleRectangle | h | h := bounds height. ^(bounds left + (13 * indentLevel)) @ bounds top extent: 9@h! ! !IndentingListItemMorph methodsFor: 'converting' stamp: 'RAA 3/31/1999 12:13'! withoutListWrapper ^complexContents withoutListWrapper! ! !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: '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: '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: '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: '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: '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: 'drawing' stamp: 'RAA 8/3/1999 09:46'! unhighlight complexContents highlightingColor ifNotNil: [self color: Color black]. self changed. ! ! !IndentingListItemMorph methodsFor: 'enumeration' stamp: 'panda 4/28/2000 15:29'! childrenDo: aBlock firstChild ifNotNil: [ firstChild withSiblingsDo: [ :aNode | aBlock value: aNode]. ]! ! !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: '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: 'initialization' stamp: 'dgd 2/14/2003 20:42'! initialize "initialize the state of the receiver" super initialize. "" indentLevel := 0. isExpanded := false! ! !IndentingListItemMorph methodsFor: 'mouse events' stamp: 'ar 3/17/2001 17:32'! inToggleArea: aPoint ^self toggleRectangle containsPoint: aPoint! ! !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:44'! findExactPathMatchIn: anArray self withSiblingsDo: [:each | (each complexContents asString = anArray first or: [anArray first isNil]) ifTrue: [^ each]]. ^ nil! ! !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: 'private' stamp: 'CarloTeixeira 7/2/2010 23:46'! findSimilarPathMatchIn: anArray self withSiblingsDo: [:each | (each complexContents asString sameAs: anArray first) ifTrue: [^ each]]. ^ nil! ! !IndentingListItemMorph methodsFor: 'private' stamp: 'nk 2/19/2004 18:29'! hasToggle ^ complexContents hasContents! ! !IndentingListItemMorph methodsFor: 'private' stamp: 'nk 12/5/2002 15:16'! toggleBounds ^self toggleRectangle! ! !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: '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-container protocol' stamp: 'RAA 7/11/1998 14:34'! complexContents ^complexContents! ! !IndentingListItemMorph methodsFor: 'private-container protocol' stamp: 'RAA 8/3/1999 09:47'! highlight complexContents highlightingColor ifNotNil: [self color: complexContents highlightingColor]. self changed. ! ! !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: '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: 'private-container protocol' stamp: 'RAA 4/2/1999 18:02'! recursiveDelete firstChild ifNotNil: [ firstChild withSiblingsDo: [ :aNode | aNode recursiveDelete]. ]. self delete ! ! !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: 'MarcusDenker 1/23/2011 09:19'! toggleExpandedState isExpanded := isExpanded not. self refreshExpandedState.! ! Object subclass: #InexactFloatPrintPolicy instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Numbers'! !InexactFloatPrintPolicy commentStamp: '' prior: 0! 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 ! ! DisplayObject subclass: #InfiniteForm instanceVariableNames: 'patternForm' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Display Objects'! !InfiniteForm commentStamp: '' prior: 0! I represent a Form obtained by replicating a pattern form indefinitely in all directions.! !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 methodsFor: 'accessing' stamp: 'mjg 7/9/2001 14:12'! asColor ^ patternForm dominantColor! ! !InfiniteForm methodsFor: 'accessing'! asForm ^ patternForm! ! !InfiniteForm methodsFor: 'accessing' stamp: 'di 9/2/97 20:21'! dominantColor ^ patternForm dominantColor! ! !InfiniteForm methodsFor: 'accessing'! offset "Refer to the comment in DisplayObject|offset." ^0 @ 0! ! !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: 'display box access'! computeBoundingBox "Refer to the comment in DisplayObject|computeBoundingBox." ^0 @ 0 corner: SmallInteger maxVal @ SmallInteger maxVal! ! !InfiniteForm methodsFor: 'displaying' stamp: 'sw 2/16/98 03:42'! colorForInsets ^ Color transparent! ! !InfiniteForm methodsFor: 'displaying' stamp: 'IgorStasenko 12/22/2012 03:22'! 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 current 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: '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: '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: 'displaying' stamp: 'ar 8/16/2001 12:47'! raisedColor ^ Color transparent! ! !InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'bolot 9/15/1999 10:13'! bitPatternForDepth: suspectedDepth ^ patternForm! ! !InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:56'! direction ^patternForm width @ 0! ! !InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:54'! form "Bitmap fills respond to #form" ^patternForm! ! !InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:54'! isBitmapFill ^true! ! !InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:54'! isGradientFill ^false! ! !InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:59'! isOrientedFill ^true! ! !InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:54'! isSolidFill ^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: '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: 'ar 7/2/1999 14:57'! normal ^0 @ patternForm height! ! !InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:56'! origin ^0@0! ! !InfiniteForm methodsFor: 'fillstyle protocol' stamp: 'ar 7/2/1999 14:56'! origin: aPoint "Ignored" ! ! !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: 'private'! form: aForm patternForm := aForm! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! InfiniteForm class instanceVariableNames: ''! !InfiniteForm class methodsFor: 'instance creation'! with: aForm "Answer an instance of me whose pattern form is the argument, aForm." ^self new form: aForm! ! ReadStream subclass: #InflateStream instanceVariableNames: 'state bitBuf bitPos source sourcePos sourceLimit litTable distTable sourceStream crc' classVariableNames: 'BlockProceedBit BlockTypes FixedDistCodes FixedLitCodes MaxBits StateNewBlock StateNoMoreData' poolDictionaries: '' category: 'Compression-Streams'! !InflateStream commentStamp: 'MarcusDenker 2/14/2010 22:29' prior: 0! 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: 'ar 12/23/1999 15:31'! close sourceStream ifNotNil:[sourceStream close].! ! !InflateStream methodsFor: 'accessing' stamp: 'tk 2/4/2000 10:26'! contents ^ self upToEnd! ! !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: '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: '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: '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: '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: 'accessing' stamp: 'ar 12/21/1999 23:54'! sourceLimit ^sourceLimit! ! !InflateStream methodsFor: 'accessing' stamp: 'ar 12/21/1999 23:52'! sourcePosition ^sourcePos! ! !InflateStream methodsFor: 'accessing' stamp: 'ar 12/23/1999 15:31'! sourceStream ^sourceStream! ! !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/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: '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: 'bit access' stamp: 'ar 12/5/1998 14:54'! nextByte ^source byteAt: (sourcePos := sourcePos + 1)! ! !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: 'crc' stamp: 'ar 2/29/2004 04:04'! crcError: aString ^CRCError signal: aString! ! !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: 'crc' stamp: 'ar 2/29/2004 04:22'! verifyCrc "Verify the crc checksum in the input"! ! !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: '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: '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: 'huffman trees' stamp: 'ar 12/4/1998 01:51'! distanceMap "This is used by the fast decompressor" ^nil! ! !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: '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: 'huffman trees' stamp: 'ar 12/4/1998 02:28'! 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 isNil ifTrue:[^values] ifFalse:[values at: i put: (valueMap at: oldValue+1)]]. ! ! !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 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: 'inflating' stamp: 'ar 12/3/1998 20:49'! proceedDynamicBlock self decompressBlock: litTable with: distTable! ! !InflateStream methodsFor: 'inflating' stamp: 'ar 12/3/1998 20:49'! proceedFixedBlock self decompressBlock: litTable with: distTable! ! !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: '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: '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: '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: '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: '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: '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: '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: 'private' stamp: 'ar 12/4/1998 02:03'! decompressAll "Profile the decompression speed" [self atEnd] whileFalse:[ position := readLimit. self next "Provokes decompression" ].! ! !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: '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: '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: '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 class instanceVariableNames: ''! !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]).! ! TextDiffBuilder subclass: #InlineTextDiffBuilder instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Tools-Diff'! !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! ! Object subclass: #InputEventFetcher instanceVariableNames: 'eventHandlers fetcherProcess inputSemaphore' classVariableNames: 'Default' poolDictionaries: 'EventSensorConstants' category: 'Kernel-Processes'! !InputEventFetcher commentStamp: 'michael.rueger 4/22/2009 11:59' prior: 0! 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: 'accessing' stamp: 'StephaneDucasse 5/18/2012 18:01'! fetcherProcess ^ fetcherProcess ! ! !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: '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: 'events' stamp: 'IgorStasenko 11/22/2008 20:20'! waitForInput inputSemaphore wait.! ! !InputEventFetcher methodsFor: 'handlers' stamp: 'mir 8/13/2008 16:29'! registerHandler: handler self eventHandlers add: handler! ! !InputEventFetcher methodsFor: 'handlers' stamp: 'mir 8/13/2008 16:29'! unregisterHandler: handler self eventHandlers remove: handler ifAbsent: []! ! !InputEventFetcher methodsFor: 'initialize-release' stamp: 'Igor.Stasenko 4/23/2009 13:51'! 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 events fetching process'! ! !InputEventFetcher methodsFor: 'initialize-release' stamp: 'michael.rueger 4/22/2009 11:34'! shutDown self terminateEventLoop. inputSemaphore ifNotNil: [Smalltalk unregisterExternalObject: inputSemaphore]! ! !InputEventFetcher methodsFor: 'initialize-release' stamp: 'michael.rueger 4/22/2009 11:33'! startUp inputSemaphore := Semaphore new. self primSetInputSemaphore: (Smalltalk registerExternalObject: inputSemaphore). inputSemaphore initSignals. self installEventLoop! ! !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: 'private' stamp: 'mir 8/14/2008 16:00'! eventHandlers ^eventHandlers ifNil: [eventHandlers := OrderedCollection new]! ! !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: '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: '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 class instanceVariableNames: ''! !InputEventFetcher class methodsFor: 'accessing' stamp: 'MarcusDenker 2/24/2012 13:30'! default "InputEventFetcher default" ^Default ifNil: [Default := InputEventFetcher new]! ! !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: '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/14/2008 15:21'! shutDown "InputEventFetcher shutDown" self default shutDown! ! !InputEventFetcher class methodsFor: 'system startup' stamp: 'mir 8/13/2008 14:25'! startUp "InputEventFetcher startUp" self default startUp! ! Object subclass: #InputEventHandler instanceVariableNames: 'eventFetcher' classVariableNames: '' poolDictionaries: 'EventSensorConstants' category: 'Kernel-Processes'! !InputEventHandler commentStamp: 'michael.rueger 4/22/2009 11:56' prior: 0! 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: 'events' stamp: 'JuanVuletich 11/1/2010 15:48'! flushEvents! ! !InputEventHandler methodsFor: 'events' stamp: 'mir 8/13/2008 19:35'! handleEvent: eventBuffer self subclassResponsibility! ! !InputEventHandler methodsFor: 'initialize-release' stamp: 'mir 8/13/2008 16:27'! registerIn: anEventFetcher eventFetcher := anEventFetcher. eventFetcher registerHandler: self! ! !InputEventHandler methodsFor: 'initialize-release' stamp: 'FernandoOlivero 11/25/2012 20:24'! unregister eventFetcher ifNotNil: [ eventFetcher unregisterHandler: self. eventFetcher := nil. ]! ! InputEventHandler subclass: #InputEventSensor instanceVariableNames: 'eventQueue modifiers mouseButtons mousePosition' classVariableNames: 'ButtonDecodeTable' poolDictionaries: 'EventSensorConstants' category: 'Kernel-Processes'! !InputEventSensor commentStamp: 'michael.rueger 4/22/2009 11:59' prior: 0! 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: '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: 'events' stamp: 'mir 11/19/2008 12:44'! flushAllButDandDEvents! ! !InputEventSensor methodsFor: 'events' stamp: 'JuanVuletich 11/1/2010 15:47'! flushEvents eventQueue ifNotNil:[eventQueue flush]! ! !InputEventSensor methodsFor: 'events' stamp: 'pmm 3/13/2010 11:31'! handleEvent: evt self queueEvent: evt shallowCopy! ! !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: '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: 'events' stamp: 'JuanVuletich 10/10/2010 22:56'! someEventInQueue ^eventQueue isEmpty not! ! !InputEventSensor methodsFor: 'initialize-release' 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: 'initialize-release' stamp: 'mir 8/14/2008 15:18'! shutDown! ! !InputEventSensor methodsFor: 'initialize-release' stamp: 'MichaelRueger 10/18/2009 12:56'! startUp self initialize! ! !InputEventSensor methodsFor: 'joystick'! joystickButtons: index ^ ((self primReadJoystick: index) bitShift: -22) bitAnd: 16r71F ! ! !InputEventSensor methodsFor: 'joystick'! joystickOn: index ^ (((self primReadJoystick: index) bitShift: -27) bitAnd: 1) ~= 0 ! ! !InputEventSensor methodsFor: 'joystick'! 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: 'keyboard' stamp: 'mir 8/13/2008 20:06'! flushKeyboard "Remove all characters from the keyboard buffer." [self keyboardPressed] whileTrue: [self keyboard]! ! !InputEventSensor methodsFor: 'keyboard' stamp: 'mir 8/14/2008 14:02'! keyboard "Answer the next character from the keyboard." ^self characterForEvent: self nextKeyboardEvent! ! !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: 'keyboard' stamp: 'mir 8/14/2008 14:06'! keyboardPressed "Answer true if keystrokes are available." ^self peekKeyboardEvent notNil! ! !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: '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: '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: '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 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: '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: 'nk 3/17/2004 07:02'! noButtonPressed "Answer whether any mouse button is not being pressed." ^self anyButtonPressed 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: '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: '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: 'mouse'! 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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: 'private events' stamp: 'nice 4/20/2009 22:48'! flushNonKbdEvents eventQueue ifNil: [^ self]. eventQueue flushAllSuchThat: [:buf | (self isKbdEvent: buf) not]! ! !InputEventSensor methodsFor: 'private events' stamp: 'mir 8/13/2008 19:57'! isKbdEvent: buf ^ (buf at: 1) = EventTypeKeyboard and: [(buf at: 4) = EventKeyChar]! ! !InputEventSensor methodsFor: 'private events' stamp: 'mir 6/23/2008 09:19'! mapButtons: buttons modifiers: modifiers "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]. (modifiers allMask: CtrlKeyBit) ifTrue:[^BlueButtonBit]. (modifiers allMask: CommandKeyBit) ifTrue:[^YellowButtonBit]. ^buttons! ! !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: '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: '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: '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: '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: '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: 'private events' stamp: 'mir 11/19/2008 19:42'! queueEvent: evt "Queue the given event in the event queue" eventQueue nextPut: evt! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! InputEventSensor class instanceVariableNames: ''! !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: 'class initialization' stamp: 'michael.rueger 4/22/2009 11:48'! installEventSensorFramework "Installs the new sensor framework." "InputEventSensor installEventSensorFramework" self installEventSensorFramework: InputEventFetcher! ! !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: '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: 'public'! default "Answer the default system InputEventSensor, Sensor." ^ Sensor! ! !InputEventSensor class methodsFor: 'settings' stamp: 'AlainPlantec 12/19/2009 22:38'! swapMouseButtons ^ OSPlatform current platformFamily ~= #Windows! ! !InputEventSensor class methodsFor: 'system startup' stamp: 'nk 6/21/2004 10:36'! shutDown self default shutDown.! ! !InputEventSensor class methodsFor: 'system startup' stamp: 'GuillermoPolito 4/22/2012 17:00'! startUp self installMouseDecodeTable. self default startUp! ! Object subclass: #InputEventSensorSystemSettings instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Settings-Kernel'! SimpleBorder subclass: #InsetBorder instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Borders'! !InsetBorder commentStamp: 'kfr 10/27/2003 09:32' prior: 0! see BorderedMorph! !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.! ! !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].! ! Model subclass: #Inspector instanceVariableNames: 'contents object selectionIndex timeOfLastListUpdate selectionUpdateTime' classVariableNames: '' poolDictionaries: '' category: 'Tools-Inspector'! !Inspector commentStamp: '' prior: 0! I represent a query path into the internal representation of an object. As a StringHolder, the string I represent is the value of the currently selected variable of the observed object.! !Inspector methodsFor: '*Polymorph-TaskbarIcons' stamp: 'FernandoOlivero 4/12/2011 09:47'! taskbarIcon ^ self theme smallInspectItIcon! ! !Inspector methodsFor: '*Shout-Parsing' stamp: 'SeanDeNigris 6/22/2012 18:34'! shoutParser: anSHParserST80 anSHParserST80 isMethod: false.! ! !Inspector methodsFor: '*Shout-Styling' stamp: 'GuillermoPolito 1/17/2012 14:09'! shoutAboutToStyle: aPluggableShoutMorphOrView aPluggableShoutMorphOrView getTextSelector == self trashSelector ifFalse: [ ^false ]. aPluggableShoutMorphOrView classOrMetaClass: self object class. ^ true! ! !Inspector methodsFor: '*necompletion' stamp: 'SeanDeNigris 7/7/2012 22:49'! 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.! ! !Inspector methodsFor: '*necompletion' stamp: 'SeanDeNigris 6/22/2012 16:21'! isCodeCompletionAllowed ^ true.! ! !Inspector methodsFor: 'accessing'! baseFieldList "Answer an Array consisting of 'self' and the instance variable names of the inspected object." ^ (Array with: 'self' with: 'all inst vars') , object class allInstVarNames! ! !Inspector methodsFor: 'accessing' stamp: 'GuillermoPolito 8/12/2010 14:52'! contents ^contents! ! !Inspector methodsFor: 'accessing' stamp: 'GuillermoPolito 8/12/2010 14:52'! contentsSelection "Return the interval of text in the code pane to select when I set the pane's contents" ^ 1 to: 0 "null selection"! ! !Inspector methodsFor: 'accessing'! fieldList "Answer the base field list plus an abbreviated list of indices." object class isVariable ifFalse: [^ self baseFieldList]. ^ self baseFieldList , (object basicSize <= (self i1 + self i2) ifTrue: [(1 to: object basicSize) collect: [:i | i printString]] ifFalse: [(1 to: self i1) , (object basicSize-(self i2-1) to: object basicSize) collect: [:i | i printString]])! ! !Inspector methodsFor: 'accessing'! i1 "This is the max index shown before skipping to the last i2 elements of very long arrays" ^ 100! ! !Inspector methodsFor: 'accessing'! i2 "This is the number of elements to show at the end of very long arrays" ^ 10! ! !Inspector methodsFor: 'accessing' stamp: 'al 9/21/2008 19:40'! initialExtent "Answer the desired extent for the receiver when it is first opened on the screen. " ^ 350 @ 300! ! !Inspector methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'! modelWakeUpIn: aWindow | newText | self updateListsAndCodeIn: aWindow. newText := self contentsIsString ifTrue: [newText := self selection] ifFalse: ["keep it short to reduce time to compute it" self selectionPrintString ]. newText = contents ifFalse: [contents := newText. self changed: #contents]! ! !Inspector methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'! noteSelectionIndex: anInteger for: aSymbol aSymbol == #fieldList ifTrue: [selectionIndex := anInteger]! ! !Inspector methodsFor: 'accessing'! object "Answer the object being inspected by the receiver." ^object! ! !Inspector methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'! object: anObject "Set anObject to be the object being inspected by the receiver." | oldIndex | anObject == object ifTrue: [self update] ifFalse: [oldIndex := selectionIndex <= 2 ifTrue: [selectionIndex] ifFalse: [0]. self inspect: anObject. oldIndex := oldIndex min: self fieldList size. self changed: #inspectObject. oldIndex > 0 ifTrue: [self toggleIndex: oldIndex]. self changed: #fieldList. self changed: #contents]! ! !Inspector methodsFor: 'accessing' stamp: 'tk 4/18/1998 15:37'! selectedClass "Answer the class of the receiver's current selection" self selectionUnmodifiable ifTrue: [^ object class]. ^ self selection class! ! !Inspector methodsFor: 'accessing' stamp: 'MarcusDenker 4/14/2011 10:52'! selectedClassOrMetaClass ^ self selectedClass! ! !Inspector methodsFor: 'accessing' stamp: 'sma 6/15/2000 16:48'! stepTimeIn: aSystemWindow ^ (selectionUpdateTime ifNil: [0]) * 10 max: 1000! ! !Inspector methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'! timeOfLastListUpdate ^ timeOfLastListUpdate ifNil: [timeOfLastListUpdate := 0]! ! !Inspector methodsFor: 'accessing' stamp: 'GuillermoPolito 8/12/2010 14:53'! trash "What should be displayed if a trash pane is restored to initial state" ^ ''! ! !Inspector methodsFor: 'accessing' stamp: 'tk 6/11/1998 22:23'! trash: newText "Don't save it" ^ true! ! !Inspector methodsFor: 'accessing' stamp: 'GuillermoPolito 1/17/2012 14:11'! trashSelector "It is the selector to access the trash in the inspector" ^#trash! ! !Inspector methodsFor: 'accessing' stamp: 'sd 11/20/2005 21:27'! update "Reshow contents, assuming selected value may have changed." selectionIndex = 0 ifFalse: [self contentsIsString ifTrue: [contents := self selection] ifFalse: [contents := self selectionPrintString]. self changed: #contents. self changed: #selection. self changed: #selectionIndex]! ! !Inspector methodsFor: 'accessing' stamp: 'di 1/13/1999 14:36'! wantsSteps ^ true! ! !Inspector methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 9/2/2012 17:03'! exploreStrongPointers self selectionIndex = 0 ifTrue: [^ self changed: #flash]. Smalltalk tools strongPointerExplorer openOn: self selection! ! !Inspector methodsFor: 'code'! doItReceiver "Answer the object that should be informed of the result of evaluating a text selection." ^object! ! !Inspector methodsFor: 'initialization' stamp: 'CamilloBruni 2/28/2012 11:44'! initialize selectionIndex := 1. super initialize! ! !Inspector methodsFor: 'initialization' stamp: 'sd 11/20/2005 21:27'! inspect: anObject "Initialize the receiver so that it is inspecting anObject. There is no current selection. Normally the receiver will be of the correct class (as defined by anObject inspectorClass), because it will have just been created by sedning inspect to anObject. However, the debugger uses two embedded inspectors, which are re-targetted on the current receiver each time the stack frame changes. The left-hand inspector in the debugger has its class changed by the code here. Care should be taken if this method is overridden to ensure that the overriding code calls 'super inspect: anObject', or otherwise ensures that the class of these embedded inspectors are changed back." | c | c := anObject inspectorClass. (self class ~= c and: [self class format = c format]) ifTrue: [ self primitiveChangeClassTo: c basicNew]. "Set 'object' before sending the initialize message, because some implementations of initialize (e.g., in DictionaryInspector) require 'object' to be non-nil." object := anObject. self initialize! ! !Inspector methodsFor: 'menu commands' stamp: 'BenjaminVanRyseghem 2/8/2012 17:08'! browseClass "Open an class browser on this class and method" ^ self selectedClassOrMetaClass ifNotNil: [ Smalltalk tools browser newOnClass: self selectedClassOrMetaClass ]! ! !Inspector methodsFor: 'menu commands' stamp: 'DiegoFernandez 6/9/2011 19:32'! browseClassRefs | class | class := self selectedClass theNonMetaClass ifNil: [^self]. class isTrait ifTrue: [self systemNavigation browseAllUsersOfTrait: class] ifFalse: [self systemNavigation browseAllCallsOnClass: class]! ! !Inspector methodsFor: 'menu commands' stamp: 'CamilloBruni 8/1/2012 16:01'! browseClassVariables "Browse the class variables of the selected class." | cls | cls := self selectedClass. (cls notNil and: [cls isTrait not]) ifTrue: [self systemNavigation browseClassVariables: cls] ! ! !Inspector methodsFor: 'menu commands' stamp: 'DiegoFernandez 6/9/2011 19:33'! browseInstVarDefs | cls | cls := self selectedClassOrMetaClass. (cls notNil and: [cls isTrait not]) ifTrue: [self systemNavigation browseInstVarDefs: cls] ! ! !Inspector methodsFor: 'menu commands' stamp: 'DiegoFernandez 6/9/2011 19:34'! browseInstVarRefs "1/26/96 sw: real work moved to class, so it can be shared" | cls | cls := self selectedClassOrMetaClass. (cls notNil and: [cls isTrait not]) ifTrue: [self systemNavigation browseInstVarRefs: cls]! ! !Inspector methodsFor: 'menu commands' stamp: 'MarcusDenker 7/12/2012 18:00'! browseMethodFull self selectedClassOrMetaClass ifNotNil: [:selectedClass | SystemNavigation new browseClass: selectedClass]! ! !Inspector methodsFor: 'menu commands' stamp: 'DiegoFernandez 6/9/2011 19:07'! classHierarchy "Create and schedule a class list browser on the receiver's hierarchy." self systemNavigation browseHierarchy: self selectedClassOrMetaClass ! ! !Inspector methodsFor: 'menu commands' stamp: 'tk 4/10/1998 17:53'! classOfSelection "Answer the class of the receiver's current selection" self selectionUnmodifiable ifTrue: [^ object class]. ^ self selection class! ! !Inspector methodsFor: 'menu commands' stamp: 'sd 11/20/2005 21:27'! classVarRefs "Request a browser of methods that store into a chosen instance variable" | aClass | (aClass := self classOfSelection) ifNotNil: [self systemNavigation browseClassVarRefs: aClass]. ! ! !Inspector methodsFor: 'menu commands' 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! ! !Inspector methodsFor: 'menu commands' stamp: 'sd 11/20/2005 21:27'! copyName "Copy the name of the current variable, so the user can paste it into the window below and work with is. If collection, do (xxx at: 1)." | sel aClass variableNames | self selectionUnmodifiable ifTrue: [^ self changed: #flash]. aClass := self object class. variableNames := aClass allInstVarNames. (aClass isVariable and: [selectionIndex > (variableNames size + 2)]) ifTrue: [sel := '(self basicAt: ' , (selectionIndex - (variableNames size + 2)) asString , ')'] ifFalse: [sel := variableNames at: selectionIndex - 2]. (self selection isKindOf: Collection) ifTrue: [sel := '(' , sel , ' at: 1)']. Clipboard clipboardText: sel asText! ! !Inspector methodsFor: 'menu commands' stamp: 'sd 11/20/2005 21:27'! defsOfSelection "Open a browser on all defining references to the selected instance variable, if that's what currently selected. " | aClass sel | self selectionUnmodifiable ifTrue: [^ self changed: #flash]. (aClass := self object class) isVariable ifTrue: [^ self changed: #flash]. sel := aClass allInstVarNames at: self selectionIndex - 2. self systemNavigation browseAllStoresInto: sel from: aClass! ! !Inspector methodsFor: 'menu commands' stamp: 'GuillermoPolito 8/13/2010 00:12'! doItContext "Answer the context in which a text selection can be evaluated." ^nil! ! !Inspector methodsFor: 'menu commands' stamp: 'IgorStasenko 1/22/2012 14:40'! explorePointers self selectionIndex = 0 ifTrue: [^ self changed: #flash]. Smalltalk tools pointerExplorer openOn: self selection! ! !Inspector methodsFor: 'menu commands' stamp: 'sw 9/21/1999 12:16'! exploreSelection self selectionIndex = 0 ifTrue: [^ self changed: #flash]. ^ self selection explore! ! !Inspector methodsFor: 'menu commands' stamp: 'EstebanLorenzano 1/31/2013 19:25'! fieldListMenu: aMenu "Arm the supplied menu with items for the field-list of the receiver" aMenu addStayUpItemSpecial. ^aMenu addAllFromPragma: 'inspectorFieldListMenu' target: self. ! ! !Inspector methodsFor: 'menu commands' stamp: 'tk 4/12/1998 08:49'! inspectBasic "Bring up a non-special inspector" selectionIndex = 0 ifTrue: [^ object basicInspect]. self selection basicInspect! ! !Inspector methodsFor: 'menu commands' stamp: 'StephaneDucasse 5/28/2011 13:40'! inspectElement "Create and schedule an Inspector on an element of the receiver's model's currently selected collection." | sel selSize countString count nameStrs | self selectionIndex = 0 ifTrue: [ ^ self changed: #flash ]. ((sel := self selection) isKindOf: SequenceableCollection) ifFalse: [ (sel isKindOf: MorphExtension) ifTrue: [ ^ sel inspectElement ]. ^ sel inspect ]. (selSize := sel size) = 1 ifTrue: [ ^ sel first inspect ]. selSize <= 20 ifTrue: [ nameStrs := (1 to: selSize) asArray collect: [ :ii | ii printString , ' ' , (((sel at: ii) printStringLimitedTo: 25) replaceAll: Character cr with: Character space) ]. count := UIManager default chooseFrom: nameStrs substrings title: 'which element?'. count = 0 ifTrue: [ ^ self ]. ^ (sel at: count) inspect ]. countString := UIManager default request: 'Which element? (1 to ' , selSize printString , ')' initialAnswer: '1'. countString isEmptyOrNil ifTrue: [ ^ self ]. count := Integer readFrom: countString readStream. (count > 0 and: [ count <= selSize ]) ifTrue: [ (sel at: count) inspect ] ifFalse: [ Beeper beep ]! ! !Inspector methodsFor: 'menu commands' stamp: 'apb 7/14/2004 13:16'! inspectSelection "Create and schedule an Inspector on the receiver's model's currently selected object." self selectionIndex = 0 ifTrue: [^ self changed: #flash]. self selection inspect. ^ self selection! ! !Inspector methodsFor: 'menu commands' stamp: 'MarcusDenker 5/7/2012 15:12'! inspectorKey: aChar from: view "Respond to a Command key issued while the cursor is over my field list" aChar == $i ifTrue: [^ self selection inspect]. aChar == $I ifTrue: [^ self selection explore]. aChar == $b ifTrue: [^ self browseMethodFull]. aChar == $h ifTrue: [^ self classHierarchy]. aChar == $c ifTrue: [^ self copyName]. aChar == $N ifTrue: [^ self browseClassRefs]. ^ false! ! !Inspector methodsFor: 'menu commands' stamp: 'CamilloBruni 8/1/2012 16:15'! referencesToSelection "Open a browser on all references to the selected instance variable, if that's what currently selected." | aClass sel | self selectionUnmodifiable ifTrue: [^ self changed: #flash]. (aClass := self object class) isVariable ifTrue: [^ self changed: #flash]. sel := aClass allInstVarNames at: self selectionIndex - 2. self systemNavigation browseAllAccessesTo: sel from: aClass! ! !Inspector methodsFor: 'selecting' stamp: 'damiencassou 5/30/2008 16:29'! accept: aString | result | result := self doItReceiver class evaluatorClass new evaluate: aString readStream in: self doItContext to: self doItReceiver notifying: nil ifFail: [ "fix this" self changed: #flash. ^ false ]. result == #failedDoit ifTrue: [ ^ false ]. self replaceSelectionValue: result. self changed: #contents. ^ true! ! !Inspector methodsFor: 'selecting' stamp: 'di 9/22/1998 21:24'! contentsIsString "Hacked so contents empty when deselected and = long printString when item 2" ^ (selectionIndex = 2) | (selectionIndex = 0)! ! !Inspector methodsFor: 'selecting' stamp: 'nice 11/8/2009 15:17'! replaceSelectionValue: anObject "The receiver has a list of variables of its inspected object. One of these is selected. The value of the selected variable is set to the value, anObject." | basicIndex si instVarIndex | selectionIndex <= 2 ifTrue: [ self toggleIndex: (si := selectionIndex). self toggleIndex: si. ^ object]. instVarIndex := selectionIndex - 2. instVarIndex > object class instSize ifFalse: [^ object instVarAt: instVarIndex put: anObject]. object class isVariable or: [self error: 'Cannot replace selection']. basicIndex := selectionIndex - 2 - object class instSize. (object basicSize <= (self i1 + self i2) or: [basicIndex <= self i1]) ifTrue: [^object basicAt: basicIndex put: anObject] ifFalse: [^object basicAt: object basicSize - (self i1 + self i2) + basicIndex put: anObject]! ! !Inspector methodsFor: 'selecting' stamp: 'eem 5/21/2008 11:46'! selectedSlotName ^ self fieldList at: self selectionIndex ifAbsent: []! ! !Inspector methodsFor: 'selecting' stamp: 'sd 11/20/2005 21:27'! selection "The receiver has a list of variables of its inspected object. One of these is selected. Answer the value of the selected variable." | basicIndex | selectionIndex = 0 ifTrue: [^ '']. selectionIndex = 1 ifTrue: [^ object]. selectionIndex = 2 ifTrue: [^ object longPrintStringLimitedTo: 20000]. (selectionIndex - 2) <= object class instSize ifTrue: [^ object instVarAt: selectionIndex - 2]. basicIndex := selectionIndex - 2 - object class instSize. (object basicSize <= (self i1 + self i2) or: [basicIndex <= self i1]) ifTrue: [^ object basicAt: basicIndex] ifFalse: [^ object basicAt: object basicSize - (self i1 + self i2) + basicIndex]! ! !Inspector methodsFor: 'selecting'! selectionIndex "The receiver has a list of variables of its inspected object. One of these is selected. Answer the index into the list of the selected variable." ^selectionIndex! ! !Inspector methodsFor: 'selecting' stamp: 'apb 8/20/2004 22:03'! selectionPrintString | text | selectionUpdateTime := [text := [self selection printStringLimitedTo: 5000] on: Error do: [text := self printStringErrorText. text addAttribute: TextColor red from: 1 to: text size. text]] timeToRun. ^ text! ! !Inspector methodsFor: 'selecting' stamp: 'PHK 6/30/2004 11:50'! selectionUnmodifiable "Answer if the current selected variable is modifiable via acceptance in the code pane. For most inspectors, no selection and a selection of 'self' (selectionIndex = 1) and 'all inst vars' (selectionIndex = 2) are unmodifiable" ^ selectionIndex <= 2! ! !Inspector methodsFor: 'selecting' stamp: 'sd 11/20/2005 21:27'! toggleIndex: anInteger "The receiver has a list of variables of its inspected object. One of these is selected. If anInteger is the index of this variable, then deselect it. Otherwise, make the variable whose index is anInteger be the selected item." selectionUpdateTime := 0. selectionIndex = anInteger ifTrue: ["same index, turn off selection" selectionIndex := 0. contents := ''] ifFalse: ["different index, new selection" selectionIndex := anInteger. self contentsIsString ifTrue: [contents := self selection] ifFalse: [contents := self selectionPrintString]]. self changed: #selection. self changed: #contents. self changed: #selectionIndex.! ! !Inspector methodsFor: 'stepping' stamp: 'AlainPlantec 12/1/2009 22:37'! stepAt: millisecondClockValue in: aWindow | newText | (CodeHolder smartUpdating and: [(millisecondClockValue - self timeOfLastListUpdate) > 8000]) "Not more often than once every 8 seconds" ifTrue: [self updateListsAndCodeIn: aWindow. timeOfLastListUpdate := millisecondClockValue]. newText := self contentsIsString ifTrue: [self selection] ifFalse: ["keep it short to reduce time to compute it" self selectionPrintString ]. newText = contents ifFalse: [contents := newText. self changed: #contents]! ! !Inspector methodsFor: 'theme' stamp: 'MarcusDenker 4/14/2011 10:46'! theme ^ UITheme current! ! !Inspector methodsFor: 'private' stamp: 'ClementBera 11/15/2012 09:10'! numberOfFixedFields ^ 2 + object class instSize! ! !Inspector methodsFor: 'private' stamp: 'sd 11/20/2005 21:27'! printStringErrorText | nm | nm := self selectionIndex < 3 ifTrue: ['self'] ifFalse: [self selectedSlotName]. ^ ('') asText.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Inspector class instanceVariableNames: ''! !Inspector class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'FernandoOlivero 4/12/2011 09:47'! taskbarIcon "Answer the icon for the receiver in a task bar." ^self theme smallInspectItIcon! ! !Inspector class methodsFor: 'instance creation' stamp: 'al 9/21/2008 19:41'! horizontalDividerProportion ^ 0.4! ! !Inspector class methodsFor: 'instance creation' stamp: 'PHK 7/22/2004 17:04'! inspect: anObject "Answer an instance of me to provide an inspector for anObject." "We call basicNew to avoid a premature initialization; the instance method inspect: anObject will do a self initialize." ^self basicNew inspect: anObject! ! !Inspector class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 10/25/2012 15:30'! openAsMorphOn: anObject withEvalPane: withEval withLabel: label valueViewClass: valueViewClass "Note: for now, this always adds an eval pane, and ignores the valueViewClass" UsersManager default currentUser canInspect ifFalse: [ ^ self ]. ^ (self openAsMorphOn: anObject withLabel: label) openInWorld! ! !Inspector class methodsFor: 'instance creation' stamp: 'MarcusDenker 11/2/2012 15:08'! openAsMorphOn: anObject withLabel: aLabel "(Inspector openAsMorphOn: SystemOrganization withLabel: 'Test') openInWorld" | window inspector | inspector := self inspect: anObject. window := (SystemWindow labelled: aLabel) model: inspector. window addMorph: ((PluggableListMorph new doubleClickSelector: #inspectSelection; on: inspector list: #fieldList selected: #selectionIndex changeSelected: #toggleIndex: menu: #fieldListMenu: keystroke: #inspectorKey:from:) autoDeselect: false ) "For doubleClick to work best disable autoDeselect" frame: (0 @ 0 corner: self horizontalDividerProportion @ self verticalDividerProportion). window addMorph: (PluggableTextMorph on: inspector text: #contents accept: #accept: readSelection: #contentsSelection menu: #codePaneMenu:shifted:) frame: (self horizontalDividerProportion @ 0 corner: 1 @ self verticalDividerProportion). window addMorph: ((PluggableTextMorph on: inspector text: inspector trashSelector accept: inspector trashSelector asMutator readSelection: #contentsSelection menu: #codePaneMenu:shifted:) askBeforeDiscardingEdits: false; font: StandardFonts codeFont) frame: (0 @ self verticalDividerProportion corner: 1 @ 1). window setUpdatablePanesFrom: #(#fieldList ). window position: 16 @ 0. "Room for scroll bar." ^ window ! ! !Inspector class methodsFor: 'instance creation' stamp: 'ar 9/27/2005 18:30'! openOn: anObject "Create and schedule an instance of me on the model, anInspector. " ^ self openOn: anObject withEvalPane: true! ! !Inspector class methodsFor: 'instance creation'! openOn: anObject withEvalPane: withEval "Create and schedule an instance of me on the model, anInspector. " ^ self openOn: anObject withEvalPane: withEval withLabel: anObject defaultLabelForInspector! ! !Inspector class methodsFor: 'instance creation' stamp: 'alain.plantec 6/10/2008 18:35'! openOn: anObject withEvalPane: withEval withLabel: label ^ self openAsMorphOn: anObject withEvalPane: withEval withLabel: label valueViewClass: nil! ! !Inspector class methodsFor: 'instance creation' stamp: 'sw 1/19/1999 14:38'! verticalDividerProportion ^ 0.7! ! !Inspector class methodsFor: 'menu' stamp: 'EstebanLorenzano 1/31/2013 18:32'! menuFieldList: aBuilder | target selection | target := aBuilder model. selection := target selection. (aBuilder item: #'Inspect') keyText: 'i'; selector: #inspectSelection; icon: UITheme current smallInspectItIcon. (aBuilder item: #'Explore') keyText: 'I'; selector: #exploreSelection; icon: UITheme current smallInspectItIcon. (((selection isMemberOf: Array) or: [selection isMemberOf: OrderedCollection]) and: [ selection size > 0]) ifTrue: [ (aBuilder item: #'Inspect element...') selector: #inspectElement ]. (selection isKindOf: MorphExtension) ifTrue: [ (aBuilder item: #'Inspect property...') selector: #inspectElement ]. aBuilder withSeparatorAfter. (aBuilder item: #'Method refs to this inst var') selector: #referencesToSelection. (aBuilder item: #'Methods storing into this inst var') selector: #defsOfSelection. (aBuilder item: #'Explore pointers') selector: #explorePointers. (aBuilder item: #'Explore strong pointers') selector: #exploreStrongPointers; withSeparatorAfter. (aBuilder item: #'Browse full') keyText: 'b'; selector: #browseMethodFull. (aBuilder item: #'Browse class') selector: #browseClass. (aBuilder item: #'Browse hierarchy') keyText: 'h'; selector: #classHierarchy; withSeparatorAfter. (aBuilder item: #'Inst var refs...') selector: #browseInstVarRefs. (aBuilder item: #'Inst var defs...') selector: #browseInstVarDefs. (aBuilder item: #'Class var refs...') selector: #classVarRefs. (aBuilder item: #'Class variables') selector: #browseClassVariables. (aBuilder item: #'Class refs') keyText: 'N'; selector: #browseClassRefs; withSeparatorAfter. (aBuilder item: #'Copy name') keyText: 'c'; selector: #copyName. (aBuilder item: #'Basic inspect') selector: #inspectBasic. ! ! !Inspector class methodsFor: 'tools registry' stamp: 'IgorStasenko 2/19/2011 02:58'! registerToolsOn: registry "Add ourselves to registry. See [Smalltalk tools]" registry register: self as: #inspector ! ! ComposableModel subclass: #InstVarAdder instanceVariableNames: 'description nameField nameLabel toolbar typeField typeLabel typeChoice selectedClass' classVariableNames: '' poolDictionaries: '' category: 'Spec-Builder-Tools'! !InstVarAdder methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/28/2012 22:07'! description ^ description contents! ! !InstVarAdder methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/28/2012 20:59'! nameField ^ nameField! ! !InstVarAdder methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/28/2012 20:59'! nameLabel ^ nameLabel! ! !InstVarAdder methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/28/2012 20:59'! selectedClass ^ selectedClass! ! !InstVarAdder methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/28/2012 20:59'! toolbar ^ toolbar! ! !InstVarAdder methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/28/2012 20:59'! typeChoice ^ typeChoice! ! !InstVarAdder methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/28/2012 20:59'! typeField ^ typeField! ! !InstVarAdder methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/28/2012 20:59'! typeLabel ^ typeLabel! ! !InstVarAdder methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/12/2012 19:08'! initialize "Initialization code for InstVarAdder" description := nil asValueHolder. selectedClass := nil asValueHolder. super initialize.! ! !InstVarAdder methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/12/2012 18:56'! initializePresenter toolbar okAction: [ self accept ].! ! !InstVarAdder methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/12/2012 18:56'! initializeWidgets self instantiateModels: #( nameField TextInputFieldModel nameLabel LabelModel toolbar OkCancelToolbar typeChoice DropListModel typeLabel LabelModel ). nameLabel text: 'Name:'. nameField autoAccept: true; entryCompletion: nil. typeLabel text: 'Class:'. typeChoice items: ((ComposableModel subclasses sort: [:a :b | a name < b name ]) collect: [: e | DropListItem named: e name do: [ selectedClass contents: e ]]) . self setFocus! ! !InstVarAdder methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 3/1/2012 21:46'! setFocus self focusOrder add: nameField; add: typeChoice; add: toolbar.! ! !InstVarAdder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 2/28/2012 21:34'! description: aDescription description contents: aDescription! ! !InstVarAdder methodsFor: 'protocol-events' stamp: 'bvr 5/31/2012 13:33'! whenDescriptionChanged: aBlock description whenChangedDo: aBlock! ! !InstVarAdder methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/2/2012 05:54'! accept | name cl | nameField accept. (name := nameField getText) isEmptyOrNil ifFalse: [ cl := selectedClass contents. cl ifNil: [ cl := ComposableModel ]. description contents addInstVarNamed: name kindOfComposablaeModel: cl. description contentsChanged ]! ! !InstVarAdder methodsFor: 'private' stamp: 'BenjaminVanRyseghem 2/28/2012 21:55'! initialExtent ^ 260@115! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! InstVarAdder class instanceVariableNames: ''! !InstVarAdder class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/15/2013 13:40'! defaultSpec | height width | height := 25. width := (StandardFonts defaultFont widthOfString: 'Name:') + 10. ^ { #ComposableSpec. #add:. {{#model . #nameLabel } . #layout: . {#FrameLayout. #rightFraction:. 0.5. #bottomOffset:. (2*height) negated} }. #add:. {{#model. #nameField.}. #layout:. {#FrameLayout. #leftOffset:. width. #bottomOffset:. (2*height) negated} }. #add:. {{#model. #typeLabel.}. #layout:. { #FrameLayout. #topFraction:. 1. #rightFraction:. 0.5. #topOffset:. (2*height negated). #bottomOffset:. (height negated)}} . #add:. {{#model. #typeChoice.}. #layout:. { #FrameLayout. #topFraction:. 1. #leftOffset:. width. #topOffset:. (2*height negated). #bottomOffset:. (height negated).}}. #add:. {{#model. #toolbar.}. #layout:. { #FrameLayout. #topFraction:. 1. #topOffset:. (height negated) }. }}! ! !InstVarAdder class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 2/28/2012 21:54'! title ^ 'Add an inst var...'! ! InstructionClient subclass: #InstVarRefLocator instanceVariableNames: 'bingo' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Methods'! !InstVarRefLocator commentStamp: 'md 4/8/2003 12:50' prior: 0! My job is to scan bytecodes for instance variable references. BlockContext allInstances collect: [ :x | {x. x hasInstVarRef} ].! !InstVarRefLocator methodsFor: 'initialize-release' stamp: 'md 4/8/2003 11:35'! interpretNextInstructionUsing: aScanner bingo := false. aScanner interpretNextInstructionFor: self. ^bingo! ! !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! ! TestCase subclass: #InstVarRefLocatorTest instanceVariableNames: 'tt' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Methods'! !InstVarRefLocatorTest commentStamp: '' prior: 0! 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: 'examples' stamp: 'md 4/8/2003 12:31'! example2 | ff| ff := 1. (1 < 2) ifTrue: [ff ifNotNil: [ff := 'hallo']]. ^ ff.! ! !InstVarRefLocatorTest methodsFor: 'tests' stamp: 'md 4/8/2003 12:42'! testExample1 | method | method := self class compiledMethodAt: #example1. self assert: (self hasInstVarRef: method).! ! !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: 'nice 1/5/2010 15:59'! testInstructions Object methods do: [:method | | scanner printer end | scanner := InstructionStream on: method. printer := InstVarRefLocator new. end := scanner method endPC. [scanner pc <= end] whileTrue: [ self shouldnt: [printer interpretNextInstructionUsing: scanner] raise: Error. ]. ].! ! !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! ! ComposableModel subclass: #InstVarSetter instanceVariableNames: 'list picklist text okCancelToolbar descriptionHolder addButton removeButton textBindings' classVariableNames: '' poolDictionaries: '' category: 'Spec-Builder-Tools'! !InstVarSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/28/2012 20:32'! addButton ^ addButton! ! !InstVarSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/28/2012 02:02'! list ^ list! ! !InstVarSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/28/2012 03:22'! okCancelToolbar ^ okCancelToolbar! ! !InstVarSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/28/2012 02:02'! picklist ^ picklist! ! !InstVarSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/28/2012 20:32'! removeButton ^ removeButton! ! !InstVarSetter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/28/2012 02:02'! text ^ text! ! !InstVarSetter methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/12/2012 19:09'! initialize "Initialization code for InstVarSetter" descriptionHolder := nil asValueHolder. textBindings := Dictionary new. super initialize. ! ! !InstVarSetter methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 10/18/2012 14:42'! initializeBindingsFrom: desc desc addInstVarDescriptions do: [:e || adds | textBindings at: e put: Dictionary new. adds := desc addIntoMethodDescriptions select: [:d | d selector = ('register', e name capitalized, 'Events') ]. adds do: [:a || source item | source := a code substrings. item := source second allButLast asSymbol. (textBindings at: e) at: item put: (((source allButFirst:2) joinUsing: ' ')->true) ]].! ! !InstVarSetter methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/12/2012 18:57'! initializePresenter okCancelToolbar okAction: [ self accept ]. addButton action: [ self addInstVar ]. removeButton action: [ self removeInstVar ]. self registerListEvents. self registerPickListEvents. self registerDescriptionEvents. self registerTextEvents! ! !InstVarSetter methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/12/2012 19:07'! initializeWidgets self instantiateModels: #( list ListComposableModel picklist PickListModel text TextModel okCancelToolbar OkCancelToolbar addButton ButtonModel removeButton ButtonModel ). list displayBlock: [:e | e name ]. picklist labelClickable: false. text aboutToStyle: true. text enabled: false. okCancelToolbar okAction: [ self accept ]. addButton label: '+'; state: false. removeButton label: '-'; state: false.! ! !InstVarSetter methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 3/5/2012 06:52'! registerDescriptionEvents descriptionHolder whenChangedDo: [:desc|| items | self initializeBindingsFrom: desc. items := desc addInstVarDescriptions select: [:e | e type inheritsFrom: ComposableModel ]. list items: (items sort: [:a :b | a name < b name ])]! ! !InstVarSetter methodsFor: 'initialization' stamp: 'bvr 5/31/2012 13:33'! registerListEvents list whenSelectedItemChanged: [:instVarDesc | instVarDesc ifNil: [ picklist items: {} ] ifNotNil: [ picklist items: (instVarDesc type possibleEvents). (instVarDesc type possibleEvents) do: [:e | (picklist checkboxFor: e) state: ((textBindings at: list selectedItem ifAbsentPut: [ Dictionary new ]) at: e ifAbsentPut: [ self defaultText->false ]) value ]]. picklist resetSelection. text text: '' ]! ! !InstVarSetter methodsFor: 'initialization' stamp: 'bvr 5/31/2012 13:33'! registerPickListEvents picklist whenPickedItemsChanged: [:item :old| item ifNotNil: [ ((textBindings at: list selectedItem ifAbsentPut: [ Dictionary new ]) at: item ifAbsentPut: [ self defaultText->false ]) value: old ]]. picklist whenSelectedItemChanged: [:item || txt | item ifNil: [ text text: ''. text enabled: false ] ifNotNil: [ txt := ((textBindings at: list selectedItem ifAbsentPut: [ Dictionary new ]) at: item ifAbsentPut: [ self defaultText->false ]) key. text text: txt. text enabled: true ]]! ! !InstVarSetter methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/11/2012 11:46'! registerTextEvents text acceptBlock: [:txt || item | item := picklist selectedItem. ((textBindings at: list selectedItem ifAbsentPut: [ Dictionary new ]) at: item ifAbsentPut: [ self defaultText->false ]) key: txt . (picklist checkboxFor: item) state: true.]! ! !InstVarSetter methodsFor: 'protocol' stamp: 'bvr 5/31/2012 13:42'! accept | instVars desc | desc := descriptionHolder contents. desc ifNil: [ ^ self ]. text accept. instVars := textBindings select: [:assoc | assoc notNil and: [ assoc values anySatisfy: [:v | v value ]]]. instVars associations do: [:assoc || instVar source events | instVar := assoc key. source := String streamContents: [:s | s << 'register' << instVar name capitalized << 'Events']. desc addCodeToInitialize: 'self ', source order: 1. desc addMethodWithSource: source category: 'initialization'. events := assoc value select: [:a | a value ]. events associations do: [:a || src | src := String streamContents: [:s | s << instVar name << ' ' << a key asString << ': ' << a value key << '.']. desc addCodeTo: source source: src order: 1 ]].! ! !InstVarSetter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 2/28/2012 14:20'! description ^ descriptionHolder contents! ! !InstVarSetter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 2/28/2012 14:11'! description: aDescription descriptionHolder contents: aDescription! ! !InstVarSetter methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 2/28/2012 14:19'! inspectedClass ^ descriptionHolder contents addClassDescription! ! !InstVarSetter methodsFor: 'protocol' stamp: 'bvr 5/31/2012 13:42'! openWithSpec super openWithSpec. text widget ifNotNil: [:m | m styler workspace: self ]! ! !InstVarSetter methodsFor: 'private' stamp: 'bvr 5/31/2012 13:33'! addInstVar | adder | adder := InstVarAdder new. adder description: descriptionHolder contents; openWithSpec. adder whenDescriptionChanged: [ self description: adder description ]! ! !InstVarSetter methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/1/2012 21:43'! defaultText ^ '[:new :old :announcement :announcer | ]'! ! !InstVarSetter methodsFor: 'private' stamp: 'BenjaminVanRyseghem 2/28/2012 14:20'! hasBindingOf: aString ^ self description ifNil: [ false ] ifNotNil: [:desc | (desc addInstVarDescriptions collect: #name) includes: aString ]! ! !InstVarSetter methodsFor: 'private' stamp: 'BenjaminVanRyseghem 2/28/2012 14:21'! hasBindingThatBeginsWith: aString ^ self description ifNil: [ false ] ifNotNil: [:desc | (desc addInstVarDescriptions collect: #name) anySatisfy: [:name | name beginsWith: aString ]]! ! !InstVarSetter methodsFor: 'private' stamp: 'BenjaminVanRyseghem 2/28/2012 03:38'! initialExtent ^ (700 min: (World extent x)) @ (300 min: (World extent y))! ! !InstVarSetter methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/30/2012 17:10'! removeInstVar descriptionHolder contents removeInstVar: list selectedItem. descriptionHolder contentsChanged.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! InstVarSetter class instanceVariableNames: ''! !InstVarSetter class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/15/2013 14:13'! defaultSpec | delta | delta := 25. ^{ #ComposableSpec. #add:. {{#model. #list. }. #layout:. {#FrameLayout. #rightFraction:. 0.3. #bottomOffset:. ((2*delta) negated)}}. #add:. {{#model. #addButton }. #layout:. {#FrameLayout. #topFraction:. 1. #rightFraction:. 0.16. #topOffset:. ((2*delta) negated). #bottomOffset:. (delta negated)}}. #add:. {{#model. #removeButton }. #layout:. {#FrameLayout. #leftFraction:. 0.16. #topFraction:. 1. #rightFraction:. 0.33. #topOffset:. ((2*delta) negated). #bottomOffset:. (delta negated)}}. #add:. {{#model. #picklist }. {#FrameLayout. #leftFraction:. 0.33. #rightFraction:. 0.66. #bottomOffset:. (delta negated).}}. #add:. {{#model. #text }. #layout:. {#FrameLayout. #leftFraction:. 0.66. #bottomOffset:. delta negated}}. #add:. {{#model. #okCancelToolbar }. #layout:. {#FrameLayout. #topFraction:. 1. #topOffset:. (delta negated)}}}! ! !InstVarSetter class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 2/28/2012 01:40'! title ^'Inst var setter'! ! VariableNode subclass: #InstanceVariableNode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-ParseNodes'! !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/15/2008 10:05'! emitCodeForStorePop: stack encoder: encoder encoder genStorePopInstVar: index. stack pop: 1! ! !InstanceVariableNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 18:08'! emitCodeForValue: stack encoder: encoder stack push: 1. ^encoder genPushInstVar: index! ! !InstanceVariableNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 17:57'! sizeCodeForStore: encoder ^encoder sizeStoreInstVar: 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 17:53'! sizeCodeForValue: encoder ^encoder sizePushInstVar: index! ! !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: 'visiting' stamp: 'eem 9/6/2009 12:34'! accept: aVisitor ^aVisitor visitInstanceVariableNode: self! ! Object subclass: #InstructionClient instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Methods'! !InstructionClient commentStamp: 'md 4/8/2003 12:50' prior: 0! 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:02'! blockReturnTop "Return Top Of Stack 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:02'! doPop "Remove Top Of Stack bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02'! jump: offset "Unconditional Jump bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02'! jump: offset if: condition "Conditional Jump bytecode." ! ! !InstructionClient methodsFor: 'instruction decoding' stamp: 'md 4/8/2003 13:02'! methodReturnConstant: value "Return Constant 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'! methodReturnTop "Return Top Of Stack 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: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:03'! popIntoTemporaryVariable: offset "Remove Top Of Stack And Store Into Temporary Variable 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: 'eem 5/31/2008 13:49'! pushClosureCopyNumCopiedValues: numCopied numArgs: numArgs blockSize: blockSize "Push Closure 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'! pushConstant: value "Push Constant, value, 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:50'! pushNewArrayOfSize: numElements "Push New Array of size numElements 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'! 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: '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: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: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:04'! storeIntoLiteralVariable: anAssociation "Store Top Of Stack Into Literal Variable Of Method 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: '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:04'! storeIntoTemporaryVariable: offset "Store Top Of Stack Into Temporary Variable Of Method bytecode." ! ! TestCase subclass: #InstructionClientTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Methods'! !InstructionClientTest commentStamp: '' prior: 0! 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: 'nice 1/5/2010 15:59'! 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: [ self shouldnt: [scanner interpretNextInstructionFor: client] raise: Error. ]. ]. ! ! InstructionClient subclass: #InstructionPrinter instanceVariableNames: 'method scanner stream oldPC innerIndents indent printPC indentSpanOfFollowingJump' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Methods'! !InstructionPrinter commentStamp: 'md 4/8/2003 12:47' prior: 0! 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: 'accessing' stamp: 'ajh 6/27/2003 22:25'! indent ^ indent ifNil: [0]! ! !InstructionPrinter methodsFor: 'accessing' stamp: 'md 4/8/2003 11:20'! method ^method.! ! !InstructionPrinter methodsFor: 'accessing' stamp: 'eem 5/29/2008 14:00'! method: aMethod method := aMethod. printPC := true. indentSpanOfFollowingJump := false! ! !InstructionPrinter methodsFor: 'accessing' stamp: 'eem 5/29/2008 13:50'! printPC ^printPC! ! !InstructionPrinter methodsFor: 'accessing' stamp: 'eem 5/29/2008 13:50'! printPC: aBoolean printPC := aBoolean! ! !InstructionPrinter methodsFor: 'initialize-release' stamp: 'ajh 2/9/2003 14:16'! indent: numTabs indent := numTabs! ! !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: '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: 'instruction decoding'! blockReturnTop "Print the Return Top Of Stack bytecode." self print: 'blockReturn'! ! !InstructionPrinter methodsFor: 'instruction decoding'! doDup "Print the Duplicate Top Of Stack bytecode." self print: 'dup'! ! !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: '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: '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'! methodReturnConstant: value "Print the Return Constant bytecode." self print: 'return: ' , value printString! ! !InstructionPrinter methodsFor: 'instruction decoding'! methodReturnReceiver "Print the Return Self bytecode." self print: 'returnSelf'! ! !InstructionPrinter methodsFor: 'instruction decoding'! methodReturnTop "Print the Return Top Of Stack bytecode." self print: 'returnTop'! ! !InstructionPrinter methodsFor: 'instruction decoding'! popIntoLiteralVariable: anAssociation "Print the Remove Top Of Stack And Store Into Literal Variable bytecode." self print: 'popIntoLit: ' , anAssociation key! ! !InstructionPrinter methodsFor: 'instruction decoding'! popIntoReceiverVariable: offset "Print the Remove Top Of Stack And Store Into Instance Variable bytecode." self print: 'popIntoRcvr: ' , offset printString! ! !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: 'instruction decoding'! popIntoTemporaryVariable: offset "Print the Remove Top Of Stack And Store Into Temporary Variable bytecode." self print: 'popIntoTemp: ' , offset printString! ! !InstructionPrinter methodsFor: 'instruction decoding'! pushActiveContext "Print the Push Active Context On Top Of Its Own Stack bytecode." self print: 'pushThisContext: '! ! !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: 'eem 5/30/2008 17:42'! pushConsArrayWithElements: numElements self print: 'pop ', numElements printString, ' into (Array new: ', numElements printString, ')'! ! !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'! 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 15:02'! pushNewArrayOfSize: numElements self print: 'push: (Array new: ', numElements printString, ')'! ! !InstructionPrinter methodsFor: 'instruction decoding'! pushReceiver "Print the Push Active Context's Receiver on Top Of Stack bytecode." self print: 'self'! ! !InstructionPrinter methodsFor: 'instruction decoding'! 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: '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'! 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: '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'! storeIntoLiteralVariable: anAssociation "Print the Store Top Of Stack Into Literal Variable Of Method bytecode." self print: 'storeIntoLit: ' , anAssociation key! ! !InstructionPrinter methodsFor: 'instruction decoding'! storeIntoReceiverVariable: offset "Print the Store Top Of Stack Into Instance Variable Of Method bytecode." self print: 'storeIntoRcvr: ' , offset printString! ! !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'! storeIntoTemporaryVariable: offset "Print the Store Top Of Stack Into Temporary Variable Of Method bytecode." self print: 'storeIntoTemp: ' , offset printString! ! !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 class instanceVariableNames: ''! !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." ! ! ClassTestCase subclass: #InstructionPrinterTest instanceVariableNames: 'tt' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Methods'! !InstructionPrinterTest commentStamp: '' prior: 0! 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: 'marcus.denker 8/24/2008 13:19'! testInstructions "just print all of methods of Object and see if no error accours" | printer | printer := InstructionPrinter. Object methods do: [:method | self shouldnt: [ String streamContents: [:stream | (printer on: method) printInstructionsOn: stream]] raise: Error. ]. ! ! Object subclass: #InstructionStream instanceVariableNames: 'sender pc' classVariableNames: 'SpecialConstants' poolDictionaries: '' category: 'Kernel-Methods'! !InstructionStream commentStamp: '' prior: 0! 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: 'debugger access' stamp: 'eem 6/5/2008 10:28'! abstractPC ^self method abstractPCForConcretePC: pc! ! !InstructionStream methodsFor: 'debugger access' stamp: 'eem 6/5/2008 10:45'! debuggerMap ^self method debuggerMap! ! !InstructionStream methodsFor: 'decoding' stamp: 'ajh 7/29/2001 20:45'! atEnd ^ pc > self method endPC! ! !InstructionStream methodsFor: 'decoding' stamp: 'MarcusDenker 6/13/2012 17:03'! interpret | endPC | endPC := self method endPC. [pc > endPC] whileFalse: [self interpretNextInstructionFor: self]! ! !InstructionStream methodsFor: 'decoding'! 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: '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 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: '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: 'scanning' stamp: 'eem 6/16/2008 09:52'! firstByte "Answer the first byte of the current bytecode." ^self method at: pc! ! !InstructionStream methodsFor: 'scanning'! followingByte "Answer the next bytecode." ^self method at: pc + 1! ! !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:24'! followingPc "Answer the pc of the following bytecode." ^self nextPc: (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'! 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: 'scanning'! nextByte "Answer the next bytecode." ^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: 'scanning'! pc "Answer the index of the next bytecode." ^pc! ! !InstructionStream methodsFor: 'scanning' stamp: 'ajh 7/18/2003 21:36'! peekInstruction "Return the next bytecode instruction as a message that an InstructionClient would understand. The pc remains unchanged." | currentPc instr | currentPc := self pc. instr := self nextInstruction. self pc: currentPc. ^ instr! ! !InstructionStream methodsFor: 'scanning' stamp: 'eem 6/5/2008 10:07'! previousPc ^self method pcPreviousTo: pc! ! !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: '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: 'eem 6/4/2008 10:57'! 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: 'scanning' stamp: 'hmm 7/29/2001 21:25'! 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: 'scanning' stamp: 'eem 6/16/2008 09:52'! thirdByte "Answer the third byte of the current bytecode." ^self method at: pc + 2! ! !InstructionStream methodsFor: 'testing' stamp: 'MarcusDenker 6/30/2012 16:40'! willBlockReturn ^ (self method at: pc) = 125! ! !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: 'testing'! 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: '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: 'testing' stamp: 'MarcusDenker 6/30/2012 16:40'! willJustPop ^ (self method at: pc) = 135! ! !InstructionStream methodsFor: 'testing'! willReturn "Answer whether the next bytecode is a return." ^(self method at: pc) between: 120 and: 125! ! !InstructionStream methodsFor: 'testing' stamp: 'eem 5/16/2008 16:22'! willSend "Answer whether the next bytecode is a message-send." | byte | byte := self method at: pc. ^byte >= 131 and: [byte >= 176 "special send or short send" or: [byte <= 134]] "long sends"! ! !InstructionStream methodsFor: 'testing' stamp: 'eem 6/4/2008 15:58'! willStore "Answer whether the next bytecode is a store or store-pop" | byte | byte := self method at: pc. ^(byte between: 96 and: 142) and: [byte <= 111 "96 103 storeAndPopReceiverVariableBytecode" "104 111 storeAndPopTemporaryVariableBytecode" or: [byte >= 129 "129 extendedStoreBytecode" and: [byte <= 130 "130 extendedStoreAndPopBytecode" or: [(byte = 132 "132 doubleExtendedDoAnythingBytecode" and: [(self method at: pc+1) >= 160]) or: [byte = 141 "141 storeRemoteTempLongBytecode" or: [byte = 142 "142 storeAndPopRemoteTempLongBytecode"]]]]]]! ! !InstructionStream methodsFor: 'testing' stamp: 'eem 6/4/2008 15:56'! willStorePop "Answer whether the next bytecode is a store-pop." | byte | byte := self method at: pc. ^byte = 130 "130 extendedStoreAndPopBytecode" or: [byte = 142 "142 storeAndPopRemoteTempLongBytecode" or: [byte between: 96 and: 111 "96 103 storeAndPopReceiverVariableBytecode" "104 111 storeAndPopTemporaryVariableBytecode"]]! ! !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: 'private'! method: method pc: startpc sender := method. "allows this class to stand alone as a method scanner" pc := startpc! ! !InstructionStream methodsFor: 'private' stamp: 'StephaneDucasse 12/22/2010 17:20'! nextPc: currentByte "Answer the pc of the next bytecode following the current one, given the current bytecode.." | type | type := currentByte // 16. ^type = 8 "extensions" ifTrue: [pc + (#(2 2 2 2 3 2 2 1 1 1 2 1 3 3 3 4) at: currentByte \\ 16 + 1)] ifFalse: [type = 10 "long jumps" ifTrue: [pc + 2] ifFalse: [pc + 1]]! ! !InstructionStream methodsFor: 'private' stamp: 'ajh 8/1/2001 02:57'! pc: n pc := n! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! InstructionStream class instanceVariableNames: ''! !InstructionStream class methodsFor: 'class initialization'! 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: 'compiling' 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: 'compiling' stamp: 'eem 6/19/2008 10:00'! isContextClass ^false! ! !InstructionStream class methodsFor: 'instance creation'! on: method "Answer an instance of me on the argument, method." ^self new method: method pc: method initialPC! ! Number subclass: #Integer instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Numbers'! !Integer commentStamp: '' prior: 0! 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: '*AsmJit-Extension'! asAJOperand "Convert receiver into operand: a signed immediate" ^ AJImmediate new ivalue: self! ! !Integer methodsFor: '*AsmJit-Extension'! asByte ^ self asTwosComplement: 16rFF! ! !Integer methodsFor: '*AsmJit-Extension'! asDoubleWord ^ self asTwosComplement: 16rFFFFFFFF! ! !Integer methodsFor: '*AsmJit-Extension'! asImm "Convert integer value into a signed immediate operand" ^ AJImmediate new ivalue: self! ! !Integer methodsFor: '*AsmJit-Extension'! asImm16 "Convert integer value into a signed immediate word operand " ^ AJImmediate new ivalue: self; size: 2! ! !Integer methodsFor: '*AsmJit-Extension'! asImm32 "Convert integer value into a signed immediate operand" ^ AJImmediate new ivalue: self; size: 4! ! !Integer methodsFor: '*AsmJit-Extension'! asImm8 "Convert integer value into a signed immediate operand" ^ AJImmediate new ivalue: self; size: 1! ! !Integer methodsFor: '*AsmJit-Extension'! asQuadWord ^ self asTwosComplement: 16rFFFFFFFFFFFFFFFF! ! !Integer methodsFor: '*AsmJit-Extension'! 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'! asUImm "Convert integer value into an unsigned immediate operand" ^ AJImmediate new uvalue: self! ! !Integer methodsFor: '*AsmJit-Extension'! asUImm16 "Convert integer value into an unsigned immediate operand" ^ AJImmediate new uvalue: self; size: 2! ! !Integer methodsFor: '*AsmJit-Extension'! asUImm32 "Convert integer value into an unsigned immediate operand" ^ AJImmediate new uvalue: self; size: 4! ! !Integer methodsFor: '*AsmJit-Extension'! asUImm8 "Convert integer value into an unsigned immediate operand" ^ AJImmediate new uvalue: self; size: 1! ! !Integer methodsFor: '*AsmJit-Extension'! asWord ^ self asTwosComplement: 16rFFFF! ! !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: '*AsmJit-Extension'! isByte ^ self >= 0 and: [ self <= 255 ]! ! !Integer methodsFor: '*AsmJit-Extension'! printAsOperandOn: aStream aStream print: self.! ! !Integer methodsFor: '*FileSystem-Core' stamp: 'CamilloBruni 7/10/2012 22:12'! humanReadableSIByteSize ^ String streamContents: [ :s| self humanReadableSIByteSizeOn: s ]! ! !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: '*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: '*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: '*Kernel-Chronology' stamp: 'CamilloBruni 6/22/2012 21:42'! asSeconds ^ Duration seconds: self! ! !Integer methodsFor: '*Keymapping-Core' stamp: 'CamilloBruni 3/18/2011 23:16'! asShortcut ^ KMSingleKeyShortcut from: self asCharacter! ! !Integer methodsFor: '*Keymapping-Shortcuts' stamp: 'CamilloBruni 3/18/2011 23:14'! alt ^ KMModifier alt + self! ! !Integer methodsFor: '*Keymapping-Shortcuts' stamp: 'GuillermoPolito 5/31/2011 18:26'! command ^ KMModifier command + self! ! !Integer methodsFor: '*Keymapping-Shortcuts' stamp: 'CamilloBruni 3/18/2011 23:14'! ctrl ^ KMModifier ctrl + self! ! !Integer methodsFor: '*Keymapping-Shortcuts' stamp: 'CamilloBruni 3/18/2011 23:14'! shift ^ KMModifier shift + self! ! !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: '*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: '*Tools-Explorer' stamp: 'laza 3/17/2005 13:38'! hasContentsInExplorer ^true! ! !Integer methodsFor: '*Tools-Inspector' stamp: 'SvenVanCaekenberghe 11/26/2012 13:52'! inspectorClass ^ IntegerInspector ! ! !Integer methodsFor: '*metacello-core' stamp: 'dkh 8/13/2009 10:38'! metacelloIntegerLessThanSelf: anInteger ^anInteger < self! ! !Integer methodsFor: '*metacello-core' stamp: 'dkh 8/13/2009 12:04'! metacelloStringLessThanSelf: aString "string version components are always '<' integer component" ^true! ! !Integer methodsFor: '*metacello-core' stamp: 'dkh 8/13/2009 10:36'! metacelloVersionComponentLessThan: aMetacelloVersonComponent ^aMetacelloVersonComponent metacelloIntegerLessThanSelf: self! ! !Integer methodsFor: 'accessing' stamp: 'CamilloBruni 10/21/2012 14:07'! decimalDigitAt: anExponent ^ self digitAt: anExponent base: 10! ! !Integer methodsFor: 'accessing' stamp: 'CamilloBruni 10/21/2012 14:24'! decimalDigitLength ^ self numberOfDigitsInBase: 10! ! !Integer methodsFor: 'accessing' stamp: 'nice 9/7/2011 21:47'! denominator "Let an Integer be polymorphic to a Fraction. See #isFraction." ^1! ! !Integer methodsFor: 'accessing' stamp: 'CamilloBruni 10/21/2012 14:30'! digitAt: anExponent base: base ^ self // (base raisedToInteger: anExponent - 1) \\ base! ! !Integer methodsFor: 'accessing' stamp: 'nice 9/7/2011 21:47'! numerator "Let an Integer be polymorphic to a Fraction. See #isFraction." ^self! ! !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: '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: '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: 'arithmetic' stamp: 'di 11/6/1998 13:59'! + aNumber "Refer to the comment in Number + " aNumber isInteger ifTrue: [self negative == aNumber negative ifTrue: [^ (self digitAdd: aNumber) normalize] ifFalse: [^ self digitSubtract: aNumber]]. ^ aNumber adaptToInteger: self andSend: #+! ! !Integer methodsFor: 'arithmetic' stamp: 'di 11/6/1998 13:59'! - aNumber "Refer to the comment in Number - " aNumber isInteger ifTrue: [self negative == aNumber negative ifTrue: [^ self digitSubtract: aNumber] ifFalse: [^ (self digitAdd: aNumber) normalize]]. ^ aNumber adaptToInteger: self andSend: #-! ! !Integer methodsFor: 'arithmetic' stamp: 'StephaneDucasse 5/27/2010 22:08'! / aNumber "Refer to the comment in Number / " | quoRem | aNumber isInteger ifTrue: [quoRem := self digitDiv: aNumber abs 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: '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: 'arithmetic'! 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: '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: 'arithmetic' stamp: 'di 11/6/1998 14:00'! quo: aNumber "Refer to the comment in Number quo: " | ng quo | aNumber isInteger ifTrue: [ng := self negative == aNumber negative == false. quo := (self digitDiv: (aNumber class == SmallInteger ifTrue: [aNumber abs] ifFalse: [aNumber]) neg: ng) at: 1. ^ quo normalize]. ^ aNumber adaptToInteger: self andSend: #quo:! ! !Integer methodsFor: 'arithmetic' stamp: 'nice 9/2/2010 21:29'! 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: '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: '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: '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: 'bit manipulation' stamp: 'IgorStasenko 12/28/2012 15:10'! & aNumber ^ self bitAnd: aNumber! ! !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: '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: 'bit manipulation'! 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: '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: 'bit manipulation'! 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: '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: '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: '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: '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: '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: 'bit manipulation'! bitInvert32 "Answer the 32-bit complement of the receiver." ^ self bitXor: 16rFFFFFFFF! ! !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 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: '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: '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: '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: 'bit manipulation' stamp: 'sr 3/13/2000 17:47'! bitXor: n "Answer an Integer whose bits are the logical XOR of the receiver's bits and those of the argument, n." | norm | norm := n normalize. ^ self digitLogic: norm op: #bitXor: length: (self digitLength max: norm digitLength)! ! !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: '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: '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: 'bit manipulation'! 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: 'bit manipulation' stamp: 'CamilloBruni 3/27/2012 17:18'! | aNumber ^ self bitOr: aNumber! ! !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: #= 0] ifFalse: [^ (self digitCompare: aNumber) <= 0]] ifFalse: [^ self negative]]. ^ aNumber adaptToInteger: self andCompare: #<=! ! !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: '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: '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: '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: 'converting' stamp: 'ar 4/9/2005 22:31'! asCharacter "Answer the Character whose value is the receiver." ^Character value: self! ! !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: 'converting' stamp: 'nice 9/22/2011 01:39'! asFloat "Answer a Float that best approximates the value of the receiver." self subclassResponsibility! ! !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: 'ls 5/26/1998 20:53'! asHexDigit ^'0123456789ABCDEF' at: self+1! ! !Integer methodsFor: 'converting'! asInteger "Answer with the receiver itself." ^self ! ! !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: 'converting' stamp: 'brp 5/13/2003 10:12'! asYear ^ Year year: self ! ! !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: '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: '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: '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: 'enumerating'! 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: 'filter streaming' stamp: 'MarcusDenker 7/15/2012 15:47'! putOn: aStream (aStream isBinary ifTrue: [ self asByteArray ] ifFalse: [ self asString]) putOn: aStream ! ! !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: '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: 'mathematical functions'! lcm: n "Answer the least common multiple of the receiver and n." ^self // (self gcd: n) * n! ! !Integer methodsFor: 'mathematical functions' stamp: 'jmv 10/19/2011 22:39'! nthRoot: aPositiveInteger "Answer the nth root of the receiver. See #nthRootAlt: for an alternative implementation." | selfAsFloat floatResult guess delta higher lower raised | selfAsFloat := self asFloat. "If we can't do Float arithmetic because we are too big, then look for an exact answer in exact arithmetic" selfAsFloat isInfinite ifTrue: [ guess := self nthRootTruncated: aPositiveInteger. (guess raisedToInteger: aPositiveInteger) = self ifTrue: [ ^ guess ]. "Nothing else can be done. No exact answer means answer must be a Float. Answer the best we have." ^guess asFloat ]. floatResult := selfAsFloat nthRoot: aPositiveInteger. guess := floatResult rounded. "If got an exact answer, answer it." raised := guess raisedToInteger: aPositiveInteger. raised = self ifTrue: [ ^ guess ]. "In this case, maybe it failed because we are such a big integer that the Float method gets inexact, even if we are a whole square number. Note 1(jmv): This algorithm is faster than #nthRootTruncated: for big n (aPositiveInteger) but fails if self asFloat isInfinite. Note 2(jmv): The algorithms I found for computing the nthRoot would havily use very large fractions. I wrote this one, that doesn't create fractions." selfAsFloat abs >= (Float maxExactInteger asFloat raisedToInteger: aPositiveInteger) ifTrue: [ raised > self ifTrue: [ higher := guess. delta := floatResult predecessor - floatResult. [ floatResult := floatResult + delta. lower := floatResult rounded. (lower raisedToInteger: aPositiveInteger) > self ] whileTrue: [ delta := delta * 2. higher := lower ] ] ifFalse: [ lower := guess. delta := floatResult successor - floatResult. [ floatResult := floatResult + delta. higher := floatResult rounded. (higher raisedToInteger: aPositiveInteger) < self ] whileTrue: [ delta := delta * 2. lower := higher ]]. [ higher - lower > 1 ] whileTrue: [ guess := lower + higher // 2. raised := guess raisedToInteger: aPositiveInteger. raised = self ifTrue: [ ^ guess ]. raised > self ifTrue: [ higher := guess ] ifFalse: [ lower := guess ]]]. "We need an approximate result" ^floatResult! ! !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: '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: '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: '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: '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: 'printing' stamp: 'CamilloBruni 10/21/2012 14:04'! asStringWithCommas "123456789 asStringWithCommas" "-123456789 asStringWithCommas" ^ String streamContents: [:stream | self printWithCommasOn: stream ]! ! !Integer methodsFor: 'printing' stamp: 'CamilloBruni 10/21/2012 13:50'! asStringWithCommasSigned "123456789 asStringWithCommasSigned" "-123456789 asStringWithCommasSigned" ^ String streamContents: [:stream | self printWithCommasSignedOn: stream ]! ! !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: '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: 'printing' stamp: 'MPW 1/1/1901 00:14'! destinationBuffer:digitLength digitLength <= 1 ifTrue: [self] ifFalse: [LargePositiveInteger new: digitLength].! ! !Integer methodsFor: 'printing' stamp: 'MPW 1/1/1901 00:16'! digitBuffer:digitLength ^Array new:digitLength*8.! ! !Integer methodsFor: 'printing'! isLiteral ^true! ! !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: '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: 'printing' stamp: 'nice 2/15/2008 21:49'! printOn: aStream ^self printOn: aStream base: 10! ! !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: '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: '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' 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' stamp: 'CamilloBruni 10/21/2012 14:42'! 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: $, ]]! ! !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: '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: '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: 'printing' stamp: 'CamilloBruni 10/21/2012 13:59'! printWithCommasOn: aStream "123456789 asStringWithCommas" "-123456789 asStringWithCommas" ^ self printSeparatedBy: $, every: 3 signed: false on: aStream! ! !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: '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: '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: '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: '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: 'laza 3/29/2004 18:21'! printStringLength: minimal ^self printStringLength: minimal padded: false ! ! !Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 18:20'! printStringLength: minimal padded: zeroFlag ^self printStringBase: 10 length: minimal padded: zeroFlag! ! !Integer methodsFor: 'printing-numerative' stamp: 'laza 3/29/2004 18:20'! printStringPadded: minimal ^self printStringLength: minimal padded: true ! ! !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: 'printing-numerative' stamp: 'laza 3/29/2004 13:35'! radix: base ^ self printStringBase: base! ! !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-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: '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: 'laza 3/29/2004 10:58'! storeStringHex ^self storeStringBase: 16! ! !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: 'system primitives'! 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: 'testing'! even "Refer to the comment in Number|even." ^((self digitAt: 1) bitAnd: 1) = 0! ! !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: 'testing'! isInteger "True for all subclasses of Integer." ^ true! ! !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: '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: '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: '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: '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: '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: '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: 'truncation and round off' stamp: 'ar 6/9/2000 18:56'! asPowerOfTwo "Convert the receiver into a power of two" ^self asSmallerPowerOfTwo! ! !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: '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: '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: 'truncation and round off'! ceiling "Refer to the comment in Number|ceiling."! ! !Integer methodsFor: 'truncation and round off'! floor "Refer to the comment in Number|floor."! ! !Integer methodsFor: 'truncation and round off'! normalize "SmallInts OK; LgInts override" ^ self! ! !Integer methodsFor: 'truncation and round off' stamp: 'GuillermoPolito 6/22/2012 14:49'! round: numberOfWishedDecimal ^self! ! !Integer methodsFor: 'truncation and round off'! rounded "Refer to the comment in Number|rounded."! ! !Integer methodsFor: 'truncation and round off'! truncated "Refer to the comment in Number|truncated."! ! !Integer methodsFor: 'private'! copyto: x | stop | stop := self digitLength min: x digitLength. ^ x replaceFrom: 1 to: stop with: self startingAt: 1! ! !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: '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: '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: '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: '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: '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: 'private'! 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: '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: 'private'! growby: n ^self growto: self digitLength + n! ! !Integer methodsFor: 'private'! growto: n ^self copyto: (self species new: n)! ! !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: '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: '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: '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: 'private' stamp: 'StephaneDucasse 2/12/2012 14:57'! 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 class instanceVariableNames: ''! !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: 'compatibility' stamp: 'laza 10/16/2004 14:34'! readFrom: aStream radix: radix ^self readFrom: aStream base: radix! ! !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: '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: '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: 'instance creation'! 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: '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: 'GuillermoPolito 8/24/2010 18:48'! 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." ^(SqNumberParser on: aStringOrStream) nextIntegerBase: base! ! !Integer class methodsFor: 'instance creation' stamp: 'nice 3/15/2008 01:09'! 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." ^(SqNumberParser on: aStringOrStream) nextIntegerBase: 10 ifFail: aBlock! ! !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 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'! 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: '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]]. ! ! !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: '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 ] ] ]! ! AbstractApiSetter subclass: #IntegerApiSetter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Spec-Tools-Editor'! !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: '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 ! ! !IntegerApiSetter methodsFor: 'private' stamp: 'BenjaminVanRyseghem 7/13/2012 04:30'! updateSliderWith: aMethod | prg min max old | prg := aMethod pragmas detect: [:e | e keyword beginsWith: 'api:' ] ifNone: [ ^ self ]. min := prg arguments second. max := prg arguments third. " old := self model perform: prg arguments fourth." 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) ]. "self isSetting ifFalse:[ self isSetting: true. choice value: old. self isSetting: false ]"! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! IntegerApiSetter class instanceVariableNames: ''! !IntegerApiSetter class methodsFor: 'as yet unclassified' stamp: 'BenjaminVanRyseghem 7/12/2012 19:44'! spec ^ SpecLayout composed newRow: [:r | r add: #selector; newColumn: [:c | c add: #choice ] width: 75] height: 25; yourself! ! ArrayedCollection variableWordSubclass: #IntegerArray instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Native'! !IntegerArray commentStamp: '' prior: 0! IntegerArrays store 32bit signed Integer values. Negative values are stored as 2's complement.! !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 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 23:34'! atAllPut: anInteger | word | anInteger < 0 ifTrue:["word := 16r100000000 + anInteger" word := (anInteger + 1) negated bitInvert32] ifFalse:[word := anInteger]. self primFill: word.! ! !IntegerArray methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:19'! defaultElement "Return the default element of the receiver" ^0! ! !IntegerArray methodsFor: 'converting' stamp: 'ar 10/10/1998 16:18'! asIntegerArray ^self! ! !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.! ! TestCase subclass: #IntegerArrayTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Arrayed'! !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:59'! testPutAllNegative | array | array := IntegerArray new: 2. array atAllPut: -1000. self assert: (array at: 2) = -1000! ! !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! ! TestCase subclass: #IntegerDigitLogicTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Numbers'! !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: '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).]]! ! !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: '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'! 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: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'! 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]. ! ! ComposableModel subclass: #IntegerEditor instanceVariableNames: 'integer slider text' classVariableNames: '' poolDictionaries: '' category: 'Spec-Tools-Editor'! !IntegerEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/12/2012 19:33'! integer ^ integer contents! ! !IntegerEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/12/2012 19:33'! integer: aBlock integer contents: aBlock ! ! !IntegerEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/12/2012 19:34'! slider ^ slider! ! !IntegerEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/12/2012 19:33'! text ^ text! ! !IntegerEditor methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 7/13/2012 05:34'! initializeWidgets self instantiateModels: #( slider SliderModel text LabelModel ). text borderWidth: 4; borderColor: Color black; text: '0'. slider quantum: 1; whenValueChangedDo: [:v | integer contents: v. text text: v asString ]. self focusOrder add: slider; add: text! ! !IntegerEditor methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 7/12/2012 19:36'! initialize "Initialization code for BlocEditor" super initialize. integer := 0 asValueHolder! ! !IntegerEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/12/2012 19:33'! buildWithSpec ^ self buildWithSpecLayout: self layout! ! !IntegerEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/12/2012 19:33'! buildWithSpec: aSpec ^ self buildWithSpecLayout: self layout! ! !IntegerEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/12/2012 19:38'! help: aString slider help: aString ! ! !IntegerEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/12/2012 19:38'! max: aNumber slider max: aNumber! ! !IntegerEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 18:52'! min: aNumber slider min: aNumber! ! !IntegerEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/12/2012 19:38'! value: aNumber slider value: aNumber! ! !IntegerEditor methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/12/2012 19:38'! whenIntegerChangedDo: aBlock integer whenChangedDo: aBlock ! ! !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! ! Inspector subclass: #IntegerInspector instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tools-Inspector'! !IntegerInspector commentStamp: '' prior: 0! I am IntegerInspector. I am an Inspector. I am a specialized Inspector for Integers. I add extra representations (hex, octal, binary) of the Integer object that I am inspecting.! !IntegerInspector methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 11/26/2012 14:08'! binary "Answer a binary representation of the Integer object I am inspecting" ^ self printStringBase: 2! ! !IntegerInspector methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 11/26/2012 14:07'! fieldList "Answer the base field list plus our custom representations." ^ self baseFieldList , self representations! ! !IntegerInspector methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 11/26/2012 14:08'! hex "Answer a hexadecimal representation of the Integer object I am inspecting" ^ self printStringBase: 16! ! !IntegerInspector methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 11/26/2012 14:08'! octal "Answer an octal representation of the Integer object I am inspecting" ^ self printStringBase: 8! ! !IntegerInspector methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 11/26/2012 14:09'! printStringBase: base "Answer a representation of the Integer object I am inspecting in the given base." ^ String streamContents: [ :stream | object printOn: stream base: base showRadix: true ]! ! !IntegerInspector methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 11/26/2012 14:09'! representations "Return the list of representations that I support. For each of these there must be a corresponding method." ^ #( hex octal binary )! ! !IntegerInspector methodsFor: 'selecting' stamp: 'SvenVanCaekenberghe 11/26/2012 14:19'! replaceSelectionValue: anObject "The receiver has a list of variables of its inspected object. One of these is selected. The value of the selected variable is set to the value, anObject." selectionIndex <= self numberOfFixedFields ifTrue: [ ^ super replaceSelectionValue: anObject ] "My own fields are readonly"! ! !IntegerInspector methodsFor: 'selecting' stamp: 'SvenVanCaekenberghe 11/26/2012 14:03'! selection "The receiver has a list of variables of its inspected object. One of these is selected. Answer the value of the selected variable." ^ self selectionIndex <= self numberOfFixedFields ifTrue: [ super selection ] ifFalse: [ self perform: (self representations at: self selectionIndex - self numberOfFixedFields) ]! ! TestCase subclass: #IntegerTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Numbers'! !IntegerTest methodsFor: 'test - rounding' stamp: 'GuillermoPolito 6/22/2012 14:52'! testRounding " self debug: #testRounding " self assert: (5 round: 2) equals: 5! ! !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: '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: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 - 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 - basic' stamp: 'md 4/21/2003 16:17'! testEven self deny: (1073741825 even). self assert: (1073741824 even). ! ! !IntegerTest methodsFor: 'tests - basic' stamp: 'sd 6/5/2005 08:45'! testIsInteger self assert: (0 isInteger). ! ! !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 - 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: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 - 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 - 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 - 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 - 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 - 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 - 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 - 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 - 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: '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 - 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: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 - 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 - 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 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 - 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 - 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 - 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 - 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 - 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 - 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 - 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 - 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 - 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 - 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: '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 - 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 - instance creation' stamp: 'StephaneDucasse 6/9/2012 22:58'! testNew self should: [Integer new] raise: self defaultTestError. ! ! !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: '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 - 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/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/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 - mathematical functions' stamp: 'nice 10/31/2010 21:50'! testDegreeCos "self run: #testDegreeCos" self shouldnt: [ 45 degreeCos] raise: Error. "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: 'tests - mathematical functions' stamp: 'nice 10/31/2010 21:39'! testDegreeSin "self run: #testDegreeSin" self shouldnt: [ 45 degreeSin] raise: Error. "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: '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 - 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 - 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 - 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: 'nice 10/19/2011 20:28'! testNthRoot self shouldnt: [ (1 << 2000 nthRoot: 100) ] raise: ArithmeticError. self assert: (1 << 2000 nthRoot: 100) equals: 1 << 20! ! !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.! ! !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: '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 - mathematical functions' stamp: 'jmv 10/13/2011 21:46'! testSqrtErrorConditions " IntegerTest new testSqrtErrorConditions " self should: [ -1 sqrt ] raise: ArithmeticError! ! !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 - 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 - 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 - 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 - 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 - 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 - 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 - 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 - 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 - 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 - 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 - 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: 'private' stamp: 'jmv 10/11/2011 08:14'! assert: a classAndValueEquals: b self assert: a class = b class. self assert: a = b! ! FileSystemResolver subclass: #InteractiveResolver instanceVariableNames: 'cache' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Core-Implementation'! !InteractiveResolver commentStamp: 'cwp 11/18/2009 11:56' prior: 0! I resolve origins by consulting the user. I maintain a cache of the user's responses.! !InteractiveResolver methodsFor: 'accessing' stamp: 'cwp 10/27/2009 10:29'! flushLocalCache cache := IdentityDictionary new! ! !InteractiveResolver methodsFor: 'initialize-release' stamp: 'cwp 10/27/2009 10:29'! initialize self flushLocalCache! ! !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]]! ! FileSystemResolverTest subclass: #InteractiveResolverTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Tests-Core'! !InteractiveResolverTest methodsFor: 'accessing' stamp: 'EstebanLorenzano 4/12/2012 14:26'! home ^ FileLocator imageDirectory resolve! ! !InteractiveResolverTest methodsFor: 'running' stamp: 'EstebanLorenzano 4/2/2012 11:38'! createResolver ^ InteractiveResolver new! ! !InteractiveResolverTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:38'! testCached [resolver resolve: #home] on: ResolutionRequest do: [:req | req resume: self home]. self shouldnt: [self assertOriginResolves: #home] raise: ResolutionRequest! ! !InteractiveResolverTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:38'! testNew [self assertOriginResolves: #home] on: ResolutionRequest do: [:req | req resume: self home]. ! ! Object subclass: #InternetConfiguration instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Network-Kernel'! !InternetConfiguration commentStamp: 'LaurentLaffont 6/8/2011 22:17' prior: 0! 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 instanceVariableNames: ''! !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:05'! getArchiePreferred "Return the preferred Archie server" "InternetConfiguration getArchiePreferred" ^self primitiveGetStringKeyedBy: 'ArchiePreferred' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 17:31'! getDownloadPath "Return the download path" "InternetConfiguration getDownloadPath" ^self primitiveGetStringKeyedBy: 'DownLoadPath' ! ! !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:08'! getFTPHost "Return the FTPHost" "InternetConfiguration getFTPHost" ^self primitiveGetStringKeyedBy: 'FTPHost' ! ! !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 9/26/2001 20:00'! getFTPProxyHost "Return the FTP proxy host" "InternetConfiguration getFTPProxyHost" ^self primitiveGetStringKeyedBy: 'FTPProxyHost' ! ! !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'! getFTPProxyUser "Return the first level FTP proxy authorisation" "InternetConfiguration getFTPProxyUser" ^self primitiveGetStringKeyedBy: 'FTPProxyUser' ! ! !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:11'! getGopherHost "Return the default Gopher server" "InternetConfiguration getGopherHost" ^self primitiveGetStringKeyedBy: 'GopherHost' ! ! !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 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' ! ! !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:15'! getLDAPServer "Return the LDAP server" "InternetConfiguration getLDAPServer" ^self primitiveGetStringKeyedBy: 'LDAPServer' ! ! !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 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:16'! getNNTPHost "Return the NNTP server" "InternetConfiguration getNNTPHost" ^self primitiveGetStringKeyedBy: 'NNTPHost' ! ! !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: '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: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 19:36'! getOrganization "Return the Organization" "InternetConfiguration getOrganization" ^self primitiveGetStringKeyedBy: 'Organization' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 19:37'! getPhHost "Return the PhHost server" "InternetConfiguration getPhHost" ^self primitiveGetStringKeyedBy: 'PhHost' ! ! !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 17:19'! getSMTPHost "Return the SMTP server" "InternetConfiguration getSMTPHost" ^self primitiveGetStringKeyedBy: 'SMTPHost' ! ! !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:20'! getTelnetHost "Return the TelnetHost server" "InternetConfiguration getTelnetHost" ^self primitiveGetStringKeyedBy: 'TelnetHost' ! ! !InternetConfiguration class methodsFor: 'lookups' stamp: 'JMM 9/26/2001 19:44'! getWAISGateway "Return the wais gateway" "InternetConfiguration getWAISGateway" ^self primitiveGetStringKeyedBy: 'WAISGateway' ! ! !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 9/26/2001 17:23'! getWhoisHost "Return the WhoisHost server" "InternetConfiguration getWhoisHost" ^self primitiveGetStringKeyedBy: 'WhoisHost' ! ! !InternetConfiguration class methodsFor: 'system primitives' stamp: 'JMM 10/5/2001 23:44'! primitiveGetMacintoshFileTypeAndCreatorFrom: aFileName ^'********' copy ! ! !InternetConfiguration class methodsFor: 'system primitives' stamp: 'JMM 9/26/2001 16:31'! primitiveGetStringKeyedBy: aKey ^String new. ! ! !InternetConfiguration class methodsFor: 'system startup' stamp: 'MarcusDenker 6/30/2011 08:38'! shutDown OSPlatform isMacOS ifTrue: [ NetworkSystemSettings useHTTPProxy: false ] ! ! !InternetConfiguration class methodsFor: 'system startup' stamp: 'SvenVanCaekenberghe 6/29/2011 14:25'! startUp OSPlatform 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: 'tests' stamp: 'JMM 10/5/2001 11:23'! useFTPProxy "Return true if UseFTPProxy" "InternetConfiguration useFTPProxy" ^(self primitiveGetStringKeyedBy: 'UseFTPProxy') = '1' ! ! !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: 'tests' stamp: 'JMM 9/26/2001 19:41'! useHTTPProxy "Return true if UseHTTPProxy" "InternetConfiguration useHTTPProxy" ^(self primitiveGetStringKeyedBy: 'UseHTTPProxy') = '1' ! ! !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'! useSocks "Return true if UseSocks" "InternetConfiguration useSocks" ^(self primitiveGetStringKeyedBy: 'UseSocks') = '1' ! ! GradientFillStyle subclass: #InterpolatedGradientFillStyle instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Balloon-Fills'! !InterpolatedGradientFillStyle commentStamp: 'gvc 5/18/2007 12:49' prior: 0! Gradient fill style that uses proper alpha-aware interpolation.! !InterpolatedGradientFillStyle methodsFor: 'as yet unclassified' stamp: 'nice 1/5/2010 15:59'! 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 := lastColor pixelWord32. 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: '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)! ! SequenceableCollection subclass: #Interval instanceVariableNames: 'start stop step' classVariableNames: '' poolDictionaries: '' category: 'Collections-Sequenceable'! !Interval commentStamp: '' prior: 0! I represent a finite arithmetic progression.! !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: 'accessing'! at: anInteger "Answer the anInteger'th element." (anInteger >= 1 and: [anInteger <= self size]) ifTrue: [^start + (step * (anInteger - 1))] ifFalse: [self errorSubscriptBounds: anInteger]! ! !Interval methodsFor: 'accessing'! at: anInteger put: anObject "Storing into an Interval is not allowed." self error: 'you can not store into an interval'! ! !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: 'accessing'! first "Refer to the comment in SequenceableCollection|first." ^start! ! !Interval methodsFor: 'accessing'! increment "Answer the receiver's interval increment." ^step! ! !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: 'accessing'! last "Refer to the comment in SequenceableCollection|last." ^stop - (stop - start \\ step)! ! !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: 'adding'! add: newObject "Adding to an Interval is not allowed." self shouldNotImplement! ! !Interval methodsFor: 'arithmetic' stamp: 'ajh 3/13/2003 15:45'! + number ^ start + number to: stop + number by: step! ! !Interval methodsFor: 'arithmetic' stamp: 'ajh 3/13/2003 15:46'! - number ^ start - number to: stop - number by: step! ! !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: 'comparing'! hash "Hash is reimplemented because = is implemented." ^(((start hash bitShift: 2) bitOr: stop hash) bitShift: 1) bitOr: self size! ! !Interval methodsFor: 'enumerating'! 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: '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: '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: '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: '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: '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: 'removing'! remove: newObject "Removing from an Interval is not allowed." self error: 'elements cannot be removed from an Interval'! ! !Interval methodsFor: 'self evaluating' stamp: 'sd 7/31/2005 22:03'! isSelfEvaluating ^ self class == Interval! ! !Interval methodsFor: 'testing' stamp: 'rhi 8/12/2003 09:52'! isInterval ^ true! ! !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: 'private'! setFrom: startInteger to: stopInteger by: stepInteger start := startInteger. stop := stopInteger. step := stepInteger! ! !Interval methodsFor: 'private'! species ^Array! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Interval class instanceVariableNames: ''! !Interval class methodsFor: 'accessing' stamp: 'CamilloBruni 9/5/2011 15:37'! streamSpecies ^ Array! ! !Interval class methodsFor: 'instance creation'! 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: 'instance creation'! 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! ! !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. "! ! CollectionRootTest subclass: #IntervalTest uses: TCloneTest + TIncludesWithIdentityCheckTest + TSequencedElementAccessTest + TIterateSequencedReadableTest + TSequencedConcatenationTest + TSubCollectionAccess + TAsStringCommaAndDelimiterSequenceableTest + TIndexAccess + TPrintOnSequencedTest + TConvertTest + TCopySequenceableWithReplacement - {#testCopyReplaceAllWithManyOccurence. #collectionWith2TimeSubcollection} + TCopySequenceableWithOrWithoutSpecificElements + TCopySequenceableSameContents - {#testShuffled} + TCopyPartOfSequenceable - {#testCopyEmptyMethod} + TCopyTest + TBeginsEndsWith + TConvertAsSortedTest + TSequencedStructuralEqualityTest + TOccurrencesTest instanceVariableNames: 'empty nonEmpty one elementIn elementNotIn subCollectionNotIn collectionOfFloat anotherCollection nonEmpty1Element subCollection collectionWithSubCollection subCollectionInNonEmpty collectionWithoutNil collectResult' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Sequenceable'! !IntervalTest methodsFor: 'as yet unclassified'! 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: 'as yet unclassified'! testStreamContentsProtocol | result index | result:= self collectionClass << [ :s| s nextPutAll: self firstCollection; nextPutAll: self secondCollection ]. self assert: result equals: self firstCollection, self secondCollection.! ! !IntervalTest methodsFor: 'as yet unclassified'! 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: 'requirements' stamp: 'damiencassou 1/27/2009 17:21'! accessCollection ^ -2 to: 14 by: 4! ! !IntervalTest methodsFor: 'requirements' stamp: 'stephane.ducasse 11/21/2008 15:39'! anotherElementNotIn ^ 42! ! !IntervalTest methodsFor: 'requirements' stamp: 'damienpollet 1/29/2009 18:55'! collection ^ nonEmpty! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 16:36'! collectionClass ^ Interval! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 09:51'! collectionInForIncluding ^ nonEmpty copyWithout: (self nonEmpty last).! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 15:15'! collectionMoreThan1NoDuplicates " return a collection of size 5 without equal elements" ^ nonEmpty ! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 15:35'! collectionNotIncluded ^ (nonEmpty last + 1) to: (nonEmpty last +5)! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 14:10'! collectionOfFloat ^collectionOfFloat ! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 14:44'! collectionWith1TimeSubcollection ^ collectionWithSubCollection ! ! !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: 'requirements' stamp: 'delaunay 4/17/2009 15:32'! collectionWithElementsToRemove ^ subCollectionInNonEmpty .! ! !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: 'requirements' stamp: 'CamilloBruni 9/9/2011 12:11'! collectionWithoutEqualElements ^ nonEmpty ! ! !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: 'requirements' stamp: 'damienpollet 1/29/2009 18:59'! doWithoutNumber ^ 6! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 14:22'! elementInCollectionOfFloat ^ collectionOfFloat anyOne! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 14:40'! elementInForElementAccessing " return an element inculded in 'accessCollection '" ^ self accessCollection anyOne! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 09:47'! elementInForIncludesTest ^ elementIn ! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 15:03'! elementInForIndexAccess ^ self accessCollection anyOne! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 09:48'! elementInForIndexAccessing ^ elementIn ! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 09:48'! elementNotIn ^elementNotIn! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 14:43'! elementNotInForElementAccessing " return an element not included in 'accessCollection' " ^ elementNotIn ! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 09:48'! elementNotInForIndexAccessing ^elementNotIn ! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/2/2009 11:53'! elementNotInForOccurrences ^ 9! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 15:27'! elementToAdd ^ elementNotIn ! ! !IntervalTest methodsFor: 'requirements' stamp: 'stephane.ducasse 10/5/2008 13:08'! empty ^ empty ! ! !IntervalTest methodsFor: 'requirements' stamp: 'marcus.denker 2/20/2009 16:30'! expectedElementByDetect "Returns the first even element of #collection" ^ -2 ! ! !IntervalTest methodsFor: 'requirements' stamp: 'damienpollet 1/29/2009 19:01'! expectedSizeAfterReject "Number of even elements in #collection" ^ 3! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 14:55'! firstCollection ^ nonEmpty.! ! !IntervalTest methodsFor: 'requirements' stamp: 'damienpollet 1/29/2009 18:57'! firstEven "Returns the first even number of #collection" ^ -2! ! !IntervalTest methodsFor: 'requirements' stamp: 'damienpollet 1/29/2009 18:58'! firstOdd "Returns the first odd number of #collection" ^ -5! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 15:14'! indexInForCollectionWithoutDuplicates ^ 2.! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 15:02'! indexInNonEmpty ^2.! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 15:04'! integerCollection ^ nonEmpty ! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 10:31'! integerCollectionWithoutEqualElements ^ 1 to: 23.! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:51'! moreThan3Elements " return a collection including atLeast 3 elements" ^ nonEmpty ! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:51'! moreThan4Elements " return a collection including at leat 4 elements" ^ nonEmpty ! ! !IntervalTest methodsFor: 'requirements' stamp: 'stephane.ducasse 10/5/2008 13:08'! nonEmpty ^ nonEmpty! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 15:00'! nonEmpty1Element ^ nonEmpty1Element ! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 14:46'! nonEmptyMoreThan1Element ^nonEmpty .! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 14:44'! oldSubCollection ^ subCollection ! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/17/2009 14:45'! replacementCollection ^ 5 to: 7.! ! !IntervalTest methodsFor: 'requirements' stamp: 'damienpollet 1/29/2009 18:57'! result ^ {SmallInteger . SmallInteger . SmallInteger . SmallInteger . SmallInteger . SmallInteger}! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 14:56'! secondCollection ^anotherCollection ! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 10:07'! sizeCollection "Answers a collection whose #size is 4" ^ 1 to: 4.! ! !IntervalTest methodsFor: 'requirements' stamp: 'damiencassou 1/27/2009 17:25'! speciesClass ^ Array! ! !IntervalTest methodsFor: 'requirements' stamp: 'delaunay 4/15/2009 09:52'! subCollectionNotIn ^subCollectionNotIn ! ! !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: 'test - equality'! testEqualSign "self debug: #testEqualSign" self deny: (self empty = self nonEmpty).! ! !IntervalTest methodsFor: 'test - equality'! 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: 'test - equality'! 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: 'test - equality'! testEqualSignOfIdenticalCollectionObjects "self debug: #testEqualSignOfIdenticalCollectionObjects" self assert: (self empty = self empty). self assert: (self nonEmpty = self nonEmpty). ! ! !IntervalTest methodsFor: 'tests' stamp: 'zz 12/5/2005 18:23'! testAdd self assert: (1 to: 10) + 5 = (6 to: 15)! ! !IntervalTest methodsFor: 'tests' stamp: 'StephaneDucasse 2/2/2010 12:14'! testAsInterval "This is the same as newFrom:" "self run: #testAsIntervaltestAsInterval" self shouldnt: [ 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). ] raise: Error. self should: [#(33 5 -22) as: Interval] raise: Error description: 'This is not an arithmetic progression' ! ! !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: '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' 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' stamp: 'md 10/12/2003 20:13'! testEquals self shouldnt: [ 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). ] raise: MessageNotUnderstood.! ! !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' 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' 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: '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' 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: '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' 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: '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' 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' 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' stamp: 'jb 7/1/2011 10:52'! 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 evaluatorClass evaluate: interval1 storeString. self assert: interval1 size = interval2 size! ! !IntervalTest methodsFor: 'tests'! 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' stamp: 'zz 12/5/2005 18:11'! testIsEvaluating self assert: (1 to: 10) isSelfEvaluating. self assert: (1 to: 10 by: 2) isSelfEvaluating! ! !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' 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: 'tests' stamp: 'zz 12/5/2005 18:28'! testMinus self assert: (1 to: 10) - 5 = (-4 to: 5)! ! !IntervalTest methodsFor: 'tests' stamp: 'md 1/14/2004 11:43'! testNewFrom self shouldnt: [ 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)) . ] raise: Error.! ! !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' 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: '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: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' 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: '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' 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 - as sorted collection' stamp: 'hfm 4/2/2010 13:37'! 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: 'tests - as sorted collection'! 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 - as sorted collection'! 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 - begins ends with'! 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: 'tests - begins ends with'! testsBeginsWithEmpty self deny: (self nonEmpty beginsWith:(self empty)). self deny: (self empty beginsWith:(self nonEmpty )). ! ! !IntervalTest methodsFor: 'tests - begins ends with'! 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 - begins ends with'! testsEndsWithEmpty self deny: (self nonEmpty endsWith: self empty). self deny: (self empty endsWith: self nonEmpty). ! ! !IntervalTest methodsFor: 'tests - comma and delimiter'! testAsCommaStringEmpty self assert: self empty asCommaString = ''. self assert: self empty asCommaStringAnd = ''. ! ! !IntervalTest methodsFor: 'tests - comma and delimiter'! 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 - comma and delimiter'! 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 - comma and delimiter'! testAsStringOnDelimiterEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim. self assert: emptyStream contents = ''. ! ! !IntervalTest methodsFor: 'tests - comma and delimiter'! testAsStringOnDelimiterLastEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim last:'and'. self assert: emptyStream contents = ''. ! ! !IntervalTest methodsFor: 'tests - comma and delimiter'! 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: 'tests - comma and delimiter'! 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 - comma and delimiter'! 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 - comma and delimiter'! 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: 'tests - concatenation'! 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 - concatenation'! 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: 'tests - converting'! 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: 'tests - converting'! 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 - converting'! assertSameContents: aCollection whenConvertedTo: aClass | result | result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass. self assert: result size = aCollection size! ! !IntervalTest methodsFor: 'tests - converting'! testAsArray "self debug: #testAsArray3" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Array! ! !IntervalTest methodsFor: 'tests - converting'! testAsBag self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! ! !IntervalTest methodsFor: 'tests - converting'! testAsByteArray | res | self shouldnt: [self integerCollectionWithoutEqualElements ] raise: Error. 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'! testAsIdentitySet "test with a collection without equal elements :" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: IdentitySet. ! ! !IntervalTest methodsFor: 'tests - converting'! testAsOrderedCollection self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! ! !IntervalTest methodsFor: 'tests - converting'! testAsSet | | "test with a collection without equal elements :" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Set. ! ! !IntervalTest methodsFor: 'tests - copy'! 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 - copy' stamp: 'delaunay 4/17/2009 15:26'! 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 - copy' stamp: 'delaunay 4/17/2009 15:24'! 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 - copy'! 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'! 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 - copy'! 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: 'delaunay 4/17/2009 15:24'! 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 - copy'! 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 - copy' stamp: 'delaunay 4/17/2009 15:26'! 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 - copy'! 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 - copy'! 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 - copy - clone'! testCopyCreatesNewObject "self debug: #testCopyCreatesNewObject" | copy | copy := self nonEmpty copy. self deny: self nonEmpty == copy. ! ! !IntervalTest methodsFor: 'tests - copy - clone'! testCopyEmpty "self debug: #testCopyEmpty" | copy | copy := self empty copy. self assert: copy isEmpty.! ! !IntervalTest methodsFor: 'tests - copy - clone'! 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 - copying part of sequenceable'! 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: 'tests - copying part of sequenceable'! testCopyAfterEmpty | result | result := self empty copyAfter: self collectionWithoutEqualElements first. self assert: result isEmpty. ! ! !IntervalTest methodsFor: 'tests - copying part of sequenceable'! 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 - copying part of sequenceable'! testCopyAfterLastEmpty | result | result := self empty copyAfterLast: self collectionWithoutEqualElements first. self assert: result isEmpty.! ! !IntervalTest methodsFor: 'tests - copying part of sequenceable'! 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 - copying part of sequenceable'! 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 - copying part of sequenceable'! testCopyUpToEmpty | result | result := self empty copyUpTo: self collectionWithoutEqualElements first. self assert: result isEmpty. ! ! !IntervalTest methodsFor: 'tests - copying part of sequenceable'! 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: 'tests - copying part of sequenceable'! testCopyUpToLastEmpty | result | result := self empty copyUpToLast: self collectionWithoutEqualElements first. self assert: result isEmpty.! ! !IntervalTest methodsFor: 'tests - copying same contents'! 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 - copying same contents'! 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 - copying same contents'! 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 - copying same contents'! testShallowCopyEmpty | result | result := self empty shallowCopy . self assert: result isEmpty .! ! !IntervalTest methodsFor: 'tests - copying with or without'! 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: 'tests - copying with or without'! 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 - copying with or without'! 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 - copying with or without'! 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 with or without'! 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: 'tests - copying with or without'! 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 - copying with replacement'! firstIndexesOf: subCollection 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: subCollection) ifTrue: [ result add: currentIndex. 1 to: subCollection size do: [:i | tmp := tmp copyWithoutFirst. currentIndex := currentIndex + 1] ] ifFalse: [ tmp := tmp copyWithoutFirst. currentIndex := currentIndex +1. ] ]. ^ result. ! ! !IntervalTest methodsFor: 'tests - copying with replacement'! 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 - copying with replacement'! 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 - copying with replacement'! 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 - element accessing'! 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 - element accessing'! 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 - element accessing'! 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 - element accessing'! 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: 'tests - element accessing'! 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 - element accessing'! testAtLastError "self debug: #testAtLast" self should: [ self moreThan4Elements atLast: self moreThan4Elements size + 1 ] raise: Error! ! !IntervalTest methodsFor: 'tests - element accessing'! 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 - element accessing'! 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 - element accessing'! 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 - element accessing'! testAtRandom | result | result := self nonEmpty atRandom . self assert: (self nonEmpty includes: result).! ! !IntervalTest methodsFor: 'tests - element accessing'! 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 - element accessing'! 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 - element accessing'! 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 - element accessing'! testMiddle "self debug: #testMiddle" self assert: self moreThan4Elements middle = (self moreThan4Elements at: self moreThan4Elements size // 2 + 1)! ! !IntervalTest methodsFor: 'tests - equality'! 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: 'tests - equality'! 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: 'tests - equality'! 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: 'tests - equality'! testHasEqualElementsOfIdenticalCollectionObjects "self debug: #testHasEqualElementsOfIdenticalCollectionObjects" self assert: (self empty hasEqualElements: self empty). self assert: (self nonEmpty hasEqualElements: self nonEmpty). ! ! !IntervalTest methodsFor: 'tests - fixture'! howMany: subCollection in: collection " return an integer representing how many time 'subCollection' appears in 'collection' " | tmp nTime | tmp:= collection. nTime:= 0. [tmp isEmpty ]whileFalse: [ (tmp beginsWith: subCollection) ifTrue: [ nTime := nTime + 1. 1 to: subCollection size do: [:i | tmp := tmp copyWithoutFirst.] ] ifFalse: [tmp := tmp copyWithoutFirst.] ]. ^ nTime. ! ! !IntervalTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/17/2009 15:26'! test0CopyTest self shouldnt: [ self empty ] raise: Error. self assert: self empty size = 0. self shouldnt: [ self nonEmpty ] raise: Error. self assert: (self nonEmpty size = 0) not. self shouldnt: [ self collectionWithElementsToRemove ] raise: Error. self assert: (self collectionWithElementsToRemove size = 0) not. self shouldnt: [ self elementToAdd ] raise: Error. self shouldnt: [ self collectionNotIncluded ] raise: Error. self collectionNotIncluded do: [ :each | self deny: (self nonEmpty includes: each) ]! ! !IntervalTest methodsFor: 'tests - fixture'! test0FixtureAsStringCommaAndDelimiterTest self shouldnt: [self nonEmpty] raise:Error . self deny: self nonEmpty isEmpty. self shouldnt: [self empty] raise:Error . self assert: self empty isEmpty. self shouldnt: [self nonEmpty1Element ] raise:Error . self assert: self nonEmpty1Element size=1.! ! !IntervalTest methodsFor: 'tests - fixture'! test0FixtureBeginsEndsWithTest self shouldnt: [self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self assert: self nonEmpty size>1. self shouldnt: [self empty ] raise: Error. self assert: self empty isEmpty.! ! !IntervalTest methodsFor: 'tests - fixture'! test0FixtureCloneTest self shouldnt: [ self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self empty ] raise: Error. self assert: self empty isEmpty. ! ! !IntervalTest methodsFor: 'tests - fixture'! test0FixtureConverAsSortedTest self shouldnt: [self collectionWithSortableElements ] raise: Error. self deny: self collectionWithSortableElements isEmpty .! ! !IntervalTest methodsFor: 'tests - fixture'! test0FixtureCopyPartOfSequenceableTest self shouldnt: [self collectionWithoutEqualElements ] raise: Error. self collectionWithoutEqualElements do: [:each | self assert: (self collectionWithoutEqualElements occurrencesOf: each)=1]. self shouldnt: [self indexInForCollectionWithoutDuplicates ] raise: Error. self assert: self indexInForCollectionWithoutDuplicates >0 & self indexInForCollectionWithoutDuplicates < self collectionWithoutEqualElements size. self shouldnt: [self empty] raise: Error. self assert: self empty isEmpty .! ! !IntervalTest methodsFor: 'tests - fixture'! test0FixtureCopySameContentsTest self shouldnt: [self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [self empty ] raise: Error. self assert: self empty isEmpty. ! ! !IntervalTest methodsFor: 'tests - fixture'! test0FixtureCopyWithOrWithoutSpecificElementsTest self shouldnt: [self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty . self shouldnt: [self indexInNonEmpty ] raise: Error. self assert: self indexInNonEmpty > 0. self assert: self indexInNonEmpty <= self nonEmpty size.! ! !IntervalTest methodsFor: 'tests - fixture'! test0FixtureCopyWithReplacementTest self shouldnt: [self replacementCollection ]raise: Error. self shouldnt: [self oldSubCollection] raise: Error. self shouldnt: [self collectionWith1TimeSubcollection ]raise: Error. self assert: (self howMany: self oldSubCollection in: self collectionWith1TimeSubcollection ) = 1. ! ! !IntervalTest methodsFor: 'tests - fixture'! test0FixtureIncludeTest | anElementIn | self shouldnt: [ self nonEmpty ]raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self elementNotIn ]raise: Error. anElementIn := true. self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self shouldnt: [ self anotherElementNotIn ]raise: Error. anElementIn := true. self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self shouldnt: [ self empty ] raise: Error. self assert: self empty isEmpty. ! ! !IntervalTest methodsFor: 'tests - fixture'! test0FixtureIncludeWithIdentityTest | anElement | self shouldnt: [ self collectionWithCopyNonIdentical ]raise: Error. anElement := self collectionWithCopyNonIdentical anyOne. self deny: anElement == anElement copy.! ! !IntervalTest methodsFor: 'tests - fixture'! test0FixtureIndexAccessTest | res collection element | self shouldnt: [ self collectionMoreThan1NoDuplicates ] raise: Error. 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 shouldnt: [ self elementInForIndexAccessing ] raise: Error. self assert: ( (collection := self collectionMoreThan1NoDuplicates )includes: (element:= self elementInForIndexAccessing)). self shouldnt: [ self elementNotInForIndexAccessing ] raise: Error. self deny: (self collectionMoreThan1NoDuplicates includes: self elementNotInForIndexAccessing)! ! !IntervalTest methodsFor: 'tests - fixture'! test0FixtureIterateSequencedReadableTest | res | self shouldnt: self nonEmptyMoreThan1Element raise: Error. self assert: self nonEmptyMoreThan1Element size > 1. self shouldnt: self empty raise: Error. 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 - fixture'! test0FixtureOccurrencesTest | tmp | self shouldnt: [self empty ]raise: Error. self assert: self empty isEmpty. self shouldnt: [ self collectionWithoutEqualElements ] raise: Error. self deny: self collectionWithoutEqualElements isEmpty. tmp := OrderedCollection new. self collectionWithoutEqualElements do: [ :each | self deny: (tmp includes: each). tmp add: each. ]. self shouldnt: [ self elementNotInForOccurrences ] raise: Error. self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! ! !IntervalTest methodsFor: 'tests - fixture'! test0FixturePrintTest self shouldnt: [self nonEmpty ] raise: Error.! ! !IntervalTest methodsFor: 'tests - fixture'! test0FixtureSequencedConcatenationTest self shouldnt: self empty raise: Exception. self assert: self empty isEmpty. self shouldnt: self firstCollection raise: Exception. self shouldnt: self secondCollection raise: Exception! ! !IntervalTest methodsFor: 'tests - fixture'! test0FixtureSequencedElementAccessTest self shouldnt: [ self moreThan4Elements ] raise: Error. self assert: self moreThan4Elements size >= 4. self shouldnt: [ self subCollectionNotIn ] raise: Error. self subCollectionNotIn detect: [ :each | (self moreThan4Elements includes: each) not ] ifNone: [ self assert: false ]. self shouldnt: [ self elementNotInForElementAccessing ] raise: Error. self deny: (self moreThan4Elements includes: self elementNotInForElementAccessing). self shouldnt: [ self elementInForElementAccessing ] raise: Error. self assert: (self moreThan4Elements includes: self elementInForElementAccessing)! ! !IntervalTest methodsFor: 'tests - fixture'! test0FixtureSubcollectionAccessTest self shouldnt: [ self moreThan3Elements ] raise: Error. self assert: self moreThan3Elements size > 2! ! !IntervalTest methodsFor: 'tests - fixture'! test0FixtureTConvertTest "a collection of number without equal elements:" | res | self shouldnt: [ self collectionWithoutEqualElements ]raise: Error. res := true. self collectionWithoutEqualElements detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false. ! ! !IntervalTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/15/2009 14:07'! test0IndexAccessingTest self shouldnt: [ self accessCollection ] raise: Error. self assert: self accessCollection size = 5. self shouldnt: [ self subCollectionNotIn ] raise: Error. self subCollectionNotIn detect: [ :each | (self accessCollection includes: each) not ] ifNone: [ self assert: false ]. self shouldnt: [ self elementNotInForIndexAccessing ] raise: Error. self deny: (self accessCollection includes: self elementNotInForIndexAccessing). self shouldnt: [ self elementInForIndexAccessing ] raise: Error. self assert: (self accessCollection includes: self elementInForIndexAccessing). self shouldnt: [ self collectionOfFloat ] raise: Error. self collectionOfFloat do: [ :each | self deny: each class = SmallInteger ]! ! !IntervalTest methodsFor: 'tests - fixture'! test0TSequencedStructuralEqualityTest self shouldnt: [self nonEmpty at: 1] raise: Error. "Ensures #nonEmpty is sequenceable"! ! !IntervalTest methodsFor: 'tests - fixture'! test0TStructuralEqualityTest self shouldnt: [self empty] raise: Error. self shouldnt: [self nonEmpty] raise: Error. self assert: self empty isEmpty. self deny: self nonEmpty isEmpty.! ! !IntervalTest methodsFor: 'tests - includes' stamp: 'delaunay 4/28/2009 10:22'! 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 shouldnt: [ self collectionWithCopyNonIdentical ] raise: Error. collection := self collectionWithCopyNonIdentical. element := collection anyOne copy. "self assert: (collection includes: element)." self deny: (collection identityIncludes: element)! ! !IntervalTest methodsFor: 'tests - includes'! 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 - includes'! testIncludesAllNoneThere "self debug: #testIncludesAllOfNoneThere'" self deny: (self empty includesAll: self nonEmpty ). self deny: (self nonEmpty includesAll: { self elementNotIn. self anotherElementNotIn })! ! !IntervalTest methodsFor: 'tests - includes'! 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: 'tests - includes'! testIncludesAnyNoneThere "self debug: #testIncludesAnyOfNoneThere'" self deny: (self nonEmpty includesAny: self empty). self deny: (self nonEmpty includesAny: { self elementNotIn. self anotherElementNotIn })! ! !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: 'tests - includes'! testIncludesElementIsThere "self debug: #testIncludesElementIsThere" self assert: (self nonEmpty includes: self nonEmpty anyOne).! ! !IntervalTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! testIdentityIndexOf "self debug: #testIdentityIndexOf" | collection element | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection identityIndexOf: element) = (collection indexOf: element)! ! !IntervalTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 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: 'delaunay 4/23/2009 15:14'! 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 - index access' stamp: 'delaunay 4/23/2009 15:14'! 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: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 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 - index access'! 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 - index access' stamp: 'delaunay 4/23/2009 15:14'! 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: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 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 - index access' stamp: 'delaunay 4/23/2009 15:14'! 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 - index access' stamp: 'delaunay 4/23/2009 15:14'! 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'! 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 - 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 - 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 - 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 - iterate on sequenced reable collections'! 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: 'tests - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! testFindFirst | element result | element := self nonEmptyMoreThan1Element at:1. result:=self nonEmptyMoreThan1Element findFirst: [:each | each =element]. self assert: result=1. ! ! !IntervalTest methodsFor: 'tests - iterate on sequenced reable collections'! testFindFirstNotIn | result | result:=self empty findFirst: [:each | true]. self assert: result=0. ! ! !IntervalTest methodsFor: 'tests - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! testFindLastNotIn | result | result:=self empty findFirst: [:each | true]. self assert: result=0. ! ! !IntervalTest methodsFor: 'tests - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! testKeysAndValuesDoEmpty | result | result:= OrderedCollection new. self empty keysAndValuesDo: [:i :value| result add: (value+i)]. self assert: result isEmpty .! ! !IntervalTest methodsFor: 'tests - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! testReverseDoEmpty | result | result:= OrderedCollection new. self empty reverseDo: [: each | result add: each]. self assert: result isEmpty .! ! !IntervalTest methodsFor: 'tests - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! testWithCollectError self should: [self nonEmptyMoreThan1Element with: self empty collect:[:a :b | ]] raise: Error.! ! !IntervalTest methodsFor: 'tests - iterate on sequenced reable collections'! 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'! testWithDoError self should: [self nonEmptyMoreThan1Element with: self empty do:[:a :b | ]] raise: Error.! ! !IntervalTest methodsFor: 'tests - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! 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 - occurrencesOf'! testOccurrencesOf | collection | collection := self collectionWithoutEqualElements . collection do: [ :each | self assert: (collection occurrencesOf: each) = 1 ].! ! !IntervalTest methodsFor: 'tests - occurrencesOf'! testOccurrencesOfEmpty | result | result := self empty occurrencesOf: (self collectionWithoutEqualElements anyOne). self assert: result = 0! ! !IntervalTest methodsFor: 'tests - occurrencesOf'! testOccurrencesOfNotIn | result | result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences. self assert: result = 0! ! !IntervalTest methodsFor: 'tests - printing'! 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 - printing'! 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 - printing'! 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 - printing'! 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: 'tests - printing'! 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 - printing'! 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 - subcollections access'! 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 - subcollections access'! 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 - subcollections access'! 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 - subcollections access'! 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 - subcollections access'! 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 - subcollections access'! 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 class uses: TCloneTest classTrait + TSequencedElementAccessTest classTrait + TIterateSequencedReadableTest classTrait + TSequencedConcatenationTest classTrait + TSubCollectionAccess classTrait + TAsStringCommaAndDelimiterSequenceableTest classTrait + TIndexAccess classTrait + TPrintOnSequencedTest classTrait + TConvertTest classTrait + TCopySequenceableWithReplacement classTrait + TCopySequenceableWithOrWithoutSpecificElements classTrait + TCopySequenceableSameContents classTrait + TCopyPartOfSequenceable classTrait + TCopyTest classTrait + TBeginsEndsWith classTrait + TConvertAsSortedTest classTrait + TIncludesWithIdentityCheckTest classTrait + TSequencedStructuralEqualityTest classTrait + TOccurrencesTest classTrait instanceVariableNames: ''! Error subclass: #InvalidDirectoryError instanceVariableNames: 'pathName' classVariableNames: '' poolDictionaries: '' category: 'Network-Url'! !InvalidDirectoryError methodsFor: 'accessing' stamp: 'ar 5/30/2001 20:44'! pathName ^pathName! ! !InvalidDirectoryError methodsFor: 'accessing' stamp: 'ar 5/30/2001 20:45'! pathName: badPathName pathName := badPathName! ! !InvalidDirectoryError methodsFor: 'exceptiondescription' stamp: 'StephaneDucasse 8/30/2009 16:54'! defaultAction ^#()! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! InvalidDirectoryError class instanceVariableNames: ''! !InvalidDirectoryError class methodsFor: 'exceptioninstantiator' stamp: 'ar 5/30/2001 20:49'! pathName: badPathName ^self new pathName: badPathName! ! Error subclass: #InvalidSocketStatusException instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Network-Kernel'! !InvalidSocketStatusException commentStamp: 'mir 5/12/2003 18:15' prior: 0! Signals if an operation on a Socket found it in a state invalid for that operation. ! ComposableModel subclass: #IssueCreator instanceVariableNames: 'description issue title type' classVariableNames: '' poolDictionaries: '' category: 'CI-Core-SliceSubmitter'! !IssueCreator commentStamp: '' prior: 0! An IssueCreator is a UI to create a Google Issue Tracker entry! !IssueCreator methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/4/2012 15:42'! description ^ description! ! !IssueCreator methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/4/2012 15:43'! issueTitle ^ title! ! !IssueCreator methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/4/2012 15:42'! type ^ type! ! !IssueCreator methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 7/4/2012 15:59'! createTypes ^ #('Type-Bug' 'Type-Cleanup' 'Type-Feature') collect: [:e | DropListItem named: e do: []].! ! !IssueCreator methodsFor: 'initialization' stamp: 'SeanDeNigris 8/12/2012 22:00'! initializeDialogWindow: aWindow aWindow okAction: [ description accept. self issue ifNotNil: [:i || t desc | t := title getText. desc := description getText asString. (t notEmpty and: [ desc notEmpty]) ifTrue: [ self issue labels: { type selectedItem label. 'Milestone-', SystemVersion current dottedMajorMinor }; title: t; description: desc ]]]. self focusOrder add: title; add: type; add: description; add: aWindow toolbar ! ! !IssueCreator methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 2/10/2013 14:43'! initializeWidgets self instantiateModels: #( title TextInputFieldModel description TextModel type DropListModel ). title ghostText: 'Title'; autoAccept: true; keyStrokeForNextFocus: Character tab asShortcut; keyStrokeForPreviousFocus: Character tab shift asShortcut; entryCompletion: nil; isCodeCompletionAllowed: false. type items: self createTypes; keyStrokeForNextFocus: Character tab asShortcut; keyStrokeForPreviousFocus: Character tab shift asShortcut. description isCodeCompletionAllowed: false; text: 'ENTER DESCRIPTION HERE'; readSelectionBlock: [ (0 to: 22) ]; acceptBlock: [ description readSelectionBlock: [ (1 to: 0) ]]! ! !IssueCreator methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 7/4/2012 15:58'! initialize "Initialization code for IssueCreator" issue := nil asValueHolder. super initialize.! ! !IssueCreator methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/6/2012 16:23'! cancelled ^ self window ifNil: [ true ] ifNotNil: [:w | w cancelled ]! ! !IssueCreator methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/18/2012 17:13'! initialExtent ^ 800@500! ! !IssueCreator methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/4/2012 15:55'! issue ^ issue contents! ! !IssueCreator methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/4/2012 15:55'! issue: anIssue issue contents: anIssue! ! !IssueCreator methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/4/2012 15:51'! title ^ 'Issue Creator'! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! IssueCreator class instanceVariableNames: ''! !IssueCreator class methodsFor: 'spec' stamp: 'BenjaminVanRyseghem 7/4/2012 15:47'! spec ^ SpecLayout composed newColumn: [:c | c newRow: [:r | r add: #issueTitle; add: #type width: 150 ] height: 30; add: #description ]; yourself! ! MorphTreeNodeModel subclass: #ItemNode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'GroupManagerUI'! !ItemNode methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 3/15/2011 14:07'! isGroup ^ false! ! !ItemNode methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 2/25/2012 16:40'! rowMorphForColumn: aTreeColumn ^ self item ifNotNil: [:i | i prettyName asMorph] ! ! EncodedCharSet subclass: #JISX0208 instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Multilingual-Encodings'! !JISX0208 commentStamp: 'yo 10/19/2004 19:52' prior: 0! This class represents the domestic character encoding called JIS X 0208 used for Japanese.! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! JISX0208 class instanceVariableNames: ''! !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: '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. ! ! !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'! initialize " self initialize " compoundTextSequence := String streamContents: [ :s | s nextPut: (Character value: 27). s nextPut: $$. s nextPut: $B ]! ! !JISX0208 class methodsFor: 'class methods' stamp: 'yo 9/2/2002 17:38'! leadingChar ^ 1. ! ! !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/4/2002 22:52'! printingDirection ^ #right. ! ! !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: 'yo 10/14/2003 10:19'! ucsTable ^ UCSTable jisx0208Table. ! ! !JISX0208 class methodsFor: 'class methods' stamp: 'yo 7/21/2004 18:36'! unicodeLeadingChar ^ JapaneseEnvironment leadingChar. ! ! Object subclass: #JPEGColorComponent instanceVariableNames: 'currentX currentY hSampleFactor vSampleFactor mcuBlocks widthInBlocks heightInBlocks dctSize mcuWidth mcuHeight priorDCValue id qTableIndex dcTableIndex acTableIndex' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Files'! !JPEGColorComponent commentStamp: '' prior: 0! 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: 'tao 10/23/97 12:21'! acTableIndex ^acTableIndex! ! !JPEGColorComponent methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! acTableIndex: anInteger acTableIndex := anInteger! ! !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:11'! heightInBlocks ^heightInBlocks! ! !JPEGColorComponent methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! heightInBlocks: anInteger heightInBlocks := anInteger! ! !JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:09'! id ^id! ! !JPEGColorComponent methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! id: anObject id := anObject! ! !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'! priorDCValue: aNumber priorDCValue := aNumber! ! !JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:43'! qTableIndex ^qTableIndex! ! !JPEGColorComponent methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! qTableIndex: anInteger qTableIndex := anInteger! ! !JPEGColorComponent methodsFor: 'accessing' stamp: 'tao 10/23/97 12:18'! totalMcuBlocks ^ heightInBlocks * widthInBlocks! ! !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:11'! widthInBlocks ^widthInBlocks! ! !JPEGColorComponent methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! widthInBlocks: anInteger widthInBlocks := anInteger! ! !JPEGColorComponent methodsFor: 'sample streaming' stamp: 'lr 7/4/2009 10:42'! initializeSampleStreamBlocks: aCollection mcuBlocks := aCollection. self resetSampleStream! ! !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: 'sample streaming' stamp: 'lr 7/4/2009 10:42'! resetSampleStream currentX := 0. currentY := 0! ! Object subclass: #JPEGHuffmanTable instanceVariableNames: 'bits values mincode maxcode valptr lookaheadBits lookaheadSymbol' classVariableNames: 'BitBufferSize Lookahead' poolDictionaries: '' category: 'Graphics-Files'! !JPEGHuffmanTable commentStamp: '' prior: 0! 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: 'lr 7/4/2009 10:42'! bits: anObject bits := anObject! ! !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: 'accessing' stamp: 'tao 10/21/97 23:59'! maxcode ^maxcode! ! !JPEGHuffmanTable methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! values: anObject values := 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: 'computation' stamp: 'tao 10/21/97 22:44'! valueForCode: code length: length ^ values at: ((valptr at: length) + code - (mincode at: length))! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! JPEGHuffmanTable class instanceVariableNames: ''! !JPEGHuffmanTable class methodsFor: 'constants' stamp: 'tao 10/21/97 22:15'! lookahead ^ Lookahead! ! !JPEGHuffmanTable class methodsFor: 'initialization' stamp: 'stephane.ducasse 6/14/2009 22:52'! initialize Lookahead := 8. BitBufferSize := 16! ! ReadStream subclass: #JPEGReadStream instanceVariableNames: 'bitBuffer bitsInBuffer' classVariableNames: 'MaxBits' poolDictionaries: '' category: 'Graphics-Files'! !JPEGReadStream commentStamp: '' prior: 0! 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: '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'! 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: 'accessing' stamp: 'ar 3/6/2001 12:34'! nextByte ^self next asInteger! ! !JPEGReadStream methodsFor: 'accessing' stamp: 'ar 3/6/2001 12:35'! nextBytes: n ^(self next: n) asByteArray! ! !JPEGReadStream methodsFor: 'accessing' stamp: 'ar 3/4/2001 17:40'! reset super reset. self resetBitBuffer! ! !JPEGReadStream methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! resetBitBuffer bitBuffer := 0. bitsInBuffer := 0! ! !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 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: '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: '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 class instanceVariableNames: ''! !JPEGReadStream class methodsFor: 'initialization' stamp: 'lr 7/4/2009 10:42'! initialize "JPEGReadStream initialize" MaxBits := 16! ! ImageReadWriter subclass: #JPEGReadWriter instanceVariableNames: 'width height components currentComponents qTable hACTable hDCTable restartInterval restartsToGo mcuWidth mcuHeight mcusPerRow mcuRowsInScan mcuMembership mcuSampleBuffer mcuImageBuffer majorVersion minorVersion dataPrecision densityUnit xDensity yDensity ss se ah al sosSeen residuals ditherMask' classVariableNames: 'ConstBits DCTK1 DCTK2 DCTK3 DCTK4 DCTSize DCTSize2 DitherMasks FIXn0n298631336 FIXn0n34414 FIXn0n390180644 FIXn0n541196100 FIXn0n71414 FIXn0n765366865 FIXn0n899976223 FIXn1n175875602 FIXn1n40200 FIXn1n501321110 FIXn1n77200 FIXn1n847759065 FIXn1n961570560 FIXn2n053119869 FIXn2n562915447 FIXn3n072711026 FloatSampleOffset HuffmanTableSize JFIFMarkerParser JPEGNaturalOrder MaxSample Pass1Bits Pass1Div Pass2Div QTableScaleFactor QuantizationTableSize SampleOffset' poolDictionaries: '' category: 'Graphics-Files'! !JPEGReadWriter commentStamp: '' prior: 0! 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: 'accessing' stamp: 'lr 7/4/2009 10:42'! hACTable hACTable ifNil: [ hACTable := Array new: HuffmanTableSize ]. ^ hACTable! ! !JPEGReadWriter methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! hDCTable hDCTable ifNil: [ hDCTable := Array new: HuffmanTableSize ]. ^ hDCTable! ! !JPEGReadWriter methodsFor: 'accessing' stamp: 'lr 7/4/2009 10:42'! qTable qTable ifNil: [ qTable := Array new: QuantizationTableSize ]. ^ qTable! ! !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: '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: '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: '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: 'colorspace conversion' stamp: 'ar 3/4/2001 22:19'! primColorConvertGrayscaleMCU self primColorConvertGrayscaleMCU: (currentComponents at: 1) bits: mcuImageBuffer bits residuals: residuals ditherMask: ditherMask.! ! !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: 'colorspace conversion' stamp: 'ar 3/4/2001 21:36'! primColorConvertIntYCbCrMCU self primColorConvertYCbCrMCU: currentComponents bits: mcuImageBuffer bits residuals: residuals ditherMask: ditherMask.! ! !JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'ar 3/4/2001 21:36'! primColorConvertYCbCrMCU: componentArray bits: bits residuals: residualArray ditherMask: mask ^self colorConvertIntYCbCrMCU! ! !JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'tao 10/26/97 15:43'! sampleFloatRangeLimit: aNumber ^ (aNumber rounded max: 0) min: MaxSample! ! !JPEGReadWriter methodsFor: 'colorspace conversion' stamp: 'di 9/15/1998 14:30'! sampleRangeLimit: aNumber aNumber < 0 ifTrue: [^ 0]. aNumber > MaxSample ifTrue: [^ MaxSample]. ^ aNumber! ! !JPEGReadWriter methodsFor: 'dct' stamp: 'tao 10/26/97 15:16'! dctFloatRangeLimit: value ^ (value / 8.0) + FloatSampleOffset.! ! !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: 'dct' stamp: 'ar 3/4/2001 21:35'! idctBlockInt: anArray component: aColorComponent ^self idctBlockInt: anArray qt: (self qTable at: aColorComponent qTableIndex)! ! !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: '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: 'dct' stamp: 'ar 3/4/2001 21:37'! primIdctBlockInt: anArray component: aColorComponent ^self primIdctInt: anArray qt: (self qTable at: aColorComponent qTableIndex)! ! !JPEGReadWriter methodsFor: 'dct' stamp: 'ar 3/4/2001 21:35'! primIdctInt: anArray qt: qt ^self idctBlockInt: anArray qt: qt! ! !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: 'error handling' stamp: 'tao 10/19/97 12:25'! notSupported: aString self error: aString , ' is not currently supported'! ! !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: '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: 'huffman encoding' stamp: 'ar 3/4/2001 17:27'! getBits: requestedBits ^stream getBits: requestedBits! ! !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: 'huffman encoding' stamp: 'lr 7/4/2009 10:42'! processRestart stream resetBitBuffer. self parseNextMarker. currentComponents do: [ :c | c priorDCValue: 0 ]. restartsToGo := restartInterval! ! !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'! 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: '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: '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: '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: '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 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: '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: '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: '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: 'marker parsing' stamp: 'lr 7/4/2009 10:42'! parseStartOfInput restartInterval := 0. densityUnit := 0. xDensity := 1. yDensity := 1! ! !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: '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: 'lr 7/4/2009 10:42'! skipMarker | length markerStart | markerStart := self position. length := self nextWord. self next: length - (self position - markerStart)! ! !JPEGReadWriter methodsFor: 'preferences' stamp: 'tao 10/26/97 22:09'! useFloatingPoint ^ false! ! !JPEGReadWriter methodsFor: 'public access' stamp: 'tao 9/18/1998 08:53'! nextImage ^ self nextImageDitheredToDepth: Display depth ! ! !JPEGReadWriter methodsFor: 'public access' stamp: 'lr 7/4/2009 10:42'! 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 current 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: '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: '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: 'private' stamp: 'lr 7/4/2009 10:42'! on: aStream super on: aStream. stream := JPEGReadStream on: stream upToEnd! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! JPEGReadWriter class instanceVariableNames: ''! !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')! ! !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! ! LanguageEnvironment subclass: #JapaneseEnvironment instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Multilingual-Languages'! !JapaneseEnvironment commentStamp: '' prior: 0! 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 instanceVariableNames: ''! !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: 'language methods' stamp: 'yo 3/17/2004 21:54'! scanSelector ^ #scanJapaneseCharactersFrom:to:in:rightX:stopConditions:kern: ! ! !JapaneseEnvironment class methodsFor: 'language methods' stamp: 'yo 3/16/2004 14:49'! traditionalCharsetClass ^ JISX0208. ! ! !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: 'subclass responsibilities' stamp: 'yo 3/17/2004 21:55'! leadingChar ^ 5. ! ! !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: 'subclass responsibilities' stamp: 'MarcusDenker 7/12/2012 20:46'! systemConverterClass | encoding | OSPlatform isWin32 ifTrue: [^ShiftJISTextConverter]. OSPlatform isMacOS ifTrue: [^UTF8TextConverter]. OSPlatform isUnix ifTrue: [encoding := X11Encoding encoding. encoding ifNil: [^EUCJPTextConverter]. (encoding = 'utf-8') ifTrue: [^UTF8TextConverter]. (encoding = 'shiftjis' or: [ encoding = 'sjis' ]) ifTrue: [^ShiftJISTextConverter]. ^EUCJPTextConverter]. ^UTF8TextConverter! ! Object subclass: #Job instanceVariableNames: 'block currentValue min max title children isRunning parent process announcer' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Job'! !Job commentStamp: '' prior: 0! 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: '*Deprecated20' stamp: 'SeanDeNigris 8/30/2012 10:46'! loggingProgress | log | log := LoggingSystemProgressItemMorph new. self announcer on: JobStart send: #onStart: to: log; on: JobChange send: #onChange: to: log; on: JobEnd send: #onEnd: to: log.! ! !Job methodsFor: 'accessing' stamp: 'SeanDeNigris 8/29/2012 14:17'! announce: anAnnouncementClass | announcement | announcement := anAnnouncementClass on: self. SystemAnnouncer uniqueInstance announce: announcement.! ! !Job methodsFor: 'accessing' stamp: 'SeanDeNigris 8/29/2012 16:10'! announceChange isRunning ifFalse: [ ^ self ]. self announce: JobChange.! ! !Job methodsFor: 'accessing' stamp: 'SeanDeNigris 8/29/2012 13:46'! block ^ block! ! !Job methodsFor: 'accessing' stamp: 'SeanDeNigris 8/29/2012 15:11'! children ^ children copy.! ! !Job methodsFor: 'accessing' stamp: 'SeanDeNigris 8/29/2012 13:46'! currentValue ^ currentValue! ! !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'! max ^ max! ! !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:08'! migrateProgressWhileUpdatingBounds: aBlockChangingBounds "Keep the progress value consistent while we change min / max" | progress | progress := self progress. aBlockChangingBounds value. self progress: progress.! ! !Job methodsFor: 'accessing' stamp: 'SeanDeNigris 8/29/2012 13:46'! min ^ min! ! !Job methodsFor: 'accessing' stamp: 'CamilloBruni 9/1/2012 13:05'! min: aNumber self migrateProgressWhileUpdatingBounds: [ min := aNumber ]. self announceChange.! ! !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: 'compatibility' stamp: 'SeanDeNigris 8/29/2012 14:36'! current ^ self currentValue.! ! !Job methodsFor: 'compatibility' stamp: 'SeanDeNigris 8/29/2012 14:12'! current: aNumber self currentValue: aNumber.! ! !Job methodsFor: 'compatibility' stamp: 'SeanDeNigris 8/29/2012 14:37'! decrement self currentValue: self currentValue - 1.! ! !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:35'! label ^ self title.! ! !Job methodsFor: 'compatibility' stamp: 'SeanDeNigris 8/29/2012 14:34'! label: aString self title: aString.! ! !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: 'debugging' stamp: 'CamilloBruni 8/31/2012 09:23'! debug ^ process debug! ! !Job methodsFor: 'initialize-release' stamp: 'CamilloBruni 8/31/2012 09:32'! initialize super initialize. min := 0. max := 100. currentValue := 0. title := ''. isRunning := false. children := OrderedCollection new.! ! !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: 'notification-handling' stamp: 'CamilloBruni 9/1/2012 12:52'! handleJobStart: aJobStartNotification self addChild: aJobStartNotification job.! ! !Job methodsFor: 'progress' stamp: 'CamilloBruni 9/1/2012 20:30'! announcer ^ announcer ifNil: [ announcer := Announcer new ].! ! !Job methodsFor: 'progress' stamp: 'CamilloBruni 8/31/2012 09:31'! progress ^ (currentValue - min) / (max - min)! ! !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: '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: 'testing' stamp: 'CamilloBruni 8/31/2012 09:22'! isRunning ^ isRunning! ! !Job methodsFor: 'private' stamp: 'SeanDeNigris 8/29/2012 15:53'! addChild: aJob children add: aJob. aJob parent: self.! ! !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: 'private' stamp: 'SeanDeNigris 8/29/2012 13:42'! block: aBlock block := aBlock.! ! !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: 'private' stamp: 'SeanDeNigris 8/29/2012 15:54'! parent: aJob parent := aJob.! ! !Job methodsFor: 'private' stamp: 'CamilloBruni 10/5/2012 17:07'! prepareForRunning isRunning := true. JobStartNotification on: self. process := Processor activeProcess. self announce: JobStart.! ! !Job methodsFor: 'private' stamp: 'SeanDeNigris 8/29/2012 15:54'! removeChild: aJob children remove: aJob.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Job class instanceVariableNames: ''! !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: '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.! ! Announcement subclass: #JobChange instanceVariableNames: 'job' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Job'! !JobChange commentStamp: '' prior: 0! A JobChange is an announcement for a job change. To get notify SystemAnnouncer uniqueInstance on: JobChange send: #XXX to: whoever.! !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'! max ^ job max! ! !JobChange methodsFor: 'accessing' stamp: 'CamilloBruni 9/1/2012 13:16'! min ^ job min! ! !JobChange methodsFor: 'accessing' stamp: 'CamilloBruni 9/1/2012 13:16'! progress ^ job progress! ! !JobChange methodsFor: 'accessing' stamp: 'CamilloBruni 9/1/2012 13:16'! title ^ job title! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! JobChange class instanceVariableNames: ''! !JobChange class methodsFor: 'instance creation' stamp: 'SeanDeNigris 8/29/2012 14:38'! on: aJob ^ self new job: aJob.! ! Announcement subclass: #JobEnd instanceVariableNames: 'job' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Job'! !JobEnd commentStamp: '' prior: 0! 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 instanceVariableNames: ''! !JobEnd class methodsFor: 'instance creation' stamp: 'SeanDeNigris 8/29/2012 14:38'! on: aJob ^ self new job: aJob.! ! Notification subclass: #JobNotification instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Job'! !JobNotification commentStamp: '' prior: 0! 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! ! JobNotification subclass: #JobProgress instanceVariableNames: 'progress title' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Job'! !JobProgress commentStamp: '' prior: 0! 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: 'accessing' stamp: 'CamilloBruni 9/1/2012 12:51'! progress ^ progress! ! !JobProgress methodsFor: 'accessing' stamp: 'CamilloBruni 9/1/2012 12:51'! progress: anObject progress := anObject! ! !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: 'handling' stamp: 'CamilloBruni 9/1/2012 12:52'! handle: aJob aJob handleJobProgress: self. self resume.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! JobProgress class instanceVariableNames: ''! !JobProgress class methodsFor: 'instance-creation' stamp: 'CamilloBruni 9/1/2012 12:51'! progress: aNormalizedNumber self new 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'! title: aTitleString progress: aNormalizedNumber self new title: aTitleString; progress: aNormalizedNumber; signal.! ! Morph subclass: #JobProgressBarMorph instanceVariableNames: 'button progressBar' classVariableNames: 'BarHeight BarWidth' poolDictionaries: '' category: 'Morphic-ProgressBar'! !JobProgressBarMorph commentStamp: '' prior: 0! 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'! decrement ^ progressBar decrement! ! !JobProgressBarMorph methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 8/30/2012 19:04'! increment ^ progressBar increment! ! !JobProgressBarMorph methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 9/1/2012 13:18'! progress ^ progressBar value / 100! ! !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 8/30/2012 19:04'! value: aNumber ^ progressBar value: aNumber! ! !JobProgressBarMorph methodsFor: 'evaluating' stamp: 'CamilloBruni 8/30/2012 19:04'! value ^ progressBar value! ! !JobProgressBarMorph methodsFor: 'initialize' stamp: 'Sd 11/30/2012 20:22'! initialize super initialize. progressBar := ProgressBarMorph new. progressBar hResizing: #spaceFill. button := ThemeIcons smallErrorIcon 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.! ! Morph subclass: #JobProgressMorph instanceVariableNames: 'bar endValue hasResult job labelMorph lastRefresh lock result startValue' classVariableNames: 'BarHeight BarWidth' poolDictionaries: '' category: 'Morphic-ProgressBar'! !JobProgressMorph commentStamp: '' prior: 0! 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: '*Deprecated20' stamp: 'SeanDeNigris 5/14/2012 15:24'! end: aNumber self deprecated: 'delete'. endValue := aNumber.! ! !JobProgressMorph methodsFor: '*Deprecated20' stamp: 'SeanDeNigris 5/14/2012 15:24'! endAt: aNumber self deprecated: 'delete'. endValue := aNumber.! ! !JobProgressMorph methodsFor: '*Deprecated20' stamp: 'SeanDeNigris 6/20/2012 23:23'! value: anObject self deprecated: 'Use SystemProgressItemMorph''s "API" protocol' on: '20 June, 2012' in: 'Pharo 2.0'. (anObject isKindOf: Number) ifTrue: [ self current: anObject ]. ((anObject isKindOf: String) and: [ anObject isSymbol not ]) ifTrue: [ ^ self label: anObject ]. anObject = #label ifTrue: [ ^ self label ]. anObject = #increment ifTrue: [ ^ self increment ]. anObject = #decrement ifTrue: [ ^ self decrement ]. anObject = #setMax ifTrue: [ ^ self error: '#setMax no longer supported. File a bug report if you want it back' ]. anObject = #setMin ifTrue: [ ^ self error: '#setMin no longer supported. File a bug report if you want it back' ]. anObject = #stripe ifTrue: [ ^ self error: '#stripe no longer supported. File a bug report if you want it back' ].! ! !JobProgressMorph methodsFor: 'API' stamp: 'SeanDeNigris 5/23/2012 00:25'! beComplete self close.! ! !JobProgressMorph methodsFor: 'API' stamp: 'SeanDeNigris 5/14/2012 19:48'! current ^ bar value.! ! !JobProgressMorph methodsFor: 'API' stamp: 'SeanDeNigris 6/20/2012 23:24'! current: aNumber bar value: aNumber. self changed.! ! !JobProgressMorph methodsFor: 'API' stamp: 'SeanDeNigris 5/14/2012 19:49'! decrement bar decrement.! ! !JobProgressMorph methodsFor: 'API' stamp: 'SeanDeNigris 5/14/2012 19:49'! increment bar increment.! ! !JobProgressMorph methodsFor: 'API' stamp: 'SeanDeNigris 5/22/2012 20:18'! label ^ self labelMorph contents.! ! !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: 'BenjaminVanRyseghem 3/1/2013 17:52'! progress: aNormalizedNumber bar progress = aNormalizedNumber ifFalse: [ bar progress: aNormalizedNumber. self changed: #progressValue ].! ! !JobProgressMorph methodsFor: 'accessing' stamp: 'CamilloBruni 8/30/2012 19:27'! job: aJob job := aJob! ! !JobProgressMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/19/2013 15:34'! lastRefresh ^ lastRefresh ifNil: [ lastRefresh := 0 ]! ! !JobProgressMorph methodsFor: 'action' stamp: 'CamilloBruni 8/31/2012 09:21'! debug job isRunning ifTrue: [ job debug ].! ! !JobProgressMorph methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 2/19/2013 15:27'! initialize "Initialization code for JobProgressMorph" super initialize. self addDependent: SystemProgressMorph uniqueInstance.! ! !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: '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: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: 'SeanDeNigris 5/23/2012 00:22'! forceRefreshOnNextChange lastRefresh := 0.! ! !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: 'private' stamp: 'SeanDeNigris 5/14/2012 15:23'! labelMorph ^ labelMorph.! ! !JobProgressMorph methodsFor: 'private' stamp: 'Sd 11/30/2012 21:42'! max: aNumber endValue := aNumber! ! !JobProgressMorph methodsFor: 'private' stamp: 'BenjaminVanRyseghem 2/19/2013 16:04'! refresh lastRefresh := Time millisecondClockValue. self width: (labelMorph width) + 25.! ! !JobProgressMorph methodsFor: 'private' stamp: 'Sd 11/30/2012 21:42'! result ^ result! ! !JobProgressMorph methodsFor: 'private' stamp: 'BenjaminVanRyseghem 2/19/2013 15:35'! result: anObject lock critical: [ hasResult := true. result := anObject ].! ! !JobProgressMorph methodsFor: 'private' stamp: 'SeanDeNigris 5/14/2012 15:09'! start: aNumber startValue := aNumber.! ! !JobProgressMorph methodsFor: 'private' stamp: 'StephaneDucasse 5/20/2012 19:39'! startAt: aNumber startValue := aNumber.! ! !JobProgressMorph methodsFor: 'private' stamp: 'Sd 11/30/2012 21:42'! updateLayout | top | labelMorph contents isEmpty ifFalse: [ self addMorphBack: labelMorph]. self addMorphBack: bar.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! JobProgressMorph class instanceVariableNames: ''! !JobProgressMorph class methodsFor: 'instance creation' stamp: 'CamilloBruni 8/30/2012 19:31'! job: aJob ^ self new initializeJob: aJob! ! Announcement subclass: #JobStart instanceVariableNames: 'job' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Job'! !JobStart commentStamp: '' prior: 0! 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 instanceVariableNames: ''! !JobStart class methodsFor: 'instance creation' stamp: 'SeanDeNigris 8/29/2012 14:38'! on: aJob ^ self new job: aJob.! ! JobNotification subclass: #JobStartNotification instanceVariableNames: 'job' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Job'! !JobStartNotification commentStamp: '' prior: 0! 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: 'accessing' stamp: 'CamilloBruni 8/31/2012 11:00'! job: anObject job := anObject! ! !JobStartNotification methodsFor: 'handling' stamp: 'CamilloBruni 9/1/2012 12:52'! handle: aJob aJob handleJobStart: self. self resume.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! JobStartNotification class instanceVariableNames: ''! !JobStartNotification class methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 8/31/2012 11:00'! on: aJob ^ (self new job: aJob) signal.! ! TestCase subclass: #JobTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Processes'! !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 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: '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 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 9/1/2012 12:56'! testSingleJob | wasRun | wasRun := false. [ :job | self assert: job children isEmpty. wasRun := true ] asJob run. self assert: wasRun.! ! Object subclass: #JoinSection instanceVariableNames: 'src dst borderWidth borderColor type width shape' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Tools-Diff'! !JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:16'! borderColor "Answer the value of borderColor" ^ borderColor! ! !JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:16'! borderColor: aColor "Set the value of borderColor" borderColor := aColor. self updateHighlights! ! !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: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:19'! dst "Answer the value of dst" ^ dst! ! !JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! dst: anObject "Set the value of dst" dst := anObject! ! !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:19'! dstLineRange: anInterval "Set the dst lineRange." self dst lineRange: anInterval! ! !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'! dstRange: anInterval "Set the dst range." self dst range: anInterval. self updateShape! ! !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'! src "Answer the value of src" ^ src! ! !JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! src: anObject "Set the value of src" src := anObject! ! !JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! srcColor: aColor "Set the src color." self src color: aColor! ! !JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! srcLineRange: anInterval "Set the src lneRange." self src lineRange: anInterval! ! !JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! srcOffset: aPoint "Set the src offset" self src offset: aPoint. self updateShape! ! !JoinSection methodsFor: 'accessing' stamp: 'gvc 11/1/2006 14:19'! srcRange: anInterval "Set the src range" self src range: anInterval. self updateShape! ! !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: '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:21'! width "Answer the value of width" ^ width! ! !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: '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: '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:17'! clicked "The receiver or a highlight was clicked." self wantsClick ifFalse: [^false]. ^true! ! !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: '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: '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: '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: '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: '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: '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: '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})! ! !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: 'initialize-release' 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! ! Object subclass: #JoinSide instanceVariableNames: 'range offset lineRange highlights color text' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Tools-Diff'! !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'! color: anObject "Set the value of color" color := 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 10:41'! highlights: anObject "Set the value of highlights" highlights := anObject! ! !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'! lineRange: anObject "Set the value of lineRange" lineRange := anObject! ! !JoinSide methodsFor: 'accessing' stamp: 'gvc 11/1/2006 10:41'! offset "Answer the value of offset" ^ offset! ! !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'! 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 11:09'! text "Answer the value of text" ^ text! ! !JoinSide methodsFor: 'accessing' stamp: 'gvc 11/1/2006 11:09'! text: anObject "Set the value of text" text := anObject! ! !JoinSide methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 10:58'! highlight "Answer the primary highlight." ^(self highlights ifEmpty: [^nil]) first! ! !JoinSide methodsFor: 'as yet unclassified' 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: ''! ! KMModifier subclass: #KMAltModifier instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Shortcuts'! !KMAltModifier methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 3/20/2011 23:54'! initialize super initialize. identifier := #a. name := 'Alt'.! ! !KMAltModifier methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 3/19/2011 20:50'! matchesEvent: aKeyboardEvent ^ aKeyboardEvent altKeyPressed! ! Object subclass: #KMBuffer instanceVariableNames: 'buffer currentEvent' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Core'! !KMBuffer methodsFor: 'accessing' stamp: 'GuillermoPolito 6/24/2012 12:08'! buffer ^buffer! ! !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: 'initialize-release' stamp: 'GuillermoPolito 6/24/2012 12:03'! initialize buffer := OrderedCollection new.! ! !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 instanceVariableNames: 'uniqueInstance'! !KMBuffer class methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 6/24/2012 12:02'! resetUniqueInstance uniqueInstance := nil! ! !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:31'! uniqueInstance: aBuffer uniqueInstance := aBuffer.! ! Object subclass: #KMBuilder instanceVariableNames: 'platform' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Pragmas'! !KMBuilder methodsFor: 'accessing' stamp: 'GuillermoPolito 10/21/2011 00:12'! platform: aPlatform platform := aPlatform! ! !KMBuilder methodsFor: 'keymap-building' stamp: 'GuillermoPolito 5/31/2011 13:45'! attachShortcutCategory: aByteSymbol to: aClass KMRepository default attachCategoryName: aByteSymbol to: aClass.! ! !KMBuilder methodsFor: 'keymap-building' stamp: 'GuillermoPolito 10/21/2011 01:26'! shortcut: aKeymapName ^KMKeymapBuilder for: aKeymapName platform: platform! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! KMBuilder class instanceVariableNames: ''! !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! ! BorderedMorph subclass: #KMCatcherMorph instanceVariableNames: 'focused keystrokes keymapSetting labelMorph initialShortcut edited' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Settings'! !KMCatcherMorph methodsFor: 'accessing' stamp: 'CamilloBruni 3/18/2011 23:11'! balloonText ^ 'Click to edit shortcut. Right click to open context menu.'! ! !KMCatcherMorph methodsFor: 'accessing' stamp: 'GuillermoPolito 1/20/2011 00:02'! setMessage: aMessage labelMorph contents: aMessage! ! !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: 'api' stamp: 'CamilloBruni 3/18/2011 23:11'! cancel edited ifFalse: [ ^ self ]. self keystrokes: OrderedCollection new. self showInitialShortcut. self initializeKeystrokes! ! !KMCatcherMorph methodsFor: 'api' stamp: 'CamilloBruni 3/18/2011 23:11'! keystrokes ^ keystrokes! ! !KMCatcherMorph methodsFor: 'api' stamp: 'GuillermoPolito 1/20/2011 01:28'! keystrokes: someKeystrokes keystrokes := someKeystrokes. self showKeystrokes.! ! !KMCatcherMorph methodsFor: 'api' stamp: 'GuillermoPolito 11/2/2011 22:34'! shortcut | theKeystrokes | theKeystrokes := self keystrokes. theKeystrokes ifEmpty: [ ^ KMNoShortcut new ]. ^ theKeystrokes allButFirst inject: theKeystrokes first asShortcut into: [ :acum :each | acum , each asShortcut ]! ! !KMCatcherMorph methodsFor: 'api' stamp: 'CamilloBruni 3/20/2011 23:41'! shortcutString | shortcut | self keystrokes ifEmpty: [ ^ '' ]. shortcut := self shortcut. ^ shortcut asString! ! !KMCatcherMorph methodsFor: 'drawing' stamp: 'GuillermoPolito 1/24/2011 02:45'! drawOn: aCanvas "Indicate unaccepted edits, conflicts etc." super drawOn: aCanvas. focused ifTrue: [ UITheme current drawTextAdornmentFor: self color: Color orange on: aCanvas]! ! !KMCatcherMorph methodsFor: 'event handling' stamp: 'CamilloBruni 3/18/2011 23:11'! allowsKeymapping ^ false! ! !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: 'event handling' stamp: 'CamilloBruni 3/19/2011 00:09'! handlesMouseDown: event ^ true! ! !KMCatcherMorph methodsFor: 'event handling' stamp: 'GuillermoPolito 1/24/2011 00:53'! keyStroke: aKeyStroke edited := true. self keystrokes add: aKeyStroke. self showKeystrokes.! ! !KMCatcherMorph methodsFor: 'event handling' stamp: 'GuillermoPolito 5/23/2012 11:39'! keyboardFocusChange: aBoolean super keyboardFocusChange: aBoolean. focused := aBoolean. focused ifTrue: [ self color: (UITheme current textEditorNormalFillStyleFor: self) ] ifFalse: [ self color: (UITheme current textEditorDisabledFillStyleFor: self) ]. ^ true! ! !KMCatcherMorph methodsFor: 'event handling' stamp: 'GuillermoPolito 5/31/2011 12:42'! keymapSetting: aSetting keymapSetting := aSetting. self initialShortcut: keymapSetting shortcut.! ! !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: 'event handling' stamp: 'CamilloBruni 3/19/2011 00:06'! 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. ]. self theme decorateMenu: menu. menu popUpInWorld: self currentWorld! ! !KMCatcherMorph methodsFor: 'halos and balloon help' stamp: 'CamilloBruni 3/18/2011 23:11'! wantsBalloon ^ true! ! !KMCatcherMorph methodsFor: 'initialization' stamp: 'GuillermoPolito 1/24/2011 01:26'! initialShortcut: aShortcut initialShortcut := aShortcut. self showInitialShortcut. self initializeKeystrokes.! ! !KMCatcherMorph methodsFor: 'initialization' stamp: 'GuillermoPolito 1/24/2011 02:43'! initialize super initialize. self layoutPolicy: TableLayout new. self listCentering: #center. self width: 300. self height: 25. self color: (UITheme current textEditorDisabledFillStyleFor: self). self borderStyle: (UITheme current textEditorDisabledBorderStyleFor: self). labelMorph := StringMorph contents: ''. self addMorph: (labelMorph). edited := false. focused := false. self initializeKeystrokes. ! ! !KMCatcherMorph methodsFor: 'initialization' stamp: 'GuillermoPolito 1/24/2011 01:26'! initializeKeystrokes keystrokes := OrderedCollection new.! ! !KMCatcherMorph methodsFor: 'initialization' stamp: 'CamilloBruni 3/20/2011 23:49'! showInitialShortcut self setMessage: initialShortcut asString.! ! !KMCatcherMorph methodsFor: 'private' stamp: 'GuillermoPolito 1/24/2011 00:57'! showKeystrokes self setMessage: self shortcutString.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! KMCatcherMorph class instanceVariableNames: ''! !KMCatcherMorph class methodsFor: 'instance creation' stamp: 'CamilloBruni 3/18/2011 23:11'! for: aModel ^ (self new) keymapSetting: aModel; yourself! ! Object subclass: #KMCategory instanceVariableNames: 'name platforms' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Core'! !KMCategory commentStamp: 'GuillermoPolito 12/14/2010 21:32' prior: 0! 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: 'CamilloBruni 3/18/2011 23:11'! categoryName ^ name! ! !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: 'accessing' stamp: 'GuillermoPolito 1/21/2012 21:02'! keymaps ^self allEntries keymaps! ! !KMCategory methodsFor: 'accessing' stamp: 'CamilloBruni 3/18/2011 23:11'! name ^ name! ! !KMCategory methodsFor: 'accessing' stamp: 'GuillermoPolito 12/14/2010 00:58'! name: aCategorySymbol name := aCategorySymbol ! ! !KMCategory methodsFor: 'associating' stamp: 'GuillermoPolito 1/21/2012 20:55'! addKeymapEntry: aKeymapEntry self commonEntries add: aKeymapEntry.! ! !KMCategory methodsFor: 'associating' stamp: 'GuillermoPolito 1/21/2012 20:55'! addKeymapEntry: aKeymapEntry at: aPlatform (self entriesAt: aPlatform) add: aKeymapEntry! ! !KMCategory methodsFor: 'associating' stamp: 'GuillermoPolito 10/21/2011 00:40'! allEntries ^self commonEntries, self platformEntries! ! !KMCategory methodsFor: 'associating' stamp: 'GuillermoPolito 10/21/2011 00:23'! commonEntries ^self entriesAt: #all! ! !KMCategory methodsFor: 'associating' stamp: 'GuillermoPolito 1/21/2012 20:56'! hasKeymapNamed: aKeymapEntryName ^self allEntries hasKeymapNamed: aKeymapEntryName! ! !KMCategory methodsFor: 'associating' stamp: 'GuillermoPolito 1/21/2012 20:57'! hasKeymapNamed: aKeymapEntryName at: aPlatform ^ (self entriesAt: aPlatform) hasKeymapNamed: aKeymapEntryName! ! !KMCategory methodsFor: 'associating' stamp: 'GuillermoPolito 1/21/2012 20:57'! keymapNamed: aKeymapEntryName ^self allEntries keymapNamed: aKeymapEntryName! ! !KMCategory methodsFor: 'associating' stamp: 'GuillermoPolito 1/21/2012 20:58'! keymapNamed: aKeymapEntryName at: aPlatform ^(self entriesAt: aPlatform) keymapNamed: aKeymapEntryName! ! !KMCategory methodsFor: 'associating' stamp: 'GuillermoPolito 10/21/2011 00:50'! platformEntries ^self entriesAt: Smalltalk os current platformFamily! ! !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: 'testing' stamp: 'GuillermoPolito 10/21/2011 00:37'! matches: aString ^ self keymaps anySatisfy: [ :entry | entry matches: aString ]! ! !KMCategory methodsFor: 'testing' stamp: 'GuillermoPolito 10/21/2011 00:37'! matchesCompletely: aString ^ self keymaps anySatisfy: [ :entry | entry matchesCompletely: aString ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! KMCategory class instanceVariableNames: ''! !KMCategory class methodsFor: 'instance creation' stamp: 'CamilloBruni 3/18/2011 23:11'! named: aCategorySymbol ^ (self new) name: aCategorySymbol; yourself! ! Object subclass: #KMCategoryTarget instanceVariableNames: 'target category morph' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Core'! !KMCategoryTarget methodsFor: '*NautilusCommon-KeyMappingExtensions' stamp: 'BenjaminVanRyseghem 2/20/2012 19:19'! category ^ category! ! !KMCategoryTarget methodsFor: '*NautilusCommon-KeyMappingExtensions' stamp: 'BenjaminVanRyseghem 2/20/2012 19:19'! morph ^ morph! ! !KMCategoryTarget methodsFor: '*NautilusCommon-KeyMappingExtensions' stamp: 'BenjaminVanRyseghem 2/20/2012 19:19'! target ^ target! ! !KMCategoryTarget methodsFor: 'accessing' stamp: 'GuillermoPolito 10/20/2011 18:37'! category: aCategory category := aCategory! ! !KMCategoryTarget methodsFor: 'accessing' stamp: 'GuillermoPolito 10/20/2011 19:05'! morph: aMorph morph := aMorph! ! !KMCategoryTarget methodsFor: 'accessing' stamp: 'GuillermoPolito 10/20/2011 18:37'! target: aTarget target := aTarget! ! !KMCategoryTarget methodsFor: 'matching' stamp: 'CamilloBruni 9/27/2012 18:16'! 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: 'matching' stamp: 'GuillermoPolito 10/20/2011 18:53'! noMatch "do nothing" ! ! !KMCategoryTarget methodsFor: 'matching' stamp: 'GuillermoPolito 10/20/2011 18:53'! partialMatch "do nothing" ! ! !KMCategoryTarget 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! ! !KMCategoryTarget methodsFor: 'printing' stamp: 'SeanDeNigris 7/17/2012 09:04'! printOn: aStream aStream nextPutAll: 'aKMCategoryTarget('; nextPutAll: (category name ifNil: 'nil' ifNotNil: [ :n | n printString ]); nextPutAll: ')'.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! KMCategoryTarget class instanceVariableNames: ''! !KMCategoryTarget 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! ! AbstractKeymappingTest subclass: #KMCategoryTest instanceVariableNames: 'categoryContainer' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Tests'! !KMCategoryTest methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 3/18/2011 23:11'! categoryContainer ^ KMFactory keymapContainer! ! !KMCategoryTest methodsFor: 'as yet unclassified' stamp: 'DeboraFortini 12/13/2011 17:17'! testAddKeymapToCategory | categoryToAdd entry | categoryToAdd := KMCategory named: #TestCategory. entry := KMKeymap named: #Foo shortcut: $a asShortcut, $b asShortcut, $c asShortcut action: [ "nothing" ]. self assert: (categoryToAdd allEntries) size = 0. categoryToAdd addKeymapEntry: entry. self assert: (categoryToAdd allEntries) size = 1.! ! !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.! ! !KMCategoryTest methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 3/13/2011 17:33'! 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).! ! KMShortcut subclass: #KMChainedShortcut instanceVariableNames: 'shortcuts' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Shortcuts'! !KMChainedShortcut methodsFor: 'accessing' stamp: 'GuillermoPolito 12/24/2010 22:40'! addShortcut: aShortcut self shortcuts add: aShortcut! ! !KMChainedShortcut methodsFor: 'accessing' stamp: 'GuillermoPolito 12/24/2010 22:39'! first: aShortcut self addShortcut: aShortcut! ! !KMChainedShortcut methodsFor: 'accessing' stamp: 'GuillermoPolito 3/15/2011 00:42'! next: aShortcut self addShortcut: aShortcut! ! !KMChainedShortcut methodsFor: 'accessing' stamp: 'CamilloBruni 3/18/2011 23:11'! shortcuts ^ shortcuts ifNil: [ shortcuts := OrderedCollection new ]! ! !KMChainedShortcut methodsFor: 'building' stamp: 'GuillermoPolito 3/15/2011 00:33'! + aCharacter | last | last := self shortcuts last. self shortcuts removeLast. self addShortcut: last + aCharacter.! ! !KMChainedShortcut methodsFor: 'building' stamp: 'CamilloBruni 3/19/2011 20:26'! , aShortcut self addShortcut: aShortcut asShortcut.! ! !KMChainedShortcut methodsFor: 'building' stamp: 'GuillermoPolito 9/12/2011 16:42'! asShortcut ^self! ! !KMChainedShortcut methodsFor: 'comparing' stamp: 'CamilloBruni 3/18/2011 23:11'! = aShortcut ^ super = aShortcut and: [ shortcuts = aShortcut shortcuts ]! ! !KMChainedShortcut methodsFor: 'comparing' stamp: 'CamilloBruni 3/18/2011 23:11'! hash ^ shortcuts hash! ! !KMChainedShortcut methodsFor: 'comparing' stamp: 'GuillermoPolito 11/2/2011 22:33'! matches: anEventBuffer |maxIndex| maxIndex := anEventBuffer size min: shortcuts size. 1 to: maxIndex do: [:index| ((shortcuts at: index) = (anEventBuffer at: index) asShortcut) ifFalse: [ ^ false]]. ^ true.! ! !KMChainedShortcut methodsFor: 'printing' stamp: 'CamilloBruni 3/20/2011 23:44'! printOn: aStream shortcuts do: [ :shortcut| shortcut printOn: aStream] separatedBy: [ aStream nextPutAll: ' , '].! ! !KMChainedShortcut methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/3/2012 15:57'! beginsWith: aShortcut ^ self shortcuts first = aShortcut ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! KMChainedShortcut class instanceVariableNames: ''! !KMChainedShortcut class methodsFor: 'instance creation' stamp: 'CamilloBruni 3/18/2011 23:11'! first: aShortcut next: anotherShortcut ^ (self new) first: aShortcut; next: anotherShortcut; yourself! ! Object subclass: #KMCombinationShortcut instanceVariableNames: 'shortcuts' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Shortcuts'! !KMCombinationShortcut methodsFor: 'accessing' stamp: 'GuillermoPolito 9/24/2012 11:37'! shortcuts: someShortcuts shortcuts := someShortcuts! ! !KMCombinationShortcut methodsFor: 'combining' stamp: 'GuillermoPolito 9/24/2012 11:42'! collect: aBlock ^shortcuts collect: aBlock! ! !KMCombinationShortcut methodsFor: 'combining' stamp: 'GuillermoPolito 9/24/2012 11:41'! combinationsDo: aBlock ^shortcuts do: aBlock! ! !KMCombinationShortcut methodsFor: 'combining' stamp: 'GuillermoPolito 9/24/2012 11:40'! includes: aShortcut ^shortcuts includes: aShortcut! ! !KMCombinationShortcut methodsFor: 'combining' stamp: 'GuillermoPolito 9/24/2012 11:39'! | aShortcut ^KMCombinationShortcut withShortcuts: (shortcuts copyWith: aShortcut)! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! KMCombinationShortcut class instanceVariableNames: ''! !KMCombinationShortcut class methodsFor: 'instance creation' stamp: 'GuillermoPolito 9/24/2012 11:38'! withShortcuts: someShortcuts ^self new shortcuts: someShortcuts; yourself! ! AbstractKeymappingTest subclass: #KMCombinationTests instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Tests'! !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: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).! ! !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: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: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:16'! testWindowsDependentShortcut | shortcut | shortcut := $a ctrl win. self assert: (shortcut shortcut = $a ctrl). self assert: shortcut platform equals: #Windows.! ! KMModifier subclass: #KMCommandModifier instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Shortcuts'! !KMCommandModifier methodsFor: 'as yet unclassified' stamp: 'SeanDeNigris 11/22/2011 18:53'! eventCode ^ 64.! ! !KMCommandModifier methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 3/19/2011 20:50'! matchesEvent: aKeyboardEvent ^ aKeyboardEvent commandKeyPressed! ! !KMCommandModifier methodsFor: 'initialize-release' stamp: 'GuillermoPolito 5/31/2011 19:54'! initialize super initialize. identifier := #m. name := 'Cmd'.! ! Announcement subclass: #KMCompleteMatch instanceVariableNames: 'event source' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Core'! !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 ^ source! ! !KMCompleteMatch methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/3/2012 14:43'! source: anObject source := anObject! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! KMCompleteMatch class instanceVariableNames: ''! !KMCompleteMatch class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 7/3/2012 14:43'! event: event from: source ^ self new event: event; source: source; yourself! ! KMModifier subclass: #KMComposedModifier instanceVariableNames: 'modifiers' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Shortcuts'! !KMComposedModifier methodsFor: 'accessing' stamp: 'CamilloBruni 3/20/2011 23:47'! printOn: aStream modifiers do: [ :modifier| modifier printOn: aStream ] separatedBy: [ aStream << ' + ' ].! ! !KMComposedModifier methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 4/10/2011 02:32'! + modified ^ modified asShortcut modifiedBy: self! ! !KMComposedModifier methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 5/31/2011 18:26'! command modifiers add: KMModifier command! ! !KMComposedModifier methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 3/19/2011 21:17'! initialize super initialize. modifiers := Set new.! ! !KMComposedModifier methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 3/19/2011 21:18'! matchesEvent: aKeyboardEvent ^ modifiers allSatisfy: [:modifier| modifier matchesEvent: aKeyboardEvent]! ! !KMComposedModifier methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 3/20/2011 23:57'! modifiedBy: modifier modifiers add: modifier. self updateIdentifier.! ! !KMComposedModifier methodsFor: 'comparing' stamp: 'CamilloBruni 3/19/2011 21:22'! = aShortcut (aShortcut isKindOf: self class) ifFalse: [^ false]. ^ aShortcut modifiers = modifiers! ! !KMComposedModifier methodsFor: 'comparing' stamp: 'CamilloBruni 3/19/2011 21:20'! alt modifiers add: KMModifier alt! ! !KMComposedModifier methodsFor: 'comparing' stamp: 'CamilloBruni 3/19/2011 21:21'! ctrl modifiers add: KMModifier ctrl! ! !KMComposedModifier methodsFor: 'comparing' stamp: 'GuillermoPolito 5/1/2012 12:26'! hash ^ modifiers hash! ! !KMComposedModifier methodsFor: 'comparing' stamp: 'CamilloBruni 3/19/2011 21:23'! modifiers ^ modifiers! ! !KMComposedModifier methodsFor: 'comparing' stamp: 'CamilloBruni 3/19/2011 21:21'! shift modifiers add: KMModifier shift! ! !KMComposedModifier methodsFor: 'comparing' stamp: 'CamilloBruni 3/20/2011 23:59'! updateIdentifier identifier := String streamContents: [ :aStream| modifiers do: [ :modifier| aStream << modifier identifier]]. identifier := identifier asSymbol! ! KMModifier subclass: #KMCtrlModifier instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Shortcuts'! !KMCtrlModifier methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 3/19/2011 20:50'! matchesEvent: aKeyboardEvent ^ aKeyboardEvent controlKeyPressed! ! !KMCtrlModifier methodsFor: 'initialize-release' stamp: 'GuillermoPolito 4/9/2011 23:52'! initialize super initialize. identifier := #c. name := 'Ctrl'.! ! ComposableModel subclass: #KMDescription instanceVariableNames: 'list collectingBlock categories displayList sortingBlock updatingBlock okToolbar dropList' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Tools-Spec'! !KMDescription commentStamp: '' prior: 0! 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: 'BenjaminVanRyseghem 4/6/2012 15:38'! displayList ^ displayList! ! !KMDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/3/2012 16:09'! dropList ^ dropList! ! !KMDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/6/2012 15:00'! list ^ list! ! !KMDescription methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/3/2012 16:09'! okToolbar ^ okToolbar! ! !KMDescription methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 8/3/2012 16:08'! initialize "Initialization code for KMDescription" categories := nil asValueHolder. super initialize. updatingBlock := [:col || dropListItems | dropListItems := col collect: [:cat | DropListItem named: cat name do: [| items | items := (cat entriesAt: #all) keymaps collect: [:e | collectingBlock value: e ]. list items: (items sorted: sortingBlock) ]]. dropList items: dropListItems ].! ! !KMDescription methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 8/3/2012 16:09'! initializePresenter displayList whenSelectedItemChanged: [ updatingBlock value: categories contents ]. categories whenChangedDo: [:col | updatingBlock value: col ]. okToolbar okAction: [ self delete ].! ! !KMDescription methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 8/3/2012 16:09'! initializeWidgets self instantiateModels: #( #dropList DropListModel list MultiColumnListModel okToolbar OkToolbar displayList DropListModel ). displayList items: { DropListItem named:'shortcut : description' do: [ collectingBlock := [:e | {e shortcut asString. ':'. e description asString} ]. sortingBlock := [:a :b | a first < b first ]]. DropListItem named:'description : shortcut' do: [ collectingBlock := [:e | {e description asString. ':'. e shortcut asString} ]. sortingBlock := [:a :b | a first < b first ]]}. list displayBlock: [ :e | e ]; allowToSelect: false. okToolbar okButton label: 'Close'; state: false! ! !KMDescription methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/6/2012 15:34'! categories: aCollectionOfSymbols | cats | cats := aCollectionOfSymbols collect: [:e | KMRepository default categoryForName: e]. categories contents: cats! ! !KMDescription methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/6/2012 15:49'! initialExtent ^ (600@350)! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! KMDescription class instanceVariableNames: ''! !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 8/3/2012 16:09'! defaultSpec ^ SpecLayout composed newColumn: [:c | c newRow: [:r | r add: #dropList; add: #displayList ] height: 25; add: #list; add: #okToolbar height: 25 ]! ! !KMDescription class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 4/6/2012 15:46'! title ^ 'Shortcuts description'! ! Object subclass: #KMDispatcher instanceVariableNames: 'target currentEvent targets morph directKeymaps' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Core'! !KMDispatcher commentStamp: 'GuillermoPolito 12/24/2010 19:00' prior: 0! 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: 'accessing' stamp: 'CamilloBruni 3/18/2011 23:11'! target ^ target! ! !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: 'building' stamp: 'GuillermoPolito 10/20/2011 19:20'! attachCategory: aCategoryName self attachCategory: aCategoryName targetting: morph! ! !KMDispatcher methodsFor: 'building' stamp: 'GuillermoPolito 10/20/2011 23:35'! attachCategory: aCategoryName onProperty: aProperty self targets add: (KMCategoryTarget target: [ morph perform: aProperty ] morph: morph category: (KMRepository default categoryForName: aCategoryName) )! ! !KMDispatcher methodsFor: 'building' stamp: 'SeanDeNigris 7/11/2012 10:08'! attachCategory: aCategoryName targetting: anObject | isAlreadyAttached | isAlreadyAttached := self targets anySatisfy: [ :e | self flag: 'Maybe the following line should be reified as KMCategoryTarget>>=... Guille? - SeanDeNigris'. e category name = aCategoryName and: [ e target = anObject and: [ e morph = morph ] ] ]. isAlreadyAttached ifFalse: [ | category categoryTarget | category := KMRepository default categoryForName: aCategoryName. categoryTarget := KMCategoryTarget target: anObject morph: morph category: category. self targets add: categoryTarget ].! ! !KMDispatcher methodsFor: 'building' stamp: 'BenjaminVanRyseghem 2/20/2012 19:36'! detachAllKeymapCategories self targets removeAll! ! !KMDispatcher methodsFor: 'building' stamp: 'BenjaminVanRyseghem 2/20/2012 22:41'! detachKeymapCategory: aCategoryName self detachKeymapCategory: aCategoryName targetting: morph! ! !KMDispatcher methodsFor: 'building' stamp: 'SeanDeNigris 7/11/2012 10:16'! detachKeymapCategory: aCategoryName targetting: anObject | categoryTarget | categoryTarget := self targets detect: [ :tgt | tgt target = anObject and: [ tgt category name = aCategoryName ] ] ifNone: [ self error: 'Category ', aCategoryName, ' is not attached to ', morph asString ]. self targets remove: categoryTarget.! ! !KMDispatcher methodsFor: 'building' stamp: 'GuillermoPolito 1/21/2012 21:34'! on: aShortcut do: anAction self directKeymaps addKeymapEntry: (KMKeymap shortcut: aShortcut action: anAction)! ! !KMDispatcher methodsFor: 'dispatching' stamp: 'GuillermoPolito 10/20/2011 19:27'! directKeymaps ^directKeymaps ifNil: [ directKeymaps := KMCategory new ]! ! !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: 'dispatching' stamp: 'EstebanLorenzano 2/1/2013 15:14'! dispatchKeystroke: aKeyEvent | currentTarget | KMLog log: aKeyEvent printString, String cr. KMBuffer uniqueInstance addEvent: aKeyEvent. currentTarget := self target. [ aKeyEvent wasHandled not and: [ currentTarget notNil ] ] whileTrue: [ currentTarget dispatch: KMBuffer uniqueInstance buffer. currentTarget := currentTarget ownerTarget. ]. aKeyEvent wasHandled ifTrue: [ ^ self ]. KMBuffer uniqueInstance clearBuffer.! ! !KMDispatcher methodsFor: 'dispatching' stamp: 'GuillermoPolito 9/21/2012 16:13'! keymapObservers | o | o := OrderedCollection with: self perInstanceTarget. o addAll: self targets. o addAll: self staticTargets. ^ o! ! !KMDispatcher methodsFor: 'dispatching' stamp: 'GuillermoPolito 10/20/2011 19:30'! perInstanceTarget ^KMCategoryTarget target: morph morph: morph category: self directKeymaps.! ! !KMDispatcher methodsFor: 'dispatching' stamp: 'GuillermoPolito 11/2/2011 22:18'! staticTargets self flag: #deprecated. "static targets should not be used any more" ^(KMRepository default categoriesForClass: target realTarget class) collect: [ :cat | KMCategoryTarget target: target realTarget morph: target morph category: cat ].! ! !KMDispatcher methodsFor: 'dispatching' stamp: 'GuillermoPolito 10/20/2011 18:20'! targets ^targets ifNil: [ targets := Set new ]! ! !KMDispatcher methodsFor: 'initialize' stamp: 'ThierryGoubier 9/14/2012 15:35'! reset self resetTargets. self resetPerInstanceTarget! ! !KMDispatcher methodsFor: 'initialize' stamp: 'ThierryGoubier 9/14/2012 15:35'! resetPerInstanceTarget directKeymaps := nil! ! !KMDispatcher methodsFor: 'initialize' stamp: 'ThierryGoubier 9/14/2012 15:24'! resetTargets targets := nil! ! !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: '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: 'match' stamp: 'GuillermoPolito 6/24/2012 12:12'! noMatch! ! !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: 'testing' stamp: 'EstebanLorenzano 2/19/2013 14:42'! includesKeymapCategory: aCategoryName ^self includesKeymapCategory: aCategoryName targetting: morph! ! !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 class instanceVariableNames: ''! !KMDispatcher class methodsFor: 'instance creation' stamp: 'GuillermoPolito 5/30/2011 01:26'! target: aTarget ^ self target: #yourself morph: aTarget! ! !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! ! AbstractKeymappingTest subclass: #KMDispatcherTestCase instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Tests'! !KMDispatcherTestCase methodsFor: 'tests' stamp: 'CamilloBruni 3/18/2011 23:11'! keymapContainer ^ KMRepository default! ! !KMDispatcherTestCase methodsFor: 'tests' stamp: 'ThierryGoubier 9/17/2012 22:35'! testAttach | morph category | category := KMCategory named: #TestBlah. morph := BorderedMorph new. morph kmDispatcher reset. morph kmDispatcher targets isEmpty ifFalse: [ self error: 'should be empty' ]. KMRepository default addCategory: category. morph attachKeymapCategory: #TestBlah. morph attachKeymapCategory: #TestBlah. self assert: morph kmDispatcher targets size equals: 1.! ! !KMDispatcherTestCase methodsFor: 'tests' stamp: 'ThierryGoubier 9/19/2012 16:57'! testBuffering | morph flag category event1 event2 event3| category := KMCategory named: #TestBlah. morph := BorderedMorph new. morph kmDispatcher reset. KMRepository default attach: category to: BorderedMorph. flag := false. category addKeymapEntry: (KMKeymap named: #Foo shortcut: $a asShortcut, $b asShortcut, $c asShortcut action: [flag := true]). category addKeymapEntry: (KMKeymap named: #Bar shortcut: $p asShortcut, $p asShortcut action: []). morph attachKeymapCategory: #TestBlah. event1 := self eventKey: $a. morph kmDispatcher dispatchKeystroke: event1. self assert: morph kmDispatcher buffer size = 1. self assert: morph kmDispatcher buffer first = 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: 'ThierryGoubier 9/17/2012 22:36'! 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 methodsFor: 'tests' stamp: 'CamilloBruni 3/19/2011 19:50'! testNoMultiTrigger | bm1 bm2 km flag1 flag2 category otherCategory | category := KMCategory named: #TestBlah. otherCategory := KMCategory named: #TestFoo. KMRepository default addCategory: category. KMRepository default addCategory: otherCategory. KMRepository default attach: category to: BorderedMorph. bm1 := BorderedMorph new. flag1 := false. category addKeymapEntry: (KMKeymap named: #Foo shortcut: $a asShortcut, $b asShortcut, $c asShortcut action: [flag1 := true]). bm2 := KMMockMorph new. KMRepository default attach: otherCategory to: KMMockMorph. flag2 := false. otherCategory addKeymapEntry: (KMKeymap named: #Bar shortcut: $a asShortcut, $b asShortcut, $c asShortcut 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 12/21/2012 12:26'! testNoStaggeredTrigger "Once a key sequence is recognized by a keymapper, all other keymappers should clear their buffers" | bm1 bm2 km flag1 flag2 category otherCategory bufferBefore | category := KMCategory named: #TestBlah. otherCategory := KMCategory named: #TestFoo. KMRepository default addCategory: category. KMRepository default addCategory: otherCategory. bm1 := BorderedMorph new. KMRepository default attach: category to: EllipseMorph. flag1 := false. category addKeymapEntry: ( KMKeymap named: #Foo shortcut: $a asShortcut, $b asShortcut, $c asShortcut action: [flag1 := true]). bm2 := Morph new. KMRepository default attach: otherCategory to: Morph. flag2 := false. otherCategory addKeymapEntry: (KMKeymap named: #Bar shortcut: $a asShortcut, $b asShortcut 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 class instanceVariableNames: ''! !KMDispatcherTestCase class methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 3/18/2011 23:11'! keymapEventBuilderClass ^ KMFactory keymapEventBuilder! ! Object subclass: #KMFactory instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Core'! !KMFactory commentStamp: 'GuillermoPolito 2/24/2011 23:43' prior: 0! 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 instanceVariableNames: ''! !KMFactory class methodsFor: 'accessing' stamp: 'CamilloBruni 3/18/2011 23:11'! keymapContainer ^ KMRepository default! ! Object subclass: #KMKeymap instanceVariableNames: 'action name shortcut defaultShortcut description' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Core'! !KMKeymap commentStamp: 'GuillermoPolito 12/14/2010 21:33' prior: 0! I am the real keymap. I have an action to evaluate when my keymap sequence is pressed.! !KMKeymap methodsFor: 'accessing' stamp: 'CamilloBruni 3/18/2011 23:11'! action ^ action! ! !KMKeymap methodsFor: 'accessing' stamp: 'CamilloBruni 3/18/2011 23:35'! action: anAction action := anAction! ! !KMKeymap methodsFor: 'accessing' stamp: 'GuillermoPolito 10/18/2011 20:49'! defaultShortcut ^defaultShortcut! ! !KMKeymap methodsFor: 'accessing' stamp: 'GuillermoPolito 10/18/2011 20:49'! defaultShortcut: aShortcut defaultShortcut := aShortcut.! ! !KMKeymap methodsFor: 'accessing' stamp: 'GuillermoPolito 4/6/2012 13:28'! description ^description ifNil: [ '' ]! ! !KMKeymap methodsFor: 'accessing' stamp: 'GuillermoPolito 4/6/2012 13:28'! description: aDescription description := aDescription asString! ! !KMKeymap methodsFor: 'accessing' stamp: 'GuillermoPolito 9/12/2011 17:32'! hasName ^name notNil! ! !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: 'accessing' stamp: 'GuillermoPolito 12/26/2010 22:14'! name: aName name := aName! ! !KMKeymap methodsFor: 'accessing' 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'! shortcut ^ shortcut! ! !KMKeymap methodsFor: 'accessing' stamp: 'GuillermoPolito 3/14/2011 02:54'! shortcut: aShortcut shortcut := aShortcut.! ! !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: '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: 'comparing' stamp: 'GuillermoPolito 9/12/2011 17:49'! hash ^action hash bitXor: (shortcut hash bitXor: name hash)! ! !KMKeymap methodsFor: 'enabling/disabling' stamp: 'SeanDeNigris 7/8/2012 23:14'! disable self shortcut: KMNoShortcut new.! ! !KMKeymap methodsFor: 'enabling/disabling' stamp: 'SeanDeNigris 7/8/2012 23:27'! reset self shortcut: self defaultShortcut.! ! !KMKeymap methodsFor: 'executing' stamp: 'GuillermoPolito 10/20/2011 18:58'! executeActionTargetting: target ^ self action cull: target cull: target! ! !KMKeymap methodsFor: 'matching' stamp: 'BenjaminVanRyseghem 7/3/2012 13:42'! matches: anEventBuffer ^ anEventBuffer ifEmpty: [ false ] ifNotEmpty: [ self shortcut matches: anEventBuffer ]! ! !KMKeymap methodsFor: 'matching' stamp: 'GuillermoPolito 11/2/2011 22:33'! matchesCompletely: aShortcut ^ self shortcut = aShortcut asShortcut! ! !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: 'GuillermoPolito 10/20/2011 18:56'! notifyPartialMatchTo: aListener | listeners | aListener isCollection ifTrue: [ listeners := aListener ] ifFalse: [ { aListener } ]. listeners do: [ :l | l partialMatch ].! ! !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 instanceVariableNames: ''! !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! ! !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! ! Object subclass: #KMKeymapBuilder instanceVariableNames: 'shortcutName platform' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Pragmas'! !KMKeymapBuilder methodsFor: 'accessing' stamp: 'GuillermoPolito 10/21/2011 01:26'! platform: aPlatform platform := aPlatform! ! !KMKeymapBuilder methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 5/31/2011 11:57'! shortcutName: aShortcutName shortcutName := aShortcutName! ! !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 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: '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 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 class instanceVariableNames: ''! !KMKeymapBuilder class methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 10/21/2011 00:14'! for: aShortcutName platform: aPlatform ^self new shortcutName: aShortcutName; platform: aPlatform; yourself! ! AbstractKeymappingTest subclass: #KMKeymapTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Tests'! !KMKeymapTest methodsFor: 'tests' stamp: 'ThierryGoubier 9/19/2012 16:56'! assertExecutionOnClass: aClassToExecuteOn attachingTo: aClassToAttach | bm km flag category | category := (KMCategory named: #TestFoo). KMRepository default addCategory: category. bm := aClassToExecuteOn new. bm attachKeymapCategory: #TestFoo. flag := false. category addKeymapEntry: (KMKeymap named: #Foo shortcut: $a asShortcut, $b asShortcut, $c asShortcut action: [flag := true]). category addKeymapEntry: (KMKeymap named: #Bar shortcut: $p asShortcut, $p asShortcut action: []). {self eventKey: $a. self eventKey: $b. self eventKey: $c} do: [:e | bm dispatchKeystrokeForEvent: e]. self assert: flag.! ! !KMKeymapTest methodsFor: 'tests' stamp: 'DeboraFortini 12/13/2011 17:23'! keymapContainer ^ KMRepository default! ! !KMKeymapTest methodsFor: 'tests' stamp: 'DeboraFortini 12/13/2011 17:33'! testExecute self assertExecutionOnClass: KMMockMorph attachingTo: KMMockMorph! ! !KMKeymapTest methodsFor: 'tests' stamp: 'DeboraFortini 12/13/2011 17:33'! testExecuteForSubclass self assertExecutionOnClass: KMMockMorphSubclass attachingTo: KMMockMorph! ! !KMKeymapTest methodsFor: 'tests' stamp: 'CamilloBruni 3/20/2011 23:31'! 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 asShortcut, $b asShortcut, $c asShortcut action: blockAction). category addKeymapEntry: (KMKeymap named: #Fum shortcut: $p asShortcut, $p asShortcut 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 class instanceVariableNames: ''! !KMKeymapTest class methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 3/18/2011 23:11'! keymapEventBuilderClass ^ KMFactory keymapEventBuilder! ! Object subclass: #KMLog instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Core'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! KMLog class instanceVariableNames: 'debug'! !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'! removeDebug debug := false! ! !KMLog class methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 11/1/2011 17:51'! setDebug debug := true! ! Morph subclass: #KMMockMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Tests-Mocks'! KMMockMorph subclass: #KMMockMorphSubclass instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Tests-Mocks'! KMShortcut subclass: #KMModifiedShortcut instanceVariableNames: 'modifier character' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Shortcuts'! !KMModifiedShortcut methodsFor: 'accessing' stamp: 'CamilloBruni 3/18/2011 23:11'! character ^ character! ! !KMModifiedShortcut methodsFor: 'accessing' stamp: 'GuillermoPolito 12/25/2010 14:22'! character: aCharacter character := aCharacter.! ! !KMModifiedShortcut methodsFor: 'accessing' stamp: 'SeanDeNigris 11/22/2011 18:39'! key ^ self character key.! ! !KMModifiedShortcut methodsFor: 'accessing' stamp: 'CamilloBruni 3/18/2011 23:11'! modifier ^ modifier! ! !KMModifiedShortcut methodsFor: 'accessing' stamp: 'GuillermoPolito 12/24/2010 22:31'! modifier: aModifier modifier := aModifier! ! !KMModifiedShortcut methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 5/31/2011 18:26'! command ^ self modifiedBy: KMModifier command! ! !KMModifiedShortcut methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 10/20/2011 15:51'! matchesEvent: aKeyboardEvent ^ (self modifier matchesEvent: aKeyboardEvent) and: [self character matchesEvent: aKeyboardEvent]! ! !KMModifiedShortcut methodsFor: 'building' stamp: 'CamilloBruni 3/19/2011 21:19'! alt ^ self modifiedBy: KMModifier alt! ! !KMModifiedShortcut methodsFor: 'building' stamp: 'CamilloBruni 3/18/2011 23:11'! asShortcut ^ self! ! !KMModifiedShortcut methodsFor: 'building' stamp: 'CamilloBruni 3/18/2011 23:11'! ctrl ^ self modifiedBy: KMModifier ctrl! ! !KMModifiedShortcut methodsFor: 'building' stamp: 'CamilloBruni 3/18/2011 23:11'! shift ^ self modifiedBy: KMModifier shift! ! !KMModifiedShortcut methodsFor: 'comparing' stamp: 'GuillermoPolito 10/20/2011 16:30'! = aShortcut super = aShortcut ifFalse: [ ^ false ]. aShortcut modifier = modifier ifFalse: [ ^ false ]. aShortcut character = character ifFalse: [ ^ false ]. ^ true! ! !KMModifiedShortcut methodsFor: 'comparing' stamp: 'CamilloBruni 3/18/2011 23:11'! hash ^ character hash + modifier hash! ! !KMModifiedShortcut methodsFor: 'printing' stamp: 'GuillermoPolito 4/9/2011 23:57'! modifiedBy: aModifier modifier := modifier + aModifier.! ! !KMModifiedShortcut methodsFor: 'printing' stamp: 'CamilloBruni 3/20/2011 23:45'! printOn: aStream modifier printOn: aStream. aStream << ' + '. character printOn: aStream.! ! !KMModifiedShortcut methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/3/2012 15:59'! beginsWith: aKMShortcut ^ self = aKMShortcut ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! KMModifiedShortcut class instanceVariableNames: ''! !KMModifiedShortcut class methodsFor: 'instance creation' stamp: 'CamilloBruni 3/18/2011 23:11'! modifier: aModifier character: aCharacter ^ (self new) modifier: aModifier; character: aCharacter; yourself! ! KMShortcut subclass: #KMModifier instanceVariableNames: 'identifier name' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Shortcuts'! !KMModifier methodsFor: 'accessing' stamp: 'SeanDeNigris 11/22/2011 19:00'! eventCode "No modifiers" ^ 0.! ! !KMModifier methodsFor: 'accessing' stamp: 'CamilloBruni 3/20/2011 23:54'! kmString ^ identifier! ! !KMModifier methodsFor: 'accessing' stamp: 'CamilloBruni 3/20/2011 23:54'! printOn: aStream aStream << name! ! !KMModifier methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 3/19/2011 21:25'! + modifier ^ modifier asShortcut modifiedBy: self! ! !KMModifier methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 3/20/2011 23:54'! identifier ^ identifier! ! !KMModifier methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 3/19/2011 20:49'! matches: aKeyboardEvent self shouldNotImplement! ! !KMModifier methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 3/19/2011 20:50'! matchesEvent: aKeyboardEvent self subclassResponsibility! ! !KMModifier methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 3/19/2011 21:16'! modifiedBy: modifier ^ KMComposedModifier new modifiedBy: modifier; modifiedBy: self; yourself! ! !KMModifier methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 3/20/2011 23:54'! name ^ name! ! !KMModifier methodsFor: 'building' stamp: 'CamilloBruni 3/18/2011 23:11'! asShortcut ^ self! ! !KMModifier methodsFor: 'comparing' stamp: 'CamilloBruni 3/20/2011 23:58'! = aShortcut super = aShortcut ifFalse: [ ^ false ]. aShortcut identifier = identifier ifFalse: [ ^ false ]. ^ true! ! !KMModifier methodsFor: 'comparing' stamp: 'CamilloBruni 3/20/2011 23:54'! hash ^ identifier hash bitXor: name hash! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! KMModifier class instanceVariableNames: ''! !KMModifier class methodsFor: 'building' stamp: 'CamilloBruni 3/18/2011 23:11'! alt ^ KMAltModifier new! ! !KMModifier class methodsFor: 'building' stamp: 'GuillermoPolito 5/31/2011 18:25'! command ^ KMCommandModifier new! ! !KMModifier class methodsFor: 'building' stamp: 'CamilloBruni 3/18/2011 23:11'! ctrl ^ KMCtrlModifier new! ! !KMModifier class methodsFor: 'building' stamp: 'CamilloBruni 3/18/2011 23:11'! shift ^ KMShiftModifier new! ! Object subclass: #KMNoKeymap instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Core'! !KMNoKeymap commentStamp: 'GuillermoPolito 2/24/2011 23:43' prior: 0! I am a Null object representing the absence of a Keymap.! !KMNoKeymap methodsFor: 'accessing' stamp: 'CamilloBruni 3/18/2011 23:11'! shortcut ^ KMNoShortcut new! ! KMShortcut subclass: #KMNoShortcut instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Shortcuts'! !KMNoShortcut commentStamp: 'CamilloBruni 3/21/2011 00:05' prior: 0! I do not respond to any keyboard event. Mostly used in the settings to deactivate a certain command.! !KMNoShortcut methodsFor: 'accessing' stamp: 'CamilloBruni 3/20/2011 23:41'! printOn: aStream! ! !KMNoShortcut methodsFor: 'building' stamp: 'CamilloBruni 3/18/2011 23:11'! + aKMModifier ^ aKMModifier! ! !KMNoShortcut methodsFor: 'building' stamp: 'CamilloBruni 3/18/2011 23:11'! , aShortcut ^ aShortcut! ! !KMNoShortcut methodsFor: 'matching' stamp: 'CamilloBruni 3/20/2011 23:50'! matches: anEventBuffer ^ false! ! !KMNoShortcut methodsFor: 'matching' stamp: 'CamilloBruni 3/20/2011 23:50'! matchesCompletely: anEventBuffer ^ false! ! Announcement subclass: #KMPartialMatch instanceVariableNames: 'event source' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Core'! !KMPartialMatch commentStamp: '' prior: 0! 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 ^ source! ! !KMPartialMatch methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/3/2012 14:42'! source: anObject source := anObject! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! KMPartialMatch class instanceVariableNames: ''! !KMPartialMatch class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 7/3/2012 14:42'! event: event from: source ^ self new event: event; source: source; yourself! ! AbstractKeymappingTest subclass: #KMPerInstanceTests instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Tests'! !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.! ! Object subclass: #KMPlatformSpecificShortcut instanceVariableNames: 'shortcut platform' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Shortcuts'! !KMPlatformSpecificShortcut methodsFor: 'accessing' stamp: 'GuillermoPolito 9/24/2012 11:15'! platform ^platform! ! !KMPlatformSpecificShortcut methodsFor: 'accessing' stamp: 'GuillermoPolito 9/24/2012 11:14'! platform: aPlatform platform := aPlatform! ! !KMPlatformSpecificShortcut methodsFor: 'accessing' stamp: 'GuillermoPolito 9/24/2012 11:14'! shortcut ^shortcut! ! !KMPlatformSpecificShortcut methodsFor: 'accessing' stamp: 'GuillermoPolito 9/24/2012 11:13'! shortcut: aShortcut shortcut := aShortcut! ! !KMPlatformSpecificShortcut methodsFor: 'combining' stamp: 'GuillermoPolito 9/24/2012 11:40'! combinationsDo: aBlock aBlock value: self! ! !KMPlatformSpecificShortcut methodsFor: 'combining' stamp: 'GuillermoPolito 9/24/2012 11:38'! | aShortcut ^KMCombinationShortcut withShortcuts: { self . aShortcut }! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! KMPlatformSpecificShortcut class instanceVariableNames: ''! !KMPlatformSpecificShortcut class methodsFor: 'instance creation' stamp: 'GuillermoPolito 9/24/2012 11:14'! with: aShortcut onPlatform: aPlatform ^self new shortcut: aShortcut; platform: aPlatform; yourself! ! Object subclass: #KMPragmaKeymapBuilder instanceVariableNames: 'pragmaKeywords model pragmaCollector' classVariableNames: 'UniqueInstace' poolDictionaries: '' category: 'Keymapping-Pragmas'! !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: 'accessing' stamp: 'GuillermoPolito 12/17/2010 00:46'! model ^ model! ! !KMPragmaKeymapBuilder methodsFor: 'accessing' stamp: 'GuillermoPolito 12/17/2010 00:46'! model: anObject model := anObject! ! !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: 'initialize-release' stamp: 'GuillermoPolito 12/17/2010 00:58'! initialize super initialize. pragmaKeywords := OrderedCollection new. ! ! !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 methodsFor: 'initialize-release' stamp: 'GuillermoPolito 1/27/2011 18:10'! reset pragmaCollector := nil. "KeymapManager default: KeymapManager new." self collectRegistrations.! ! !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: '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: '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 class instanceVariableNames: ''! !KMPragmaKeymapBuilder class methodsFor: 'instance creation' stamp: 'GuillermoPolito 7/31/2012 12:00'! initialize "KMPragmaKeymapBuilder initialize" self uniqueInstance reset.! ! !KMPragmaKeymapBuilder class methodsFor: 'instance creation' stamp: 'GuillermoPolito 10/20/2011 23:55'! pragmas ^#(#keymap #keymap:)! ! !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: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.! ! !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 ]! ! Object subclass: #KMRepository instanceVariableNames: 'categories categoryHolders' classVariableNames: 'Singleton' poolDictionaries: '' category: 'Keymapping-Core'! !KMRepository commentStamp: 'GuillermoPolito 12/14/2010 21:37' prior: 0! 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: 'GuillermoPolito 11/2/2011 22:14'! categoriesForClass: aClass | classCategories superclassCategories | aClass == Object ifTrue: [ ^ Set new ]. classCategories := self categoryHolders at: aClass ifAbsent: [ Set new ]. superclassCategories := self categoriesForClass: aClass superclass. ^ classCategories union: superclassCategories! ! !KMRepository methodsFor: 'accessing' stamp: 'GuillermoPolito 5/31/2011 11:26'! categoryForName: aCategorySymbol ^ self categories at: aCategorySymbol ifAbsentPut: [ KMCategory named: aCategorySymbol ]! ! !KMRepository methodsFor: 'accessing' stamp: 'CamilloBruni 3/18/2011 23:11'! categoryHolders ^ categoryHolders ifNil: [ categoryHolders := Dictionary new ]! ! !KMRepository methodsFor: 'accessing' stamp: 'CamilloBruni 3/18/2011 23:11'! ensureCategoryByName: aCategorySymbol | category | (self includesCategoryNamed: aCategorySymbol) ifFalse: [ category := KMCategory named: aCategorySymbol. self addCategory: category ] ifTrue: [ category := self categoryForName: aCategorySymbol ]. ^ category! ! !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 4/6/2012 13:25'! 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 asShortcut named: shortcutName do: action withDescription: aDescription. category addKeymapEntry: entry at: aPlatform. ] ifFalse:[ entry := category keymapNamed: shortcutName at: aPlatform. entry shortcutHasChangedBy: shortcut asShortcut. entry action: action. entry description: aDescription ]! ! !KMRepository methodsFor: 'accessing' stamp: 'CamilloBruni 3/18/2011 23:11'! keymapNamed: aKeymapName inCategory: aKeymapCategory ^ (self categoryForName: aKeymapCategory) keymapNamed: aKeymapName! ! !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 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: 'keymaps' stamp: 'GuillermoPolito 3/13/2011 17:58'! attachCategoryName: aCategorySymbol to: aClass self attach: (self ensureCategoryByName: aCategorySymbol) to: aClass.! ! !KMRepository methodsFor: 'testing' stamp: 'CamilloBruni 3/18/2011 23:11'! includesCategory: aCategory ^ self categories includes: aCategory! ! !KMRepository methodsFor: 'testing' stamp: 'CamilloBruni 3/18/2011 23:11'! includesCategoryNamed: aCategorySymbol ^ self categories includesKey: aCategorySymbol! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! KMRepository class instanceVariableNames: ''! !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: 'instance creation' stamp: 'ThierryGoubier 9/17/2012 21:58'! 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." self default: self new. KMPragmaKeymapBuilder uniqueInstance reset! ! KMModifier subclass: #KMShiftModifier instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Shortcuts'! !KMShiftModifier methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 10/20/2011 15:50'! matchesEvent: aKeyboardEvent ^ aKeyboardEvent shiftPressed! ! !KMShiftModifier methodsFor: 'initialize-release' stamp: 'CamilloBruni 3/20/2011 23:55'! initialize super initialize. identifier := #s. name := 'Shift'.! ! Object subclass: #KMShortcut instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Shortcuts'! !KMShortcut methodsFor: 'building' stamp: 'CamilloBruni 3/18/2011 23:11'! , aShortcut ^ KMChainedShortcut first: self next: aShortcut asShortcut! ! !KMShortcut methodsFor: 'building' stamp: 'GuillermoPolito 4/6/2012 13:26'! named: keymapName do: anActionBlock ^ KMKeymap named: keymapName shortcut: self action: anActionBlock! ! !KMShortcut methodsFor: 'building' stamp: 'GuillermoPolito 4/6/2012 13:49'! named: keymapName do: anActionBlock withDescription: aDescription ^ KMKeymap named: keymapName shortcut: self action: anActionBlock description: aDescription! ! !KMShortcut methodsFor: 'building' stamp: 'CamilloBruni 3/18/2011 23:11'! value: aBuilder ^ self! ! !KMShortcut methodsFor: 'combination' stamp: 'GuillermoPolito 9/24/2012 11:40'! combinationsDo: aBlock aBlock value: self! ! !KMShortcut methodsFor: 'combination' stamp: 'GuillermoPolito 9/24/2012 11:04'! includes: aShortcut ^self = aShortcut! ! !KMShortcut methodsFor: 'combination' stamp: 'GuillermoPolito 9/24/2012 11:23'! mac ^KMPlatformSpecificShortcut with: self onPlatform: #MacOSX! ! !KMShortcut methodsFor: 'combination' stamp: 'GuillermoPolito 9/24/2012 11:10'! platform ^#all! ! !KMShortcut methodsFor: 'combination' stamp: 'GuillermoPolito 9/24/2012 10:59'! shortcut ^self! ! !KMShortcut methodsFor: 'combination' stamp: 'GuillermoPolito 9/24/2012 11:23'! unix ^KMPlatformSpecificShortcut with: self onPlatform: #Unix! ! !KMShortcut methodsFor: 'combination' stamp: 'GuillermoPolito 9/24/2012 11:15'! win ^KMPlatformSpecificShortcut with: self onPlatform: #Windows! ! !KMShortcut methodsFor: 'combination' stamp: 'GuillermoPolito 9/24/2012 11:38'! | aShortcut ^KMCombinationShortcut withShortcuts: { self . aShortcut }! ! !KMShortcut methodsFor: 'comparing' stamp: 'CamilloBruni 3/18/2011 23:11'! = aShortcut ^ aShortcut isKindOf: self species! ! !KMShortcut methodsFor: 'comparing' stamp: 'CamilloBruni 3/18/2011 23:11'! hash ^ self species hash! ! !KMShortcut methodsFor: 'comparing' stamp: 'GuillermoPolito 10/20/2011 16:42'! matches: anEventBuffer ^ self matchesCompletely: anEventBuffer first! ! !KMShortcut methodsFor: 'comparing' stamp: 'GuillermoPolito 11/2/2011 22:30'! matchesCompletely: aKeyboardEvent ^self = aKeyboardEvent asShortcut! ! !KMShortcut methodsFor: 'converting' stamp: 'GuillermoPolito 11/2/2011 22:33'! asShortcut ^self! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! KMShortcut class instanceVariableNames: ''! !KMShortcut class methodsFor: 'building' stamp: 'DeboraFortini 12/13/2011 14:25'! fromKeyboardEvent: evt | modifier control command shift hasModifier keyString | control := evt controlKeyPressed. command := evt commandKeyPressed. shift := evt shiftPressed. (shift | command | control) ifFalse: [^ KMSingleKeyShortcut from: evt keyCharacter ]. modifier := KMNoShortcut new. control ifTrue: [ modifier := modifier + KMModifier ctrl ]. command ifTrue: [ modifier := modifier + KMModifier command ]. shift ifTrue: [ modifier := modifier + KMModifier shift ]. ^ modifier + evt modifiedCharacter! ! SettingDeclaration subclass: #KMShortcutDeclaration instanceVariableNames: 'categoryName declaration shortcutName' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Settings'! !KMShortcutDeclaration methodsFor: 'accessing' stamp: 'GuillermoPolito 5/31/2011 12:27'! categoryName ^categoryName! ! !KMShortcutDeclaration methodsFor: 'accessing' stamp: 'GuillermoPolito 5/31/2011 12:27'! categoryName: aCategoryName categoryName := aCategoryName! ! !KMShortcutDeclaration methodsFor: 'accessing' stamp: 'GuillermoPolito 10/18/2011 20:52'! defaultValue ^self realValue defaultShortcut! ! !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:58'! realValue: aShortcut self realValue accept: aShortcut.! ! !KMShortcutDeclaration methodsFor: 'accessing' stamp: 'GuillermoPolito 5/31/2011 13:54'! shortcutName ^shortcutName! ! !KMShortcutDeclaration methodsFor: 'accessing' stamp: 'GuillermoPolito 5/31/2011 13:54'! shortcutName: aShortcutName shortcutName := aShortcutName! ! Object subclass: #KMShortcutSetting instanceVariableNames: 'shortcutName category action' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Settings'! !KMShortcutSetting methodsFor: 'accessing' stamp: 'GuillermoPolito 1/24/2011 22:02'! action: anActionBlock action := anActionBlock! ! !KMShortcutSetting methodsFor: 'accessing' stamp: 'GuillermoPolito 1/20/2011 00:55'! category: aCategory category := aCategory! ! !KMShortcutSetting methodsFor: 'accessing' stamp: 'GuillermoPolito 10/18/2011 20:52'! defaultShortcut ^ self keymap defaultShortcut! ! !KMShortcutSetting methodsFor: 'accessing' stamp: 'GuillermoPolito 5/31/2011 12:43'! keymap ^ KMFactory keymapContainer keymapNamed: shortcutName inCategory: category! ! !KMShortcutSetting methodsFor: 'accessing' stamp: 'CamilloBruni 3/18/2011 23:11'! keystrokes ^ self keymap shortcut! ! !KMShortcutSetting methodsFor: 'accessing' stamp: 'CamilloBruni 3/18/2011 23:11'! shortcut ^ self keymap shortcut! ! !KMShortcutSetting methodsFor: 'accessing' stamp: 'GuillermoPolito 5/31/2011 12:46'! shortcutName: aShortcutName shortcutName := aShortcutName! ! !KMShortcutSetting methodsFor: 'setting' stamp: 'GuillermoPolito 1/24/2011 01:13'! accept: aShortcut self keymap shortcut: aShortcut! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! KMShortcutSetting class instanceVariableNames: ''! !KMShortcutSetting class methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 3/18/2011 23:11'! for: aShortcutName in: aCategory ^ (self new) shortcutName: aShortcutName; category: aCategory; yourself! ! !KMShortcutSetting class methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 3/18/2011 23:11'! settingInputWidgetForNode: aSettingNode | catcherMorph theme | theme := UITheme builder. catcherMorph := KMCatcherMorph for: aSettingNode realValue. ^ theme newRow: {catcherMorph}! ! AbstractKeymappingTest subclass: #KMShortcutTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Tests'! !KMShortcutTest methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 5/31/2011 19: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 = 'Ctrl + Cmd + E'.! ! !KMShortcutTest methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 3/21/2011 21:56'! testBadComposedCmdShortcutFails ^ self should: [ KMModifier ctrl ctrl ] raise: Error! ! !KMShortcutTest methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 3/21/2011 21:56'! testChainIntegerSucceds ^ self assert: ($e ctrl , 1) = ($e ctrl , 1)! ! !KMShortcutTest methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 3/21/2011 21:56'! testChainShortcutSucceds ^ self assert: ($e ctrl , $e ctrl) = ($e ctrl , $e ctrl)! ! !KMShortcutTest methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 3/21/2011 21:56'! testChainSimpleCharsSucceds ^ self assert: ($e ctrl , $e) = ($e ctrl , $e)! ! !KMShortcutTest methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 3/21/2011 21:56'! testCmdIntegerSucceds ^ self assert: 1 ctrl = 1 ctrl! ! !KMShortcutTest methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 3/21/2011 21:56'! testCmdKeySucceds ^ self assert: $e ctrl = $e ctrl! ! !KMShortcutTest methodsFor: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'GuillermoPolito 5/31/2011 19:52'! testCreation self assert: ($e asShortcut isKindOf: KMSingleKeyShortcut). self assert: ($e ctrl isKindOf: KMModifiedShortcut). self assert: ($e ctrl alt shift command isKindOf: KMModifiedShortcut).! ! !KMShortcutTest methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'CamilloBruni 3/21/2011 21:56'! testShiftKeySucceds ^ self assert: $e shift = $e shift! ! !KMShortcutTest methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'GuillermoPolito 4/10/2011 02:27'! testSingleShortcutsMatch |a one home | a := self eventKey: $a. one := self eventKey: 1 asCharacter. home := self eventKey: Character home. self assert: ($a asShortcut matches: {a}). self assert: (1 asShortcut matches: {one}). self assert: (Character home asShortcut matches: {home}). self deny: ($b asShortcut matches: {a}). self assert: ($a asShortcut matchesCompletely: {a}). self assert: (1 asShortcut matchesCompletely: {one}).! ! !KMShortcutTest methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 3/21/2011 21:56'! testTripleChainShortcutSucceds ^ self assert: ($e ctrl , $e ctrl , $d ctrl) = ($e ctrl , $e ctrl , $d ctrl)! ! KMShortcut subclass: #KMSingleKeyShortcut instanceVariableNames: 'key' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Shortcuts'! !KMSingleKeyShortcut methodsFor: 'accessing' stamp: 'CamilloBruni 3/18/2011 23:11'! key ^ key! ! !KMSingleKeyShortcut methodsFor: 'accessing' stamp: 'GuillermoPolito 12/25/2010 14:21'! key: aKeyString key := aKeyString.! ! !KMSingleKeyShortcut methodsFor: 'accessing' stamp: 'SeanDeNigris 11/22/2011 18:59'! modifier ^ KMModifier new.! ! !KMSingleKeyShortcut methodsFor: 'as yet unclassified' stamp: 'DeboraFortini 10/18/2011 19:40'! matchesEvent: aKeyboardEvent ^ self key asLowercase = aKeyboardEvent modifiedCharacter asLowercase! ! !KMSingleKeyShortcut methodsFor: 'building' stamp: 'CamilloBruni 3/18/2011 23:11'! asShortcut ^ self! ! !KMSingleKeyShortcut methodsFor: 'building' stamp: 'CamilloBruni 3/19/2011 21:13'! modifiedBy: aModifier ^ KMModifiedShortcut modifier: aModifier character: self! ! !KMSingleKeyShortcut methodsFor: 'comparing' stamp: 'GuillermoPolito 10/20/2011 16:30'! = aShortcut ^ super = aShortcut and: [ aShortcut key sameAs: key ]! ! !KMSingleKeyShortcut methodsFor: 'comparing' stamp: 'CamilloBruni 3/18/2011 23:11'! hash ^ key hash! ! !KMSingleKeyShortcut methodsFor: 'showing' stamp: 'GuillermoPolito 4/10/2011 02:37'! printOn: aStream aStream nextPutAll: (self printStringFor: key) asString asUppercase.! ! !KMSingleKeyShortcut methodsFor: 'showing' stamp: 'GuillermoPolito 4/10/2011 02:17'! printStringFor: aCharacter | specialKeys | specialKeys := self specialKeys. ^specialKeys at: aCharacter asciiValue ifAbsent: [ aCharacter ].! ! !KMSingleKeyShortcut methodsFor: 'showing' stamp: 'GuillermoPolito 4/10/2011 02:18'! specialKeys ^self class specialKeys! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! KMSingleKeyShortcut class instanceVariableNames: 'specialKeys'! !KMSingleKeyShortcut class methodsFor: 'building' stamp: 'CamilloBruni 3/18/2011 23:25'! from: aString ^ (self new) key: aString asCharacter; yourself! ! !KMSingleKeyShortcut class methodsFor: 'building' stamp: 'GuillermoPolito 10/21/2011 09:33'! 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.]! ! Object subclass: #KMStorage instanceVariableNames: 'namedRegistry annonimousRegistry' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Core'! !KMStorage methodsFor: 'accessing' stamp: 'GuillermoPolito 1/21/2012 21:02'! , aKMStorage ^self class new addAll: self keymaps; addAll: aKMStorage keymaps.! ! !KMStorage methodsFor: 'accessing' stamp: 'GuillermoPolito 1/21/2012 21:00'! add: aKeymap aKeymap hasName ifTrue: [ namedRegistry at: aKeymap name put: aKeymap ] ifFalse: [ annonimousRegistry add: aKeymap ].! ! !KMStorage methodsFor: 'accessing' stamp: 'GuillermoPolito 1/21/2012 20:52'! addAll: keymaps keymaps do: [ :km | self add: km ].! ! !KMStorage methodsFor: 'accessing' stamp: 'GuillermoPolito 1/21/2012 20:56'! hasKeymapNamed: aKmName ^namedRegistry includesKey: aKmName! ! !KMStorage methodsFor: 'accessing' stamp: 'GuillermoPolito 1/21/2012 20:57'! keymapNamed: aKmName ^namedRegistry at: aKmName! ! !KMStorage methodsFor: 'accessing' stamp: 'GuillermoPolito 1/21/2012 20:55'! keymaps ^annonimousRegistry , namedRegistry values! ! !KMStorage methodsFor: 'accessing' stamp: 'GuillermoPolito 1/21/2012 21:01'! size ^self keymaps size! ! !KMStorage methodsFor: 'initialize-release' stamp: 'GuillermoPolito 1/21/2012 20:49'! initialize annonimousRegistry := Set new. namedRegistry := Dictionary new.! ! Object subclass: #KMTarget instanceVariableNames: 'realTarget morph targetSelector directKeymaps perInstanceCategories' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Core'! !KMTarget commentStamp: 'GuillermoPolito 2/24/2011 23:44' prior: 0! I am the reification of the Keymap target. I am the one that receives the actions.! !KMTarget methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/3/2012 14:46'! dispatch: buffer morph kmDispatcher dispatch: KMBuffer uniqueInstance buffer copy! ! !KMTarget methodsFor: 'accessing' stamp: 'GuillermoPolito 6/24/2012 12:09'! dispatchOwnerKeystroke: aKeyEvent morph owner ifNil: [ ^ self ]. morph owner kmDispatcher dispatch: KMBuffer uniqueInstance buffer! ! !KMTarget methodsFor: 'accessing' stamp: 'GuillermoPolito 10/20/2011 19:07'! morph ^morph! ! !KMTarget methodsFor: 'accessing' stamp: 'GuillermoPolito 5/29/2011 23:50'! morph: aMorph morph := aMorph! ! !KMTarget methodsFor: 'accessing' stamp: 'GuillermoPolito 6/24/2012 12:42'! ownerTarget morph owner ifNil: [ ^nil ]. ^morph owner kmDispatcher target.! ! !KMTarget methodsFor: 'accessing' stamp: 'GuillermoPolito 5/31/2011 11:15'! realTarget ^morph perform: self targetSelector! ! !KMTarget methodsFor: 'accessing' stamp: 'GuillermoPolito 5/31/2011 11:18'! targetSelector ^targetSelector ifNil: [ #yourself ]! ! !KMTarget methodsFor: 'accessing' stamp: 'GuillermoPolito 5/31/2011 11:10'! targetSelector: aTargetSelector targetSelector := aTargetSelector! ! !KMTarget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/3/2012 12:51'! announcer ^ self morph announcer! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! KMTarget class instanceVariableNames: ''! !KMTarget class methodsFor: 'instance creation' stamp: 'GuillermoPolito 5/31/2011 11:11'! for: aTarget in: aMorph ^ (self new) targetSelector: aTarget; morph: aMorph; yourself! ! ByteTextConverter subclass: #KOI8RTextConverter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Multilingual-TextConversion'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! KOI8RTextConverter class instanceVariableNames: ''! !KOI8RTextConverter class methodsFor: 'accessing' stamp: 'yo 12/11/2007 10:59'! encodingNames ^ #('koi8-r') copy ! ! !KOI8RTextConverter class methodsFor: 'accessing' stamp: 'michael.rueger 2/2/2009 18:53'! languageEnvironment ^RussianEnvironment! ! !KOI8RTextConverter class methodsFor: 'as yet unclassified'! initialize self initializeTables! ! !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 )! ! EncodedCharSet subclass: #KSX1001 instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Multilingual-Encodings'! !KSX1001 commentStamp: 'yo 10/19/2004 19:53' prior: 0! This class represents the domestic character encoding called KS X 1001 used for Korean.! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! KSX1001 class instanceVariableNames: ''! !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: 'Alexandre.Bergel 11/20/2008 11:17'! compoundTextSequence ^ compoundTextSequence! ! !KSX1001 class methodsFor: 'class methods' stamp: 'Alexandre.Bergel 11/20/2008 11:17'! initialize " KSX1001 initialize " compoundTextSequence := String streamContents: [ :stream | stream nextPut: Character escape. stream nextPut: $$. stream nextPut: $(. stream nextPut: $C ]! ! !KSX1001 class methodsFor: 'class methods' stamp: 'yo 10/22/2002 19:49'! leadingChar ^ 3. ! ! !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/14/2003 10:19'! ucsTable ^ UCSTable ksx1001Table. ! ! Object subclass: #KeyChain instanceVariableNames: 'username password encryptor lastUnlock encryptorDecryptor bindings' classVariableNames: '' poolDictionaries: '' category: 'KeyChain'! !KeyChain commentStamp: '' prior: 0! 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: 'accessing' stamp: 'BenjaminVanRyseghem 5/9/2012 13:16'! username ^ username! ! !KeyChain methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/9/2012 13:16'! username: aString username := aString ! ! !KeyChain methodsFor: 'encryption' stamp: 'BenjaminVanRyseghem 5/6/2012 22:26'! decryptPassword: aString ^ encryptorDecryptor decrypt: aString base: password! ! !KeyChain methodsFor: 'encryption' stamp: 'BenjaminVanRyseghem 5/6/2012 22:10'! encryptPassword: aString ^ encryptorDecryptor encrypt: aString base: password! ! !KeyChain methodsFor: 'encryption' stamp: 'BenjaminVanRyseghem 5/9/2012 13:25'! reEncryptKeysBased: aFormerBase bindings associations do: [:assoc || oldUsernamePassword string | oldUsernamePassword := bindings at: assoc key. string := encryptorDecryptor decrypt: oldUsernamePassword password base: aFormerBase. bindings at: assoc key put: ( UsernamePassword username: oldUsernamePassword username password: (self encryptPassword: string) )]! ! !KeyChain methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 5/9/2012 16:40'! initialize "Initialization code for KeyChain" super initialize. bindings := IdentityDictionary new. encryptor := SHA1Ecryptor new. encryptorDecryptor := DummyEcryptorDecryptor new. password := nil. lastUnlock := Cookie new defaultValue: false; timeToLive: self defaultTimeBetweenUnlocks; yourself.! ! !KeyChain methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/9/2012 13:25'! groups ^ bindings keys! ! !KeyChain methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/11/2012 18:04'! isLocked ^ true! ! !KeyChain methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/20/2012 03:25'! lock lastUnlock contents: false.! ! !KeyChain methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/10/2012 13:55'! removeUserNamePasswordFor: aGroup ^ self isUnlocked ifTrue: [ bindings removeKey: aGroup ]! ! !KeyChain methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/9/2012 13:25'! setEncryptorDecryptor: anEncryptorDecryptor self isUnlocked ifTrue: [ | oldDecryptor | oldDecryptor := encryptorDecryptor. encryptorDecryptor := anEncryptorDecryptor . bindings associations do: [:assoc || oldUsernamePassword string | oldUsernamePassword := bindings at: assoc key. string := oldDecryptor decrypt: oldUsernamePassword password base: password. bindings at: assoc key put: ( UsernamePassword username: oldUsernamePassword username password: (self encryptPassword: string) )]]! ! !KeyChain methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/9/2012 13:10'! setPassword: aPassword (password isNil or: [ self isUnlocked ]) ifTrue: [ | oldPassword | oldPassword := password. 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: 'BenjaminVanRyseghem 5/9/2012 16:45'! setUserName: user password: pass forGroup: group self isUnlocked ifTrue: [ bindings at: group put: (UsernamePassword username: user password: (self encryptPassword: pass)). ^ true ]. ^ false! ! !KeyChain methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/9/2012 16:45'! setUserName: user password: pass forGroup: group withUnlockPassword: aString (encryptor encrypt: aString) = password ifTrue: [ bindings at: group put: (UsernamePassword username: user password: (self encryptPassword: pass)). ^ true ]. ^ false! ! !KeyChain methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem2 5/11/2012 18:21'! setUserNamePassword: usernamePassword forGroup: group self isUnlocked ifTrue: [ bindings at: group put: usernamePassword. ^ true ]. ^ false! ! !KeyChain methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/11/2012 16:37'! unlock ^ self isUnlocked ! ! !KeyChain methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/9/2012 16:43'! userNamePasswordFor: aGroup ^ self isUnlocked ifTrue: [ | oldUsernamePassword | oldUsernamePassword := bindings at: aGroup ifAbsent: [ ^ nil ]. UsernamePassword username: oldUsernamePassword username password: (self decryptPassword: (oldUsernamePassword password)) ]! ! !KeyChain methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/9/2012 22:08'! askPasswordForKeyChain: attempt | string | password ifNil: [ ^ lastUnlock contents: true ]. string := UITheme current 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 ]. lastUnlock contents: true! ! !KeyChain methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/6/2012 23:35'! defaultTimeBetweenUnlocks " 5 minutes " ^ Duration minutes: 5! ! !KeyChain methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/9/2012 16:20'! isUnlocked ^ self isUnlocked: 0! ! !KeyChain methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/9/2012 16:21'! isUnlocked: attempt ^ lastUnlock contents ifTrue: [ true ] ifFalse: [ attempt = self maxAttemptsNumber ifTrue: [ ^ false ]. self askPasswordForKeyChain: attempt. self isUnlocked: (attempt +1) ]! ! !KeyChain methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/9/2012 16:19'! maxAttemptsNumber ^ 3! ! !KeyChain methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/9/2012 13:25'! passwordFor: aUserName ^ self isUnlocked ifTrue: [ self decryptPassword: (bindings at: aUserName) ]! ! !KeyChain methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/9/2012 12:59'! timeBetweenUnlocks ^ lastUnlock timeToLive! ! !KeyChain methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/9/2012 12:59'! timeBetweenUnlocks: aDuration lastUnlock timeToLive: aDuration! ! !KeyChain methodsFor: 'private-UI' stamp: 'BenjaminVanRyseghem 5/10/2012 13:28'! bindings ^ bindings! ! ComposableModel subclass: #KeyChainViewer instanceVariableNames: 'add edit keychain list remove ok' classVariableNames: '' poolDictionaries: '' category: 'KeyChain-UI'! !KeyChainViewer commentStamp: '' prior: 0! A KeyChainViewer is a GUI to see and edit values of a keychain! !KeyChainViewer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/10/2012 13:26'! add ^ add! ! !KeyChainViewer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/10/2012 13:26'! edit ^ edit! ! !KeyChainViewer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/10/2012 13:26'! keychain ^ keychain! ! !KeyChainViewer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/10/2012 13:26'! list ^ list! ! !KeyChainViewer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/10/2012 13:26'! ok ^ ok! ! !KeyChainViewer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/10/2012 13:26'! remove ^ remove! ! !KeyChainViewer methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 8/2/2012 15:27'! initialize "Initialization code for KeyChainViewer" keychain := nil asValueHolder. super initialize.! ! !KeyChainViewer methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 5/10/2012 13:44'! initializeAdd add label: '+'; enabled: false; state: false; action: [ self addPassword ]! ! !KeyChainViewer methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 5/10/2012 13:44'! initializeEdit edit label: 'edit'; enabled: false; state: false; action: [ self editPassword ]! ! !KeyChainViewer methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 5/10/2012 13:44'! initializeRemove remove label: '-'; enabled: false; state: false; action: [ self removePassword ]! ! !KeyChainViewer methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 8/2/2012 16:27'! initializeWidgets "Initialization code for KeyChainViewer" 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: 'protocol' stamp: 'BenjaminVanRyseghem 5/10/2012 13:19'! keychain: aKeyChain keychain contents: aKeyChain! ! !KeyChainViewer methodsFor: 'private' stamp: 'BenjaminVanRyseghem 8/2/2012 16:47'! addPassword | wrapper editor group user index | keychain contents ifNotNil:[:kc | kc unlock ]. wrapper := KeychainEditingWrapper new keychain: keychain contents; group: ''; usernamePassword: UsernamePassword new. editor := KeychainEditor new keychainEditingWrapper: wrapper; yourself. self window ifNotNil: [: w | w openModal: editor openDialogWithSpec window]. editor cancelled ifTrue: [ ^ self ]. group := wrapper group. user :=wrapper usernamePassword. keychain contents setUserNamePassword: user forGroup: group. keychain contentsChanged. index := list listItems indexOf: (group -> user ). list setSelectedIndex: index! ! !KeyChainViewer methodsFor: 'private' stamp: 'BenjaminVanRyseghem 8/2/2012 16:33'! editPassword list selectedItem ifNil: [ ^ self ] ifNotNil: [:it || wrapper editor | keychain contents ifNotNil:[:kc | kc unlock ]. wrapper := KeychainEditingWrapper new keychain: keychain contents; group: it key; usernamePassword: it value. editor := KeychainEditor new keychainEditingWrapper: wrapper; yourself. self window ifNotNil: [: w | w openModal: editor openDialogWithSpec window ]. editor cancelled ifTrue: [ ^ self ]. it key: wrapper group. it value: wrapper usernamePassword. keychain contentsChanged. list setSelectedItem: it ]! ! !KeyChainViewer methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/10/2012 16:18'! initialExtent ^ (320@240)! ! !KeyChainViewer methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/10/2012 13:56'! removePassword list selectedItem ifNil: [ ^self ] ifNotNil: [:it | keychain contents removeUserNamePasswordFor: it key. keychain contentsChanged ]! ! !KeyChainViewer methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/10/2012 23:46'! title ^ keychain contents ifNil: [ 'Keychain editor' ] ifNotNil: [:kc | kc username ifNil: [ 'Keychain editor' ] ifNotNil: [:usr | 'Editing ', usr ,'''s keychain' ]]! ! !KeyChainViewer methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/10/2012 13:27'! wrapItem: anItem ^ { anItem key. anItem value username }! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! KeyChainViewer class instanceVariableNames: ''! !KeyChainViewer class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/15/2013 13:47'! internSpec ^{#ComposableSpec. #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) }}! ! NotFound subclass: #KeyNotFound instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Collections-Unordered'! !KeyNotFound commentStamp: 'SvenVanCaekenberghe 4/19/2011 19:41' prior: 0! 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: 'accessing' stamp: 'SvenVanCaekenberghe 4/19/2011 19:38'! key: aKey super object: aKey! ! !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 ]! ! UserInputEvent subclass: #KeyboardEvent instanceVariableNames: 'keyValue charCode scanCode' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Events'! !KeyboardEvent methodsFor: '*Keymapping-Core' stamp: 'GuillermoPolito 9/12/2011 17:14'! altKeyPressed ^self commandKeyPressed! ! !KeyboardEvent methodsFor: '*Keymapping-Core' stamp: 'GuillermoPolito 11/2/2011 22:32'! asShortcut ^ KMShortcut fromKeyboardEvent: self! ! !KeyboardEvent methodsFor: '*Keymapping-Core' stamp: 'DeboraFortini 11/1/2011 16:37'! 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 controlKeyPressed and: [ (#(MacOSX Windows) includes: Smalltalk os current platformFamily) and: [ keyValue <= 26 ]]) ifTrue: [ (self keyValue + $a asciiValue - 1) asCharacter ] ifFalse: [ self keyCharacter ]! ! !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: 'comparing' stamp: 'ar 9/13/2000 15:50'! hash ^buttons hash + keyValue hash ! ! !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: 'initialize' stamp: 'michael.rueger 2/24/2009 14:08'! scanCode: anInt scanCode := anInt! ! !KeyboardEvent methodsFor: 'initialize' stamp: 'ar 10/25/2000 22:08'! type: eventType readFrom: aStream type := eventType. timeStamp := Integer readFrom: aStream. aStream skip: 1. buttons := Integer readFrom: aStream. aStream skip: 1. keyValue := Integer readFrom: aStream.! ! !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: '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: '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: 'keyboard' stamp: 'michael.rueger 2/25/2009 22:19'! scanCode ^scanCode! ! !KeyboardEvent methodsFor: 'printing' stamp: 'tk 10/13/2004 15:19'! 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 controlKeyPressed and: [ keyValue <= 26 ]) 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: '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: 'printing' stamp: 'ar 10/25/2000 22:07'! storeOn: aStream aStream nextPutAll: type. aStream space. self timeStamp storeOn: aStream. aStream space. buttons storeOn: aStream. aStream space. keyValue storeOn: aStream. ! ! !KeyboardEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:49'! isKeyDown ^self type == #keyDown! ! !KeyboardEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:49'! isKeyUp ^self type == #keyUp! ! !KeyboardEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:49'! isKeyboard ^true! ! !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: 'testing' stamp: 'SeanDeNigris 1/29/2013 11:22'! isUserInterrupt ^ UserInterruptHandler cmdDotEnabled and: [ self keyCharacter = $. and: [ self commandKeyPressed ] ]. ! ! !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: '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.! ! Object subclass: #KeychainEditingWrapper instanceVariableNames: 'keychain group usernamePassword' classVariableNames: '' poolDictionaries: '' category: 'KeyChain-UI'! !KeychainEditingWrapper commentStamp: '' prior: 0! A KeychainEditingWrapper is a simple wrapper for the KeychainEditor ! !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'! keychain ^ keychain! ! !KeychainEditingWrapper methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/11/2012 17:46'! keychain: anObject keychain := anObject! ! !KeychainEditingWrapper methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/11/2012 17:46'! usernamePassword ^ usernamePassword! ! !KeychainEditingWrapper methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/11/2012 17:46'! usernamePassword: anObject usernamePassword := anObject! ! ComposableModel subclass: #KeychainEditor instanceVariableNames: 'groupLabel groupTextField setPassword usernameLabel usernameTextField password keychainEditingWrapper' classVariableNames: '' poolDictionaries: '' category: 'KeyChain-UI'! !KeychainEditor commentStamp: '' prior: 0! A KeychainEditor is a GUI for editing keychain entrie! !KeychainEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/11/2012 17:21'! groupLabel ^ groupLabel! ! !KeychainEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/11/2012 17:21'! groupTextField ^ groupTextField! ! !KeychainEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/11/2012 18:01'! setNewPassword | it newPassword w | (it := keychainEditingWrapper contents) 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: 'accessing' stamp: 'BenjaminVanRyseghem 5/11/2012 17:21'! setPassword ^ setPassword! ! !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 15:21'! initialize "Initialization code for KeychainEditor" keychainEditingWrapper := nil asValueHolder. super initialize.! ! !KeychainEditor methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 8/2/2012 16:46'! initializeDialogWindow: aWindow aWindow okAction: [ self ok ].! ! !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: '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: 'protocol' stamp: 'BenjaminVanRyseghem 8/2/2012 16:45'! cancelled ^ self window ifNil: [ false ] ifNotNil: [:w | w cancelled ]! ! !KeychainEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/11/2012 17:49'! keychainEditingWrapper ^ keychainEditingWrapper! ! !KeychainEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/11/2012 17:49'! keychainEditingWrapper: anAssociation keychainEditingWrapper contents: anAssociation! ! !KeychainEditor methodsFor: 'private' stamp: 'BenjaminVanRyseghem 8/2/2012 16:41'! initialExtent ^ 330@150! ! !KeychainEditor methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/11/2012 18:15'! ok | it | (it := keychainEditingWrapper contents) ifNil: [ ^ self ]. it group: groupTextField getText asSymbol. it usernamePassword username: usernameTextField getText. it usernamePassword password: password.! ! !KeychainEditor methodsFor: 'private' stamp: 'BenjaminVanRyseghem 8/2/2012 16:50'! title ^ keychainEditingWrapper contents ifNil: [ 'Group editor' ] ifNotNil: [:it | it group ifEmpty: [ 'Group editor' ] ifNotEmpty: [:name | 'Editing ', name asString printString, ' group' ]]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! KeychainEditor class instanceVariableNames: ''! !KeychainEditor class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/15/2013 13:44'! internSpec ^{#ComposableSpec . #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) }}! ! Dictionary subclass: #KeyedTree instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !KeyedTree commentStamp: '' prior: 0! 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: '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: '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 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 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: '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: 'accessing' stamp: 'gvc 12/15/2005 13:54'! subtrees "Answer the subtrees of the receiver." ^(self select: [:v | v isKindOf: KeyedTree]) values! ! !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: '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: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: '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: '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: '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: '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]! ! !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 ! ! TestCase subclass: #KeyedTreeTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Polymorph-Widgets'! !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: '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: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'! 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 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].! ! !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'! 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 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 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}].! ! AbstractKeymappingTest subclass: #KeymapBuilderTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Keymapping-Tests'! !KeymapBuilderTest methodsFor: 'as yet unclassified' stamp: 'DeboraFortini 12/13/2011 17:36'! testAddKeymapCreatesCategory self assert: KMRepository default categories isEmpty. KMRepository default initializeKeymap: #test executingOn: $r ctrl, $r asShortcut, $r asShortcut 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: 'DeboraFortini 12/13/2011 17:38'! testAddKeymapCreatesShortcut KMRepository default initializeKeymap: #test executingOn: $r ctrl, $r asShortcut, $r asShortcut doing: [ :receiver | "nothing" ] inCategory: #Testing platform: #all. self assert: (KMRepository default categoryForName: #Testing ) allEntries size = 1.! ! !KeymapBuilderTest methodsFor: 'as yet unclassified' stamp: 'ThierryGoubier 9/19/2012 16:29'! testAttachKeymapAndExecuteExecutes | executed morphToTest | executed := false. KMFactory keymapContainer initializeKeymap: #test executingOn: $a asShortcut, $a asShortcut, $a asShortcut 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 methodsFor: 'as yet unclassified' stamp: 'DeboraFortini 12/13/2011 17:37'! testAttachKeymapAttaches KMFactory keymapContainer initializeKeymap: #test executingOn: $r ctrl, $r asShortcut, $r asShortcut doing: [ :receiver | "nothing" ] inCategory: #Testing platform: #all.. KMFactory keymapContainer attachCategoryName: #Testing to: KMMockMorph. self assert: ((KMFactory keymapContainer categoriesForClass: KMMockMorph ) anySatisfy: [ :c | c name = #Testing ]).! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! KeymapBuilderTest class instanceVariableNames: ''! !KeymapBuilderTest class methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 3/18/2011 23:11'! keymapEventBuilderClass ^ KMFactory keymapEventBuilder! ! AbstractKeyPressedPlugin subclass: #KonamiCodePlugin instanceVariableNames: 'lastKeystrokeTime lastKeystrokes code' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Plugin'! !KonamiCodePlugin commentStamp: '' prior: 0! A KonamiCodePlugin is a plugin which run an action when the Konami code is entered! !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/12/2011 17:22'! initialize super initialize. lastKeystrokeTime := 0. ! ! !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: 'BenjaminVanRyseghem 5/4/2011 15:55'! openKonamiCode [ 15 timesRepeat: [ Beeper primitiveBeep. (Delay forMilliseconds: 50) wait. ]] fork. ! ! LanguageEnvironment subclass: #KoreanEnvironment instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Multilingual-Languages'! !KoreanEnvironment commentStamp: '' prior: 0! 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 instanceVariableNames: ''! !KoreanEnvironment class methodsFor: 'as yet unclassified' stamp: 'janggoon 11/4/2008 22:11'! leadingChar ^ 7! ! !KoreanEnvironment class methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 7/12/2012 20:44'! systemConverterClass | encoding | OSPlatform isWin32 ifTrue: [^EUCKRTextConverter]. OSPlatform isMacOS ifTrue: [^UTF8TextConverter]. OSPlatform isUnix ifTrue: [encoding := X11Encoding encoding. encoding ifNil: [^EUCKRTextConverter]. (encoding = 'utf-8') ifTrue: [^UTF8TextConverter]. ^EUCKRTextConverter]. ^UTF8TextConverter! ! !KoreanEnvironment class methodsFor: 'as yet unclassified' stamp: 'yo 3/16/2004 14:50'! traditionalCharsetClass ^ KSX1001. ! ! !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' )! ! AtomicCollection subclass: #LIFOQueue instanceVariableNames: 'head' classVariableNames: '' poolDictionaries: '' category: 'Collections-Atomic'! !LIFOQueue commentStamp: 'Igor.Stasenko 10/16/2010 03:58' prior: 0! This is a thread-safe LIFO (last-in-first-out) queue (also known as stack) implementation, based on atomic operations. ! !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: '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: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: 'accessing' stamp: 'Igor.Stasenko 10/16/2010 03:51'! nextOrNil ^ self nextIfNone: [ nil ]! ! !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: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! ! !LIFOQueue methodsFor: 'initialize-release' stamp: 'Igor.Stasenko 10/16/2010 03:37'! initialize | dummy | dummy := self newItem. dummy next: nil; object: dummy. head := dummy.! ! !LIFOQueue methodsFor: 'stack-compliant protocol' stamp: 'Igor.Stasenko 10/16/2010 04:03'! errorEmptyStack self error: 'this stack is empty'! ! !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:01'! push: anObject ^ self nextPut: anObject! ! TestCase subclass: #LIFOQueueTests instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Atomic'! !LIFOQueueTests methodsFor: 'instance creation' stamp: 'Igor.Stasenko 10/16/2010 04:41'! newQueue ^ LIFOQueue new! ! !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: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: '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! ! Object subclass: #LRUCache instanceVariableNames: 'size factory calls hits values' classVariableNames: '' poolDictionaries: '' category: 'System-Support'! !LRUCache commentStamp: '' prior: 0! I'm a cache of values, given a key I return a Value from the cache or from the factory! !LRUCache methodsFor: 'accessing'! at: aKey "answer the object for aKey, if not present in the cache creates it. Clone the factory block before calling in case of multiple processes!!" | element keyHash | calls := calls + 1. keyHash := aKey hash. 1 to: size do: [:index | element := values at: index. (keyHash = (element at: 2) and: [aKey = (element at: 1)]) ifTrue: ["Found!!" hits := hits + 1. values replaceFrom: 2 to: index with: (values first: index - 1). values at: 1 put: element. ^ element at: 3]]. "Not found!!" element := {aKey. keyHash. factory shallowCopy value: aKey}. values replaceFrom: 2 to: size with: values allButLast. values at: 1 put: element. ^ element at: 3! ! !LRUCache methodsFor: 'initialization'! initializeSize: aNumber factory: aBlock "initialize the receiver's size and factory" size := aNumber. values := Array new: aNumber withAll: {nil. nil. nil}. factory := aBlock. calls := 0. hits := 0! ! !LRUCache methodsFor: 'printing'! printOn: aStream "Append to the argument, aStream, a sequence of characters that identifies the receiver." aStream nextPutAll: self class name; nextPutAll: ' size:'; nextPutAll: size asString; nextPutAll: ', calls:'; nextPutAll: calls asString; nextPutAll: ', hits:'; nextPutAll: hits asString; nextPutAll: ', ratio:'. calls = 0 ifTrue: [aStream nextPutAll: 0 asFloat asString] ifFalse: [aStream nextPutAll: (hits / calls) asFloat asString]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! LRUCache class instanceVariableNames: ''! !LRUCache class methodsFor: 'instance creation'! size: aNumber factory: aBlock "answer an instance of the receiver" ^ self new initializeSize: aNumber factory: aBlock! ! !LRUCache class methodsFor: 'testing'! test " LRUCache test " | c | c := LRUCache size: 5 factory: [:key | key * 2]. c at: 1. c at: 2. c at: 3. c at: 4. c at: 1. c at: 5. c at: 6. c at: 7. c at: 8. c at: 1. ^ c! ! !LRUCache class methodsFor: 'testing'! test2 " LRUCache test2. Time millisecondsToRun:[LRUCache test2]. MessageTally spyOn:[LRUCache test2]. " | c | c := LRUCache size: 600 factory: [:key | key * 2]. 1 to: 6000 do: [:each | c at: each]. ^ c! ! Announcement subclass: #LabelClicked instanceVariableNames: 'source stateChanged' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !LabelClicked commentStamp: '' prior: 0! I am an announcement raised when someone click on the label of a CheckboxMorph! !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 ^ stateChanged! ! !LabelClicked methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/21/2013 23:32'! stateChanged: anObject stateChanged := anObject! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! LabelClicked class instanceVariableNames: ''! !LabelClicked class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 2/21/2013 23:32'! source: source stateChanged: stateChanged ^ self new source: source; stateChanged: stateChanged; yourself! ! AbstractBasicWidget subclass: #LabelModel instanceVariableNames: 'textHolder' classVariableNames: '' poolDictionaries: '' category: 'Spec-Widgets'! !LabelModel commentStamp: '' prior: 0! A LabelModel is a spec model for Labels! !LabelModel methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 7/16/2012 18:07'! initialize "Initialization code for LabelModel" super initialize. textHolder := '' asValueHolder. enabledHolder := true asValueHolder. textHolder whenChangedDo: [ self changed: #getText ].! ! !LabelModel methodsFor: 'morphic' stamp: 'BenjaminVanRyseghem 7/13/2012 02:17'! getText ^ textHolder contents! ! !LabelModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 02:15'! text: aText "Set the text of the label" textHolder contents: aText! ! !LabelModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/13/2012 02:16'! whenTextChanged: aBlock "Set a block to performed when the text is changed" textHolder whenChangedDo: aBlock! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! LabelModel class instanceVariableNames: ''! !LabelModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 2/8/2013 14:24'! defaultSpec ^ {#LabelSpec. #model:. #model. #getEnabledSelector:. #enabled. #getTextSelector:. #getText. #vResizing:. #shrinkWrap. #hResizing:. #spaceFill. #borderWidth:. #(model borderWidth). #borderColor:. #(model borderColor). #setBalloonText:. { #model . #help}}! ! !LabelModel class methodsFor: 'specs'! title ^ 'Label Morph'! ! StringMorph subclass: #LabelMorph instanceVariableNames: 'getEnabledSelector getTextSelector enabled model disabledStyle' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !LabelMorph commentStamp: 'gvc 5/18/2007 12:48' prior: 0! String morph with enablement support. When disabled the text will appear inset.! !LabelMorph methodsFor: 'accessing' stamp: 'gvc 8/2/2007 16:43'! disabledStyle "Answer the value of disabledStyle" ^ disabledStyle! ! !LabelMorph methodsFor: 'accessing' stamp: 'gvc 8/2/2007 16:53'! disabledStyle: anObject "Set the value of disabledStyle" disabledStyle := anObject. self changed: #disabledStyle; changed! ! !LabelMorph methodsFor: 'accessing' stamp: 'gvc 1/16/2007 15:28'! enabled "Answer the value of enabled" ^enabled! ! !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: 'accessing' stamp: 'gvc 7/30/2010 13:37'! getTextSelector: aSymbol getTextSelector := aSymbol. self updateText! ! !LabelMorph methodsFor: 'accessing' stamp: 'gvc 1/16/2007 15:52'! model "Answer the value of model" ^model! ! !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: 'as yet unclassified' stamp: 'gvc 8/2/2007 16:35'! disable "Disable the receiver." self enabled: false! ! !LabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 8/2/2007 16:35'! enable "Enable the receiver." self enabled: true! ! !LabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/16/2007 15:28'! getEnabledSelector "Answer the value of getEnabledSelector" ^ getEnabledSelector! ! !LabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/16/2007 15:27'! getEnabledSelector: anObject "Set the value of getEnabledSelector" getEnabledSelector := anObject. self updateEnabled! ! !LabelMorph methodsFor: 'as yet unclassified' stamp: 'gvc 3/4/2010 15:16'! interactionState: aSymbol "Backstop here to prevent 'legacy' color handling being applied from pluggable buttons."! ! !LabelMorph 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)]]! ! !LabelMorph methodsFor: 'as yet unclassified' 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: '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: '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: 'initialization' stamp: 'gvc 8/2/2007 16:44'! initialize "Initialize the receiver." super initialize. self disabledStyle: #plain; enabled: 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: '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: '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]! ! AbstractSpec subclass: #LabelSpec instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Spec-Core-Specs'! !LabelSpec commentStamp: '' prior: 0! A LabelSpec is a spec used to describe a label! !LabelSpec methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/24/2012 03:14'! classSymbol ^ #Label! ! Object subclass: #LanguageEnvironment instanceVariableNames: 'id' classVariableNames: 'ClipboardInterpreterClass Current FileNameConverter InputInterpreterClass KnownEnvironments SystemConverter' poolDictionaries: '' category: 'Multilingual-Languages'! !LanguageEnvironment commentStamp: '' prior: 0! The name multilingualized Squeak 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: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: 'accessing' stamp: 'mir 7/15/2004 15:31'! localeID ^id! ! !LanguageEnvironment methodsFor: 'initialization' stamp: 'mir 7/15/2004 15:31'! localeID: anID id := anID! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! LanguageEnvironment class instanceVariableNames: ''! !LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 3/17/2004 15:24'! canBeGlobalVarInitial: char ^ Unicode canBeGlobalVarInitial: char. ! ! !LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 3/17/2004 15:24'! canBeNonGlobalVarInitial: char ^ Unicode canBeNonGlobalVarInitial: char. ! ! !LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 7/28/2004 21:34'! currentPlatform ^ Locale currentPlatform languageEnvironment. ! ! !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: 'accessing' stamp: 'yo 12/2/2004 16:13'! isCharset ^ false. ! ! !LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 3/17/2004 15:24'! isDigit: char ^ Unicode isDigit: char. ! ! !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:25'! isLowercase: char ^ Unicode isLowercase: char. ! ! !LanguageEnvironment class methodsFor: 'accessing' stamp: 'yo 3/17/2004 15:25'! isUppercase: char ^ Unicode isUppercase: char. ! ! !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: 'class initialization' stamp: 'mir 7/15/2004 16:13'! localeChanged self startUp! ! !LanguageEnvironment class methodsFor: 'class initialization' stamp: 'GuillermoPolito 6/27/2012 12:41'! startUp self clearDefault.! ! !LanguageEnvironment class methodsFor: 'initialization' stamp: 'CamilloBruni 8/24/2012 18:05'! clearDefault SystemConverter := nil. FileNameConverter := nil. ! ! !LanguageEnvironment class methodsFor: 'initialization' stamp: 'GuillermoPolito 6/27/2012 12:41'! initialize "LanguageEnvironment initialize" Smalltalk addToStartUpList: LanguageEnvironment ! ! !LanguageEnvironment class methodsFor: 'initialization' stamp: 'mir 7/21/2004 19:10'! resetKnownEnvironments "LanguageEnvironment resetKnownEnvironments" KnownEnvironments := nil! ! !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: 'CamilloBruni 8/24/2012 18:05'! defaultFileNameConverter FileNameConverter ifNil: [FileNameConverter := self currentPlatform class fileNameConverterClass new]. ^ FileNameConverter! ! !LanguageEnvironment class methodsFor: 'public query' stamp: 'CamilloBruni 8/24/2012 18:06'! defaultSystemConverter SystemConverter ifNil: [SystemConverter := self currentPlatform class systemConverterClass new]. ^ SystemConverter! ! !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: 'subclass responsibilities' stamp: 'michael.rueger 2/5/2009 17:23'! fileNameConverterClass ^UTF8TextConverter! ! !LanguageEnvironment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/17/2004 15:11'! leadingChar self subclassResponsibility. ^ 0. ! ! !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: 'subclass responsibilities' stamp: 'yo 3/17/2004 15:10'! systemConverterClass self subclassResponsibility. ^ Latin1TextConverter. ! ! !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: 'private' stamp: 'mir 7/15/2004 15:45'! knownEnvironments "LanguageEnvironment knownEnvironments" "KnownEnvironments := nil" ^KnownEnvironments ifNil: [KnownEnvironments := self initKnownEnvironments]! ! LargePositiveInteger variableByteSubclass: #LargeNegativeInteger instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Numbers'! !LargeNegativeInteger commentStamp: '' prior: 0! Just like LargePositiveInteger, but represents a negative number.! !LargeNegativeInteger methodsFor: '*Fuel' stamp: 'MarianoMartinezPeck 6/11/2012 22:46'! fuelAccept: aGeneralMapper ^ self >= -2147483648 ifTrue: [ aGeneralMapper mapAndTraceByClusterName: self to: FLNegative32SmallIntegerCluster ] ifFalse: [ aGeneralMapper visitBytesObject: self]! ! !LargeNegativeInteger methodsFor: 'arithmetic'! abs ^ self negated! ! !LargeNegativeInteger methodsFor: 'arithmetic'! negated ^ self copyto: (LargePositiveInteger new: self digitLength)! ! !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: '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: 'converting' stamp: 'nice 9/22/2011 01:36'! asFloat ^self negated 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: '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: 'nice 7/15/2011 14:06'! log ^DomainError signal: 'log 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: '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! ! !LargeNegativeInteger methodsFor: 'testing' stamp: 'di 4/23/1998 11:18'! negative "Answer whether the receiver is mathematically negative." ^ true! ! !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: '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:03'! strictlyPositive "Answer whether the receiver is mathematically positive." ^ false! ! ClassTestCase subclass: #LargeNegativeIntegerTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Numbers'! !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! ! Integer variableByteSubclass: #LargePositiveInteger instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Numbers'! !LargePositiveInteger commentStamp: '' prior: 0! 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: '*Fuel' stamp: 'MarianoMartinezPeck 6/11/2012 22:47'! fuelAccept: aGeneralMapper ^ self <= 4294967295 ifTrue: [ aGeneralMapper mapAndTraceByClusterName: self to: FLPositive32SmallIntegerCluster ] ifFalse: [ aGeneralMapper visitBytesObject: self]! ! !LargePositiveInteger methodsFor: 'arithmetic'! * 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! ! !LargePositiveInteger methodsFor: 'arithmetic'! + 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! ! !LargePositiveInteger methodsFor: 'arithmetic'! - 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! ! !LargePositiveInteger methodsFor: 'arithmetic'! / 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! ! !LargePositiveInteger methodsFor: 'arithmetic'! // 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! ! !LargePositiveInteger methodsFor: 'arithmetic'! \\ anInteger "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." ^super \\ anInteger! ! !LargePositiveInteger methodsFor: 'arithmetic' stamp: 'RAA 5/31/2000 13:21'! \\\ anInteger "a faster modulo method for use in DSA. Be careful if you try to use this elsewhere" ^(self digitDiv: anInteger neg: false) second! ! !LargePositiveInteger methodsFor: 'arithmetic'! abs! ! !LargePositiveInteger methodsFor: 'arithmetic'! negated ^ (self copyto: (LargeNegativeInteger new: self digitLength)) normalize "Need to normalize to catch SmallInteger minVal"! ! !LargePositiveInteger methodsFor: 'arithmetic'! 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! ! !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: 'bit manipulation' stamp: 'SqR 9/18/2000 15:17'! hashMultiply "Truncate to 28 bits and try again" ^(self bitAnd: 16rFFFFFFF) hashMultiply! ! !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: 'bit manipulation' stamp: 'VeronicaUquillas 6/11/2010 14:14'! 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))! ! !LargePositiveInteger methodsFor: 'comparing'! < 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! ! !LargePositiveInteger methodsFor: 'comparing'! <= 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! ! !LargePositiveInteger methodsFor: 'comparing'! > 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! ! !LargePositiveInteger methodsFor: 'comparing'! >= 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! ! !LargePositiveInteger methodsFor: 'comparing' stamp: 'SqR 8/13/2002 10:52'! hash ^ByteArray hashBytes: self startingWith: self species hash! ! !LargePositiveInteger methodsFor: 'converting' stamp: 'ajh 7/25/2001 22:28'! 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! ! !LargePositiveInteger methodsFor: 'converting' stamp: 'nice 9/22/2011 01:53'! 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: Floating point hardware will correctly handle the rounding by itself with a single inexact operation if mantissa has one excess bit of precision. Except in the last case when extra bits are present after an even mantissa, we must round upper by ourselves. Note 1: the inexact flag in floating point hardware must not be trusted because it won't take into account the bits we truncated by ourselves. Note 2: the floating point hardware is presumed configured in default rounding mode." | mantissa shift sum excess | "Check how many bits excess the maximum precision of a Float mantissa." excess := self highBitOfMagnitude - Float precision. excess > 1 ifTrue: ["Remove the excess bits but one." mantissa := self bitShift: 1 - excess. shift := excess - 1. "Handle the case of extra bits truncated after an even mantissa." ((mantissa bitAnd: 2r11) = 2r01 and: [self anyBitOfMagnitudeFrom: 1 to: shift]) ifTrue: [mantissa := mantissa + 1]] ifFalse: [mantissa := self. shift := 0]. "Now that mantissa has at most 1 excess bit of precision, let floating point operations perform the final rounding." sum := 0.0. 1 to: mantissa digitLength do: [:byteIndex | sum := sum + ((mantissa digitAt: byteIndex) asFloat timesTwoPower: shift). shift := shift + 8]. ^sum! ! !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: 'converting' stamp: 'RAA 3/2/2002 14:32'! withAtLeastNDigits: desiredLength | new | self size >= desiredLength ifTrue: [^self]. new := self class new: desiredLength. new replaceFrom: 1 to: self size with: self startingAt: 1. ^new! ! !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 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: 'mathematical functions' stamp: 'nice 10/14/2011 23:38'! 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"! ! !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 10/14/2011 23:50'! sqrtFloor "Return the integer part of the square root of self" | powerOfTwo | (powerOfTwo := self lowBit - 1 // 2) > 1 ifFalse: [^super sqrtFloor]. ^(self bitShift: -2 * powerOfTwo) sqrtFloor bitShift: powerOfTwo! ! !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! ! !LargePositiveInteger methodsFor: 'printing' stamp: 'StephaneDucasse 9/1/2010 08:49'! 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! ! !LargePositiveInteger methodsFor: 'system primitives' stamp: 'tk 3/24/1999 20:28'! 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]! ! !LargePositiveInteger methodsFor: 'system primitives'! 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! ! !LargePositiveInteger methodsFor: 'system primitives'! 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! ! !LargePositiveInteger methodsFor: 'system primitives'! 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! ! !LargePositiveInteger methodsFor: 'testing' stamp: 'nice 8/31/2008 00:07'! isLarge ^true! ! !LargePositiveInteger methodsFor: 'testing' stamp: 'StephaneDucasse 2/4/2012 16:59'! 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! ! !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: 'testing' stamp: 'jm 3/27/98 06:19'! sign "Optimization. Answer 1 since receiver is greater than 0." ^ 1 ! ! !LargePositiveInteger methodsFor: 'testing' stamp: 'di 4/23/1998 11:02'! strictlyPositive "Answer whether the receiver is mathematically positive." ^ true! ! ClassTestCase subclass: #LargePositiveIntegerTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Numbers'! !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: '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).! ! EncodedCharSet subclass: #Latin1 instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Multilingual-Encodings'! !Latin1 commentStamp: 'yo 10/19/2004 19:53' prior: 0! 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 instanceVariableNames: 'rightHalfSequence'! !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: 'accessing - displaying' stamp: 'yo 8/18/2003 17:32'! printingDirection ^ #right. ! ! !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: '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: '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: 'yo 8/18/2003 17:32'! leadingChar ^ 0. ! ! !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: '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)! ! LanguageEnvironment subclass: #Latin1Environment instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Multilingual-Languages'! !Latin1Environment commentStamp: '' prior: 0! 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 instanceVariableNames: ''! !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: '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: 'language methods' stamp: 'yo 1/24/2005 09:59'! traditionalCharsetClass ^ Latin1. ! ! !Latin1Environment class methodsFor: 'subclass responsibilities' stamp: 'yo 3/17/2004 15:07'! leadingChar ^ 0. ! ! !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: 'subclass responsibilities' stamp: 'ClementBera 11/2/2012 11:36'! systemConverterClass OSPlatform isWin32 ifTrue: [^ UTF8TextConverter]. OSPlatform isMacOSX ifTrue: [ ^ UTF8TextConverter ]. OSPlatform isMacOS ifTrue: [^MacRomanTextConverter]. OSPlatform isUnix ifTrue: [^ UTF8TextConverter]. ^ Latin1TextConverter ! ! ByteTextConverter subclass: #Latin1TextConverter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Multilingual-TextConversion'! !Latin1TextConverter commentStamp: '' prior: 0! Text converter for ISO 8859-1. An international encoding used in Western Europe.! !Latin1TextConverter methodsFor: 'conversion' stamp: 'michael.rueger 2/5/2009 14:20'! byteToUnicode: char ^char! ! !Latin1TextConverter methodsFor: 'conversion' stamp: 'michael.rueger 2/5/2009 14:20'! unicodeToByte: unicodeChar ^unicodeChar charCode < 256 ifTrue: [unicodeChar] ifFalse: [0 asCharacter]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Latin1TextConverter class instanceVariableNames: ''! !Latin1TextConverter class methodsFor: 'accessing'! 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 )! ! !Latin1TextConverter class methodsFor: 'accessing' stamp: 'tbn 1/17/2011 13:04'! encodingNames ^ #('latin-1' 'latin1' 'iso-8859-1') copy. ! ! !Latin1TextConverter class methodsFor: 'accessing' stamp: 'michael.rueger 2/2/2009 19:31'! languageEnvironment ^Latin1Environment! ! !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"! ! LanguageEnvironment subclass: #Latin2Environment instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Multilingual-Languages'! !Latin2Environment commentStamp: '' prior: 0! 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 instanceVariableNames: ''! !Latin2Environment class methodsFor: 'subclass responsibilities' stamp: 'nice 5/1/2011 19:22'! leadingChar ^0! ! !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: 'subclass responsibilities' stamp: 'MarcusDenker 7/12/2012 20:45'! systemConverterClass OSPlatform isWin32 ifTrue: [^CP1250TextConverter ]. ^ ISO88592TextConverter. ! ! LanguageEnvironment subclass: #Latin9Environment instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Multilingual-Languages'! !Latin9Environment commentStamp: '' prior: 0! This class provides the support for the languages in 'Latin-9' category.! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Latin9Environment class instanceVariableNames: ''! !Latin9Environment class methodsFor: 'subclass responsibilities' stamp: 'nice 5/1/2011 19:22'! leadingChar ^0! ! !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: 'subclass responsibilities' stamp: 'MarcusDenker 7/12/2012 20:45'! systemConverterClass OSPlatform isWin32 ifTrue: [^CP1252TextConverter ]. ^ ISO885915TextConverter. ! ! Object subclass: #LayoutCell instanceVariableNames: 'target cellSize extraSpace flags nextCell' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Layouts'! !LayoutCell commentStamp: '' prior: 0! 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: '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:12'! cellSize ^cellSize! ! !LayoutCell methodsFor: 'accessing' stamp: 'ar 10/28/2000 18:12'! cellSize: aPoint cellSize := aPoint! ! !LayoutCell methodsFor: 'accessing' stamp: 'ar 11/10/2000 17:09'! extraSpace ^extraSpace ifNil:[0@0]! ! !LayoutCell methodsFor: 'accessing' stamp: 'ar 10/28/2000 21:30'! extraSpace: aPoint extraSpace := aPoint! ! !LayoutCell methodsFor: 'accessing' stamp: 'ls 8/5/2004 16:47'! flags ^flags ifNil: [ 0 ]! ! !LayoutCell methodsFor: 'accessing' stamp: 'ls 8/5/2004 16:48'! hSpaceFill ^self flags anyMask: 1! ! !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: 'ar 10/28/2000 18:12'! nextCell: aCell nextCell := aCell! ! !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:11'! target ^target! ! !LayoutCell methodsFor: 'accessing' stamp: 'ar 10/28/2000 18:12'! target: newTarget target := newTarget! ! !LayoutCell methodsFor: 'accessing' stamp: 'ls 8/5/2004 16:47'! vSpaceFill ^self flags anyMask: 2! ! !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: '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! ! Object subclass: #LayoutFrame instanceVariableNames: 'leftFraction leftOffset topFraction topOffset rightFraction rightOffset bottomFraction bottomOffset' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Layouts'! !LayoutFrame commentStamp: '' prior: 0! 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: '*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: '*Spec-Core' stamp: 'BenjaminVanRyseghem 1/15/2013 11:32'! generateSpec ^ self asArray generateSpec! ! !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'! bottomFraction ^bottomFraction! ! !LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'! bottomFraction: aNumber bottomFraction := aNumber! ! !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'! bottomOffset ^bottomOffset! ! !LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'! bottomOffset: anInteger bottomOffset := anInteger! ! !LayoutFrame methodsFor: 'accessing' stamp: 'IgorStasenko 12/18/2012 16:50'! bottomRightOffset: aPoint bottomOffset := aPoint y. rightOffset := aPoint x.! ! !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'! 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: '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'! leftFraction ^leftFraction! ! !LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'! leftFraction: aNumber leftFraction := aNumber! ! !LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'! leftFraction: aNumber offset: anInteger leftFraction := aNumber. leftOffset := anInteger! ! !LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:35'! leftOffset ^leftOffset! ! !LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'! leftOffset: anInteger leftOffset := anInteger! ! !LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'! rightFraction ^rightFraction! ! !LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'! rightFraction: aNumber rightFraction := aNumber! ! !LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'! rightFraction: aNumber offset: anInteger rightFraction := aNumber. rightOffset := anInteger! ! !LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'! rightOffset ^rightOffset! ! !LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'! rightOffset: anInteger rightOffset := anInteger! ! !LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'! topFraction ^topFraction! ! !LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:36'! topFraction: aNumber topFraction := aNumber! ! !LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:37'! topFraction: aNumber offset: anInteger topFraction := aNumber. topOffset := anInteger! ! !LayoutFrame methodsFor: 'accessing' stamp: 'IgorStasenko 12/18/2012 16:50'! topLeftOffset: aPoint topOffset := aPoint y. leftOffset := aPoint x.! ! !LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:37'! topOffset ^topOffset! ! !LayoutFrame methodsFor: 'accessing' stamp: 'ar 10/23/2000 19:37'! topOffset: anInteger topOffset := anInteger! ! !LayoutFrame methodsFor: 'converting' stamp: 'StephaneDucasse 12/24/2012 17:03'! asArray ^ { leftFraction . topFraction . rightFraction . bottomFraction . leftOffset . topOffset . rightOffset . bottomOffset } ! ! !LayoutFrame methodsFor: 'converting' stamp: 'StephaneDucasse 12/21/2012 13:52'! asLayoutFrame ^self! ! !LayoutFrame methodsFor: 'initialize-release' 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: '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: 'objects from disk' stamp: 'StephaneDucasse 12/24/2012 16:52'! negateBottomRightOffsets bottomOffset := bottomOffset negated. rightOffset := rightOffset negated. ! ! !LayoutFrame methodsFor: 'printing' stamp: 'StephaneDucasse 12/24/2012 18:26'! isSelfEvaluating ^ false! ! !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: 'testing' stamp: 'StephaneDucasse 12/27/2012 18:30'! hasNoOffsets ^ leftOffset = 0 and: [rightOffset = 0 and: [ topOffset = 0 and: [ bottomOffset = 0 ]]]. ! ! !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 class instanceVariableNames: ''! !LayoutFrame class methodsFor: 'accessing' stamp: 'JW 2/1/2001 12:48'! classVersion ^1 "changed treatment of bottomOffset and rightOffset" ! ! !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 ! ! !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! ! TestCase subclass: #LayoutFrameTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Layouts'! !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 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 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! ! !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.! ! Object subclass: #LayoutPolicy instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Layouts'! !LayoutPolicy commentStamp: '' prior: 0! A LayoutPolicy defines how submorphs of some morph should be arranged. Subclasses of the receiver define concrete layout policies.! !LayoutPolicy methodsFor: 'layout' stamp: 'ar 1/27/2001 14:39'! flushLayoutCache "Flush any cached information associated with the receiver"! ! !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" ! ! !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: 'testing' stamp: 'ar 10/29/2000 01:28'! isProportionalLayout ^false! ! !LayoutPolicy methodsFor: 'testing' stamp: 'ar 10/29/2000 01:28'! isTableLayout ^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"! ! Object subclass: #LayoutProperties instanceVariableNames: 'hResizing vResizing disableLayout' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Layouts'! !LayoutProperties commentStamp: '' prior: 0! This class provides a compact bit encoding for the most commonly used layout properties.! !LayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:51'! disableTableLayout ^disableLayout! ! !LayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:51'! disableTableLayout: aBool disableLayout := aBool! ! !LayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:51'! hResizing ^hResizing! ! !LayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:51'! hResizing: aSymbol hResizing := aSymbol! ! !LayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:51'! vResizing ^vResizing! ! !LayoutProperties methodsFor: 'accessing' stamp: 'ar 11/14/2000 17:52'! vResizing: aSymbol vResizing := aSymbol! ! !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: 'initialize' stamp: 'alain.plantec 5/28/2009 10:00'! initialize super initialize. hResizing := vResizing := #rigid. disableLayout := false.! ! !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: 'table defaults' stamp: 'ar 11/13/2000 19:53'! cellInset "Default" ^0! ! !LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/14/2000 17:50'! cellPositioning ^#center! ! !LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 19:55'! cellSpacing "Default" ^#none! ! !LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/14/2000 16:38'! layoutInset ^0! ! !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'! listDirection "Default" ^#topToBottom! ! !LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 19:59'! listSpacing "Default" ^#none! ! !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'! minCellSize ^0! ! !LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 20:00'! reverseTableCells ^false! ! !LayoutProperties methodsFor: 'table defaults' stamp: 'ar 11/13/2000 20:01'! rubberBandCells ^false! ! !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: 'testing' stamp: 'ar 11/13/2000 18:34'! includesTableProperties ^false! ! ClassListExample subclass: #LazyClassListExample instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-MorphTreeWidget-Examples'! !LazyClassListExample commentStamp: 'AlainPlantec 1/17/2010 08:28' prior: 0! LazyClassListExample new openOn: Object ! !LazyClassListExample methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 1/15/2010 13:59'! treeMorphClass ^ LazyMorphTreeMorph ! ! Morph subclass: #LazyListMorph instanceVariableNames: 'listItems font selectedRow selectedRows listSource maxWidth' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Widgets'! !LazyListMorph commentStamp: 'efc 8/6/2005 11:34' prior: 0! 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: '*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: '*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: '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: '*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: '*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: '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: '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: '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: '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. ! ! !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: '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:39'! drawBackgroundForSearchedRow: row on: aCanvas self drawBackgroundForRow: row on: aCanvas color: listSource secondarySelectionColor! ! !LazyListMorph methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 9/1/2011 10:40'! drawBackgroundForSelectedRow: row on: aCanvas self drawBackgroundForRow: row on: aCanvas color: listSource selectionColorToUse! ! !LazyListMorph methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 9/16/2011 17:05'! drawOn: aCanvas listItems size = 0 ifTrue: [^ 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: 'AlainPlantec 2/11/2011 13:13'! drawSelectionOn: aCanvas "Draw the selection background." | frame | selectedRow ifNil: [ ^self ]. selectedRow = 0 ifTrue: [ ^self ]. self drawBackgroundForSelectedRow: selectedRow on: aCanvas ! ! !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: 'drawing' stamp: 'ls 7/5/2000 18:37'! font "return the font used for drawing. The response is never nil" ^font! ! !LazyListMorph methodsFor: 'drawing' stamp: 'ls 7/5/2000 18:04'! font: newFont font := (newFont ifNil: [ TextStyle default defaultFont ]). self adjustHeight. self changed.! ! !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: '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: '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: '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: '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 access' stamp: 'ls 5/15/2001 22:11'! getListSize "return the number of items in the list" listSource ifNil: [ ^0 ]. ^listSource getListSize! ! !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: '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: '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: 'ls 7/7/2000 10:38'! selectedRow "return the currently selected row, or nil if none is selected" ^selectedRow! ! !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: '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: 'BenjaminVanRyseghem 2/21/2013 23:15'! display: item atRow: row on: aCanvas "Display the given item at the given row on the given canvas." | itemColor backgroundColor drawBounds frame attrs useDefaultFont | 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: '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: '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: '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: '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: '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 subclass: #LazyMorphListMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !LazyMorphListMorph commentStamp: 'gvc 5/18/2007 12:47' prior: 0! Support for morph lists in PluggableMorphListMorph.! !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: '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 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: '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: '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: '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 ! ! !LazyMorphListMorph methodsFor: 'as yet unclassified' 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 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: '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 12:24'! selectRow: index "select the index-th row" selectedRows add: index. self invalidRect: (self drawBoundsForRow: index)! ! !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: 'nice 1/5/2010 15:59'! userString "Do I have a text string to be searched on?" ^ String streamContents: [:strm | | usm | 1 to: self getListSize do: [:i | usm := (self getListItem: i) submorphs detect: [:m | m userString notNil] ifNone: []. strm nextPutAll: (usm ifNil: [''] ifNotNil: [usm userString]); cr]]! ! MorphTreeMorph subclass: #LazyMorphTreeMorph instanceVariableNames: 'lazyIncrement' classVariableNames: '' poolDictionaries: '' category: 'Morphic-MorphTreeWidget'! !LazyMorphTreeMorph commentStamp: '' prior: 0! 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: '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 11/19/2009 17:31'! buildRowMorphsFrom: aNodeMorph self buildRowMorphsFrom: aNodeMorph increment: self lazyIncrement. ! ! !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 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 2/6/2010 13:42'! lazyIncrement ^ lazyIncrement ifNil: [ lazyIncrement := 20 ] ! ! !LazyMorphTreeMorph methodsFor: 'initialize - release' stamp: 'tg 11/16/2009 02:26'! lazyIncrement: anInteger lazyIncrement := anInteger ! ! !LazyMorphTreeMorph methodsFor: 'lazy tree' stamp: 'AlainPlantec 11/15/2009 21:57'! indentingItemClass ^ LazyMorphTreeNodeMorph! ! MorphTreeNodeMorph subclass: #LazyMorphTreeNodeMorph instanceVariableNames: 'drawable' classVariableNames: '' poolDictionaries: '' category: 'Morphic-MorphTreeWidget'! !LazyMorphTreeNodeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/20/2009 07:27'! drawOn: aCanvas drawable ifFalse: [container buildRowMorphsFrom: self] ifTrue: [super drawOn: aCanvas] ! ! !LazyMorphTreeNodeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/19/2009 16:50'! drawSubmorphsOn: aCanvas drawable ifFalse: [^ self]. super drawSubmorphsOn: 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. ! ! !LazyMorphTreeNodeMorph methodsFor: 'initialization' stamp: 'AlainPlantec 11/15/2009 22:09'! initRow! ! !LazyMorphTreeNodeMorph methodsFor: 'initialization' stamp: 'AlainPlantec 11/15/2009 23:01'! initialize super initialize. drawable := false! ! ParseNode subclass: #LeafNode instanceVariableNames: 'key code index' classVariableNames: '' poolDictionaries: '' category: 'Compiler-ParseNodes'! !LeafNode commentStamp: '' prior: 0! 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: 'accessing'! key ^key! ! !LeafNode methodsFor: 'code generation' stamp: 'ab 7/6/2004 17:39'! code ^ code! ! !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: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: '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: '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: '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: 'initialize-release' stamp: 'ar 3/26/2004 15:44'! key: object code: byte key := object. code := byte! ! !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: 'private'! code: index type: type index isNil ifTrue: [^type negated]. (CodeLimits at: type) > index ifTrue: [^(CodeBases at: type) + index]. ^type * 256 + index! ! WeakAnnouncementSubscription weakSubclass: #LegacyWeakSubscription instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Announcements-Core'! !LegacyWeakSubscription commentStamp: 'IgorStasenko 3/12/2011 21:37' prior: 0! 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: '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: '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: 'finalization' stamp: 'IgorStasenko 3/12/2011 18:19'! register self weakRegistry add: self subscriber executor: self! ! !LegacyWeakSubscription methodsFor: 'finalization' stamp: 'IgorStasenko 3/12/2011 17:40'! unregister | sub | sub := self subscriber. sub ifNotNil: [ self weakRegistry remove: sub ] ! ! !LegacyWeakSubscription methodsFor: 'finalization' stamp: 'IgorStasenko 3/12/2011 14:16'! weakRegistry ^ WeakRegistry default! ! WriteStream subclass: #LimitedWriteStream instanceVariableNames: 'limit limitBlock' classVariableNames: '' poolDictionaries: '' category: 'Collections-Streams'! !LimitedWriteStream commentStamp: '' prior: 0! 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: '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! ! !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: '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! ! Object subclass: #LimitingLineStreamWrapper instanceVariableNames: 'stream line limitingBlock position' classVariableNames: '' poolDictionaries: '' category: 'Collections-Streams'! !LimitingLineStreamWrapper commentStamp: '' prior: 0! 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: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 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: '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 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'! next "Provide character-based access" position isNil ifTrue: [^nil]. position < line size ifTrue: [^line at: (position := position + 1)]. line := stream nextLine. self updatePosition. ^ Character cr! ! !LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 11/24/1998 14:09'! nextLine | thisLine | self atEnd ifTrue: [^nil]. thisLine := line. line := stream nextLine. ^thisLine ! ! !LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 11/13/1998 13:04'! peekLine self atEnd ifTrue: [^nil]. ^ line! ! !LimitingLineStreamWrapper methodsFor: 'accessing' stamp: 'bf 11/24/1998 16:53'! skipThisLine line := stream nextLine. self updatePosition. ! ! !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: '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: 'stream protocol' stamp: 'bf 11/13/1998 17:00'! close ^stream close! ! !LimitingLineStreamWrapper methodsFor: 'testing' stamp: 'bf 11/13/1998 16:55'! atEnd ^line isNil or: [limitingBlock value: line]! ! !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 class instanceVariableNames: ''! !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: '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 ! ! !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: 'instance creation' stamp: 'bf 11/24/1998 14:31'! on: aStream delimiter: aString ^self new setStream: aStream delimiter: aString ! ! PolygonMorph subclass: #LineMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Basic'! !LineMorph commentStamp: '' prior: 0! This is really only a shell for creating single-segment straight-line Shapes.! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! LineMorph class instanceVariableNames: ''! !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! ! !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! ! Object subclass: #LineSegment instanceVariableNames: 'start end' classVariableNames: '' poolDictionaries: '' category: 'Balloon-Geometry'! !LineSegment commentStamp: '' prior: 0! 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 11/2/1998 12:12'! bounds "Return the bounds containing the receiver" ^(start min: end) corner: (start max: end)! ! !LineSegment methodsFor: 'accessing' stamp: 'ar 6/8/2003 00:07'! degree ^1! ! !LineSegment methodsFor: 'accessing' stamp: 'ar 5/23/2001 19:11'! direction ^end - start! ! !LineSegment methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:12'! end "Return the end point" ^end! ! !LineSegment methodsFor: 'accessing' stamp: 'ar 6/7/2003 00:10'! end: aPoint end := aPoint! ! !LineSegment methodsFor: 'accessing' stamp: 'ar 11/2/1998 12:12'! start "Return the start point" ^start! ! !LineSegment methodsFor: 'accessing' stamp: 'ar 6/7/2003 00:10'! start: aPoint start := aPoint! ! !LineSegment methodsFor: 'bezier clipping' stamp: 'ar 6/8/2003 00:06'! bezierClipCurve: aCurve ^self bezierClipCurve: aCurve epsilon: 1! ! !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: '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: 'converting' stamp: 'ar 6/8/2003 04:19'! asBezier2Points: error ^Array with: start with: start with: end! ! !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: '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: '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: 'converting' stamp: 'ar 11/2/1998 12:11'! asLineSegment "Represent the receiver as a straight line segment" ^self! ! !LineSegment methodsFor: 'converting' stamp: 'ar 6/7/2003 20:57'! asTangentSegment ^LineSegment from: end-start to: end-start! ! !LineSegment methodsFor: 'converting' stamp: 'ar 6/7/2003 00:08'! reversed ^self class controlPoints: self controlPoints reversed! ! !LineSegment methodsFor: 'initialize' stamp: 'ar 11/2/1998 12:12'! from: startPoint to: endPoint "Initialize the receiver" start := startPoint. end := endPoint.! ! !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: '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: 'intersection' stamp: 'nk 12/27/2003 13:00'! roundTo: quantum start := start roundTo: quantum. end := end roundTo: quantum.! ! !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: 'testing' stamp: 'ar 11/2/1998 12:12'! hasZeroLength "Return true if the receiver has zero length" ^start = end! ! !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: '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 11/2/1998 12:07'! isLineSegment "Return true if the receiver is a line segment" ^true! ! !LineSegment methodsFor: 'testing' stamp: 'ar 11/2/1998 12:08'! isStraight "Return true if the receiver represents a straight line" ^true! ! !LineSegment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 00:15'! asBezier2Curves: err ^Array with: self! ! !LineSegment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 00:08'! controlPoints ^{start. end}! ! !LineSegment methodsFor: 'vector functions' stamp: 'ar 6/7/2003 23:39'! controlPointsDo: aBlock aBlock value: start; value: end! ! !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: '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 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 6/7/2003 17:21'! lineSegments: steps do: aBlock "Evaluate aBlock with the receiver's line segments" aBlock value: start value: end! ! !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: '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 11/2/1998 12:09'! tangentAt: parameter "Return the tangent at the given parametric value along the receiver" ^end - start! ! !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: 'ar 11/2/1998 12:09'! tangentAtStart "Return the tangent for the last point" ^(end - start)! ! !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 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: '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: 'private' stamp: 'ar 6/7/2003 21:00'! debugDraw ^self debugDrawAt: 0@0.! ! !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 class instanceVariableNames: ''! !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: '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'.! ! !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)! ! Object subclass: #Link instanceVariableNames: 'nextLink' classVariableNames: '' poolDictionaries: '' category: 'Collections-Support'! !Link commentStamp: '' prior: 0! 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: 'accessing'! nextLink "Answer the link to which the receiver points." ^nextLink! ! !Link methodsFor: 'accessing'! nextLink: aLink "Store the argument, aLink, as the link to which the receiver refers. Answer aLink." ^nextLink := aLink! ! !Link methodsFor: 'converting' stamp: 'HenrikSperreJohansen 10/18/2009 15:59'! asLink ^self! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Link class instanceVariableNames: ''! !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! ! SequenceableCollection subclass: #LinkedList uses: TSortable instanceVariableNames: 'firstLink lastLink' classVariableNames: '' poolDictionaries: '' category: 'Collections-Sequenceable'! !LinkedList commentStamp: 'HenrikSperreJohansen 10/18/2009 16:09' prior: 0! 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: 'accessing' stamp: 'HenrikSperreJohansen 10/18/2009 15:36'! at: index ^(self linkAt: index) value! ! !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: 'accessing' stamp: 'HenrikSperreJohansen 10/19/2009 11:07'! 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) ifTrue: [^ 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: '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 10/18/2009 17:20'! firstLink "Answer the first link. Create an error notification if the receiver is empty." self emptyCheck. ^firstLink ! ! !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: '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: '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: '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: '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: '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: '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: '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: '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: '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: 'copying' stamp: 'HenrikSperreJohansen 10/19/2009 15:09'! copyWith: newElement ^self copy add: newElement; yourself! ! !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: 'copying' stamp: 'nice 10/5/2009 08:49'! postCopy | aLink | super postCopy. firstLink isNil ifFalse: [ aLink := firstLink := firstLink copy. [aLink nextLink isNil] whileFalse: [aLink nextLink: (aLink := aLink nextLink copy)]. lastLink := 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: '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: 'enumerating' stamp: 'HenrikSperreJohansen 10/19/2009 11:03'! linksDo: aBlock | aLink | aLink := firstLink. [aLink == nil ] whileFalse: [ aBlock value: aLink. aLink := aLink nextLink]! ! !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: 'enumerating' stamp: 'ajh 8/6/2002 16:39'! species ^ Array! ! !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: 'removing' stamp: 'nice 1/10/2009 00:23'! removeAll "Implementation note: this has to be fast" firstLink := lastLink := nil! ! !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: '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: '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: 'removing' stamp: 'HenrikSperreJohansen 10/18/2009 17:43'! removeLink: aLink ^self removeLink: aLink ifAbsent: [self error: 'no such method!!']! ! !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: 'sorting'! 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! ! !LinkedList methodsFor: 'sorting'! 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! ! !LinkedList methodsFor: 'sorting'! 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]! ! !LinkedList methodsFor: 'sorting'! 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! ! !LinkedList methodsFor: 'sorting'! 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! ! !LinkedList methodsFor: 'sorting'! sort "Sort this collection into ascending order using the '<=' operator." self sort: [:a :b | a <= b]! ! !LinkedList methodsFor: 'sorting'! 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! ! !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: 'private' stamp: 'HenrikSperreJohansen 10/18/2009 17:11'! linkAt: index ^self linkAt: index ifAbsent: [ self errorSubscriptBounds: index]! ! !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: 'private' stamp: 'HenrikSperreJohansen 10/18/2009 17:40'! linkOf: anObject ^ self linkOf: anObject ifAbsent: [self error: 'No such element']! ! !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: 'private' stamp: 'HenrikSperreJohansen 10/19/2009 11:58'! validIndex: index ^index > 0 and: [index <= self size]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! LinkedList class uses: TSortable classTrait instanceVariableNames: ''! !LinkedList class methodsFor: 'accessing' stamp: 'CamilloBruni 9/5/2011 15:38'! streamSpecies ^ Array! ! !LinkedList class methodsFor: 'instance creation' stamp: 'HenrikSperreJohansen 10/19/2009 15:03'! new: anInt "LinkedList don't need capacity" ^self new! ! !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! ! !LinkedList class methodsFor: 'stream creation' stamp: 'CamilloBruni 9/5/2011 15:34'! new: size streamContents: aBlock ^ self withAll: (super new: size streamContents: aBlock)! ! TestCase subclass: #LinkedListTest uses: TAddTest - {#testTAddWithOccurences. #testTAddTwice. #testTWriteTwice} + TEmptyTest + TIterateTest + TIterateSequencedReadableTest + TPrintTest + TAsStringCommaAndDelimiterSequenceableTest + TIndexAccess + TSequencedElementAccessTest + TSubCollectionAccess + TConvertTest - {#testAsByteArray. #integerCollectionWithoutEqualElements} + TCopyPartOfSequenceable - {#testCopyEmptyMethod} + TCopySequenceableSameContents - {#testSortBy. #integerCollection} + TCopySequenceableWithOrWithoutSpecificElements + TCopyTest + TCopySequenceableWithReplacement - {#testCopyReplaceAllWithManyOccurence. #collectionWith2TimeSubcollection} + TBeginsEndsWith + TRemoveTest + TSetArithmetic + TIncludesWithIdentityCheckTest + TStructuralEqualityTest + TOccurrencesTest instanceVariableNames: 'nextLink n list link1 link2 link3 link4 nonEmpty otherList link collectionWithNil collectionWithoutNil nonEmpty1Element collectionWithoutEqualElements elementNotIn elementIn sameAtendAndBegining collection5Elements collectResult' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Sequenceable'! !LinkedListTest commentStamp: 'mk 8/3/2005 11:55' prior: 0! A set of test cases which thoroughly test functionality of the LinkedList class.! !LinkedListTest methodsFor: 'accessing' stamp: 'md 10/14/2004 10:47'! n ^n! ! !LinkedListTest methodsFor: 'accessing' stamp: 'md 10/14/2004 10:46'! nextLink ^nextLink! ! !LinkedListTest methodsFor: 'accessing' stamp: 'md 10/14/2004 10:46'! nextLink: aLink nextLink := aLink! ! !LinkedListTest methodsFor: 'accessing' stamp: 'md 10/14/2004 10:47'! n: number n := number. ! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 16:46'! accessCollection ^collectionWithoutEqualElements ! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 11:52'! anotherElementNotIn " return an element included in 'collection' " ^ elementNotIn ! ! !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: '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: 'damienpollet 1/29/2009 19:10'! collection ^ self nonEmpty! ! !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 15:14'! collectionMoreThan1NoDuplicates " return a collection of size 5 without equal elements" ^ collectionWithoutEqualElements! ! !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 4/24/2009 11:37'! collectionWith1TimeSubcollection " return a collection including 'oldSubCollection' only one time " ^ self oldSubCollection ! ! !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: 'requirements' stamp: 'damienpollet 1/29/2009 16:14'! collectionWithElement "Returns a collection that already includes what is returned by #element." ^ self collection! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 11:17'! collectionWithElementsToRemove " return a collection of elements included in 'nonEmpty' " ^ self nonEmpty ! ! !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: 'requirements' stamp: 'CamilloBruni 9/9/2011 12:11'! collectionWithoutEqualElements " return a collection not including equal elements " ^collectionWithoutEqualElements ! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/22/2009 17:07'! collectionWithoutNilElements " return a collection that doesn't includes a nil element " ^collectionWithoutNil ! ! !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: 'requirements' stamp: 'delaunay 4/23/2009 16:46'! elementInForElementAccessing " return an element inculded in 'accessCollection '" ^ elementIn ! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 16:27'! elementInForIndexAccessing " return an element included in 'accessCollection' " ^ elementIn ! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/22/2009 15:31'! elementNotIn ^ Link new! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 16:46'! elementNotInForElementAccessing " return an element not included in 'accessCollection' " ^ elementNotIn ! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 15:10'! elementNotInForIndexAccessing " return an element not included in 'accessCollection' " ^ elementNotIn ! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 16:07'! elementNotInForOccurrences " return an element notIncluded in #collectionWithoutEqualElements" ^ elementNotIn ! ! !LinkedListTest methodsFor: 'requirements' stamp: 'HenrikSperreJohansen 10/19/2009 14:48'! elementToAdd " return an element of type 'nonEmpy' elements'type'" ^ ValueLink value: 77! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 10:55'! indexInForCollectionWithoutDuplicates " return an index between 'collectionWithoutEqualsElements' bounds" ^ 2! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/24/2009 11:09'! indexInNonEmpty " return an index between bounds of 'nonEmpty' " ^ self nonEmpty size! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:52'! moreThan3Elements " return a collection including atLeast 3 elements" ^ collectionWithoutEqualElements ! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/27/2009 10:52'! moreThan4Elements " return a collection including at leat 4 elements" ^ collectionWithoutEqualElements ! ! !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: 'requirements' stamp: 'delaunay 4/23/2009 14:14'! nonEmpty1Element " return a collection of size 1 including one element" ^ nonEmpty1Element ! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 14:09'! nonEmptyMoreThan1Element " return a collection that don't includes equl elements'" ^collectionWithoutNil ! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:30'! nonEmptyWithoutEqualElements " return a collection without equal elements " ^ collectionWithoutEqualElements ! ! !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: 'requirements' stamp: 'damienpollet 1/29/2009 16:22'! otherCollection ^ otherList ifNil: [otherList := LinkedList with: Link new with: Link new]! ! !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: 'requirements' stamp: 'cyrille.delaunay 12/18/2009 12:05'! result "Returns a collection of the classes of elements in #collection" ^ collectResult! ! !LinkedListTest methodsFor: 'requirements' stamp: 'delaunay 4/22/2009 15:32'! speciesClass ^LinkedList! ! !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: '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: '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: 'test - equality'! testEqualSign "self debug: #testEqualSign" self deny: (self empty = self nonEmpty).! ! !LinkedListTest methodsFor: 'test - equality'! 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: 'test - equality'! testEqualSignOfIdenticalCollectionObjects "self debug: #testEqualSignOfIdenticalCollectionObjects" self assert: (self empty = self empty). self assert: (self nonEmpty = self nonEmpty). ! ! !LinkedListTest methodsFor: 'test - fixture'! test0FixtureIterateTest | res | self shouldnt: [ self collectionWithoutNilElements ] raise: Error. 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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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' 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: '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 - adding'! 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 - adding'! 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 - adding'! 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 - adding'! 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 - begins ends with'! 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 - begins ends with'! testsBeginsWithEmpty self deny: (self nonEmpty beginsWith:(self empty)). self deny: (self empty beginsWith:(self nonEmpty )). ! ! !LinkedListTest methodsFor: 'tests - begins ends with'! 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 - begins ends with'! testsEndsWithEmpty self deny: (self nonEmpty endsWith: self empty). self deny: (self empty endsWith: self nonEmpty). ! ! !LinkedListTest methodsFor: 'tests - comma and delimiter'! testAsCommaStringEmpty self assert: self empty asCommaString = ''. self assert: self empty asCommaStringAnd = ''. ! ! !LinkedListTest methodsFor: 'tests - comma and delimiter'! 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 - comma and delimiter'! 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 - comma and delimiter'! testAsStringOnDelimiterEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim. self assert: emptyStream contents = ''. ! ! !LinkedListTest methodsFor: 'tests - comma and delimiter'! testAsStringOnDelimiterLastEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim last:'and'. self assert: emptyStream contents = ''. ! ! !LinkedListTest methodsFor: 'tests - comma and delimiter'! 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: 'tests - comma and delimiter'! 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 - comma and delimiter'! 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 - comma and delimiter'! 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: 'tests - converting'! 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 - converting'! 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 - converting'! assertSameContents: aCollection whenConvertedTo: aClass | result | result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass. self assert: result size = aCollection size! ! !LinkedListTest methodsFor: 'tests - converting'! testAsArray "self debug: #testAsArray3" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Array! ! !LinkedListTest methodsFor: 'tests - converting'! testAsBag self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! ! !LinkedListTest methodsFor: 'tests - converting'! testAsIdentitySet "test with a collection without equal elements :" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: IdentitySet. ! ! !LinkedListTest methodsFor: 'tests - converting'! testAsOrderedCollection self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! ! !LinkedListTest methodsFor: 'tests - converting'! testAsSet | | "test with a collection without equal elements :" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Set. ! ! !LinkedListTest methodsFor: 'tests - copy'! 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 - copy'! 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: 'tests - copy'! 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 - copy'! 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'! 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 - copy'! 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'! 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 - copy'! 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 - copy'! 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 - copy'! 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 - copy'! 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 - copying part of sequenceable'! 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 - copying part of sequenceable'! testCopyAfterEmpty | result | result := self empty copyAfter: self collectionWithoutEqualElements first. self assert: result isEmpty. ! ! !LinkedListTest methodsFor: 'tests - copying part of sequenceable'! 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 - copying part of sequenceable'! testCopyAfterLastEmpty | result | result := self empty copyAfterLast: self collectionWithoutEqualElements first. self assert: result isEmpty.! ! !LinkedListTest methodsFor: 'tests - copying part of sequenceable'! 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 - copying part of sequenceable'! 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: 'tests - copying part of sequenceable'! testCopyUpToEmpty | result | result := self empty copyUpTo: self collectionWithoutEqualElements first. self assert: result isEmpty. ! ! !LinkedListTest methodsFor: 'tests - copying part of sequenceable'! 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: 'tests - copying part of sequenceable'! testCopyUpToLastEmpty | result | result := self empty copyUpToLast: self collectionWithoutEqualElements first. self assert: result isEmpty.! ! !LinkedListTest methodsFor: 'tests - copying same contents'! 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 - copying same contents'! 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 - copying same contents'! 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 - copying same contents'! testShallowCopyEmpty | result | result := self empty shallowCopy . self assert: result isEmpty .! ! !LinkedListTest methodsFor: 'tests - copying same contents'! 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 - copying with or without'! 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 - copying with or without'! 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 - copying with or without'! 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 - copying with or without'! 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 with or without'! 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 - copying with or without'! 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 - copying with replacement'! firstIndexesOf: subCollection 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: subCollection) ifTrue: [ result add: currentIndex. 1 to: subCollection size do: [:i | tmp := tmp copyWithoutFirst. currentIndex := currentIndex + 1] ] ifFalse: [ tmp := tmp copyWithoutFirst. currentIndex := currentIndex +1. ] ]. ^ result. ! ! !LinkedListTest methodsFor: 'tests - copying with replacement'! 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 - copying with replacement'! 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 - copying with replacement'! 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 - 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 - element accessing'! 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 - element accessing'! 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 - element accessing'! 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: 'tests - element accessing'! 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 - element accessing'! 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: 'tests - element accessing'! 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 - element accessing'! testAtLastError "self debug: #testAtLast" self should: [ self moreThan4Elements atLast: self moreThan4Elements size + 1 ] raise: Error! ! !LinkedListTest methodsFor: 'tests - element accessing'! 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 - element accessing'! 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 - element accessing'! 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 - element accessing'! testAtRandom | result | result := self nonEmpty atRandom . self assert: (self nonEmpty includes: result).! ! !LinkedListTest methodsFor: 'tests - element accessing'! 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 - element accessing'! 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 - element accessing'! 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 - element accessing'! 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 - element accessing'! testLast "self debug: #testLast" self assert: self moreThan4Elements last = (self moreThan4Elements at: self moreThan4Elements size)! ! !LinkedListTest methodsFor: 'tests - element accessing'! testMiddle "self debug: #testMiddle" self assert: self moreThan4Elements middle = (self moreThan4Elements at: self moreThan4Elements size // 2 + 1)! ! !LinkedListTest methodsFor: 'tests - empty' stamp: 'damien.pollet 10/31/2008 14:36'! empty ^ list! ! !LinkedListTest methodsFor: 'tests - empty'! testIfEmpty self nonEmpty ifEmpty: [ self assert: false] . self empty ifEmpty: [ self assert: true] . ! ! !LinkedListTest methodsFor: 'tests - empty'! testIfEmptyifNotEmpty self assert: (self empty ifEmpty: [true] ifNotEmpty: [false]). self assert: (self nonEmpty ifEmpty: [false] ifNotEmpty: [true]). ! ! !LinkedListTest methodsFor: 'tests - empty'! testIfEmptyifNotEmptyDo "self debug #testIfEmptyifNotEmptyDo" self assert: (self empty ifEmpty: [true] ifNotEmptyDo: [:s | false]). self assert: (self nonEmpty ifEmpty: [false] ifNotEmptyDo: [:s | true]). self assert: (self nonEmpty ifEmpty: [false] ifNotEmptyDo: [:s | s]) == self nonEmpty.! ! !LinkedListTest methodsFor: 'tests - empty'! 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 - empty'! testIfNotEmptyDo self empty ifNotEmptyDo: [:s | self assert: false]. self assert: (self nonEmpty ifNotEmptyDo: [:s | s]) == self nonEmpty ! ! !LinkedListTest methodsFor: 'tests - empty'! testIfNotEmptyDoifNotEmpty self assert: (self empty ifNotEmptyDo: [:s | false] ifEmpty: [true]). self assert: (self nonEmpty ifNotEmptyDo: [:s | s] ifEmpty: [false]) == self nonEmpty! ! !LinkedListTest methodsFor: 'tests - empty'! testIfNotEmptyifEmpty self assert: (self empty ifNotEmpty: [false] ifEmpty: [true]). self assert: (self nonEmpty ifNotEmpty: [true] ifEmpty: [false]). ! ! !LinkedListTest methodsFor: 'tests - empty'! testIsEmpty self assert: (self empty isEmpty). self deny: (self nonEmpty isEmpty).! ! !LinkedListTest methodsFor: 'tests - empty'! testIsEmptyOrNil self assert: (self empty isEmptyOrNil). self deny: (self nonEmpty isEmptyOrNil).! ! !LinkedListTest methodsFor: 'tests - empty'! testNotEmpty self assert: (self nonEmpty notEmpty). self deny: (self empty notEmpty).! ! !LinkedListTest methodsFor: 'tests - fixture'! howMany: subCollection in: collection " return an integer representing how many time 'subCollection' appears in 'collection' " | tmp nTime | tmp:= collection. nTime:= 0. [tmp isEmpty ]whileFalse: [ (tmp beginsWith: subCollection) ifTrue: [ nTime := nTime + 1. 1 to: subCollection size do: [:i | tmp := tmp copyWithoutFirst.] ] ifFalse: [tmp := tmp copyWithoutFirst.] ]. ^ nTime. ! ! !LinkedListTest methodsFor: 'tests - fixture'! test0CopyTest self shouldnt: [ self empty ]raise: Error. self assert: self empty size = 0. self shouldnt: [ self nonEmpty ]raise: Error. self assert: (self nonEmpty size = 0) not. self shouldnt: [ self collectionWithElementsToRemove ]raise: Error. self assert: (self collectionWithElementsToRemove size = 0) not. self collectionWithElementsToRemove do: [:each | self assert: ( self nonEmpty includes: each)]. self shouldnt: [ self elementToAdd ]raise: Error. self deny: (self nonEmpty includes: self elementToAdd ). self shouldnt: [ self collectionNotIncluded ]raise: Error. self collectionNotIncluded do: [ :each | self deny: (self nonEmpty includes: each) ]! ! !LinkedListTest methodsFor: 'tests - fixture'! test0FixtureAsStringCommaAndDelimiterTest self shouldnt: [self nonEmpty] raise:Error . self deny: self nonEmpty isEmpty. self shouldnt: [self empty] raise:Error . self assert: self empty isEmpty. self shouldnt: [self nonEmpty1Element ] raise:Error . self assert: self nonEmpty1Element size=1.! ! !LinkedListTest methodsFor: 'tests - fixture'! test0FixtureBeginsEndsWithTest self shouldnt: [self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self assert: self nonEmpty size>1. self shouldnt: [self empty ] raise: Error. self assert: self empty isEmpty.! ! !LinkedListTest methodsFor: 'tests - fixture'! test0FixtureCopyPartOfSequenceableTest self shouldnt: [self collectionWithoutEqualElements ] raise: Error. self collectionWithoutEqualElements do: [:each | self assert: (self collectionWithoutEqualElements occurrencesOf: each)=1]. self shouldnt: [self indexInForCollectionWithoutDuplicates ] raise: Error. self assert: self indexInForCollectionWithoutDuplicates >0 & self indexInForCollectionWithoutDuplicates < self collectionWithoutEqualElements size. self shouldnt: [self empty] raise: Error. self assert: self empty isEmpty .! ! !LinkedListTest methodsFor: 'tests - fixture'! test0FixtureCopySameContentsTest self shouldnt: [self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [self empty ] raise: Error. self assert: self empty isEmpty. ! ! !LinkedListTest methodsFor: 'tests - fixture'! test0FixtureCopyWithOrWithoutSpecificElementsTest self shouldnt: [self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty . self shouldnt: [self indexInNonEmpty ] raise: Error. self assert: self indexInNonEmpty > 0. self assert: self indexInNonEmpty <= self nonEmpty size.! ! !LinkedListTest methodsFor: 'tests - fixture'! test0FixtureCopyWithReplacementTest self shouldnt: [self replacementCollection ]raise: Error. self shouldnt: [self oldSubCollection] raise: Error. self shouldnt: [self collectionWith1TimeSubcollection ]raise: Error. self assert: (self howMany: self oldSubCollection in: self collectionWith1TimeSubcollection ) = 1. ! ! !LinkedListTest methodsFor: 'tests - fixture'! test0FixtureEmptyTest self shouldnt: [ self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self empty ] raise: Error. self assert: self empty isEmpty.! ! !LinkedListTest methodsFor: 'tests - fixture'! test0FixtureIncludeTest | anElementIn | self shouldnt: [ self nonEmpty ]raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self elementNotIn ]raise: Error. anElementIn := true. self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self shouldnt: [ self anotherElementNotIn ]raise: Error. anElementIn := true. self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self shouldnt: [ self empty ] raise: Error. self assert: self empty isEmpty. ! ! !LinkedListTest methodsFor: 'tests - fixture'! test0FixtureIncludeWithIdentityTest | anElement | self shouldnt: [ self collectionWithCopyNonIdentical ]raise: Error. anElement := self collectionWithCopyNonIdentical anyOne. self deny: anElement == anElement copy.! ! !LinkedListTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/23/2009 15:14'! test0FixtureIndexAccessTest | res | self shouldnt: [ self collectionMoreThan1NoDuplicates ] raise: Error. 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 shouldnt: [ self elementInForIndexAccessing ] raise: Error. self assert: (self collectionMoreThan1NoDuplicates includes: self elementInForIndexAccessing). self shouldnt: [ self elementNotInForIndexAccessing ] raise: Error. self deny: (self collectionMoreThan1NoDuplicates includes: self elementNotInForIndexAccessing)! ! !LinkedListTest methodsFor: 'tests - fixture'! test0FixtureIterateSequencedReadableTest | res | self shouldnt: self nonEmptyMoreThan1Element raise: Error. self assert: self nonEmptyMoreThan1Element size > 1. self shouldnt: self empty raise: Error. 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 - fixture'! test0FixtureOccurrencesTest | tmp | self shouldnt: [self empty ]raise: Error. self assert: self empty isEmpty. self shouldnt: [ self collectionWithoutEqualElements ] raise: Error. self deny: self collectionWithoutEqualElements isEmpty. tmp := OrderedCollection new. self collectionWithoutEqualElements do: [ :each | self deny: (tmp includes: each). tmp add: each. ]. self shouldnt: [ self elementNotInForOccurrences ] raise: Error. self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! ! !LinkedListTest methodsFor: 'tests - fixture'! test0FixturePrintTest self shouldnt: [self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty.! ! !LinkedListTest methodsFor: 'tests - fixture'! test0FixtureRequirementsOfTAddTest self shouldnt: [ self collectionWithElement ] raise: Exception. self shouldnt: [ self otherCollection ] raise: Exception. self shouldnt: [ self element ] raise: Exception. self assert: (self collectionWithElement includes: self element). self deny: (self otherCollection includes: self element)! ! !LinkedListTest methodsFor: 'tests - fixture'! test0FixtureSequencedElementAccessTest self shouldnt: [ self moreThan4Elements ] raise: Error. self assert: self moreThan4Elements size >= 4. self shouldnt: [ self subCollectionNotIn ] raise: Error. self subCollectionNotIn detect: [ :each | (self moreThan4Elements includes: each) not ] ifNone: [ self assert: false ]. self shouldnt: [ self elementNotInForElementAccessing ] raise: Error. self deny: (self moreThan4Elements includes: self elementNotInForElementAccessing). self shouldnt: [ self elementInForElementAccessing ] raise: Error. self assert: (self moreThan4Elements includes: self elementInForElementAccessing)! ! !LinkedListTest methodsFor: 'tests - fixture'! test0FixtureSetAritmeticTest self shouldnt: [ self collection ] raise: Error. self deny: self collection isEmpty. self shouldnt: [ self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self anotherElementOrAssociationNotIn ] raise: Error. self collection isDictionary ifTrue: [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ] ifFalse: [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ]. self shouldnt: [ self collectionClass ] raise: Error! ! !LinkedListTest methodsFor: 'tests - fixture'! test0FixtureSubcollectionAccessTest self shouldnt: [ self moreThan3Elements ] raise: Error. self assert: self moreThan3Elements size > 2! ! !LinkedListTest methodsFor: 'tests - fixture'! test0FixtureTConvertTest "a collection of number without equal elements:" | res | self shouldnt: [ self collectionWithoutEqualElements ]raise: Error. res := true. self collectionWithoutEqualElements detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false. ! ! !LinkedListTest methodsFor: 'tests - fixture'! test0FixtureTRemoveTest | duplicate | self shouldnt: [ self empty ]raise: Error. self shouldnt: [ self nonEmptyWithoutEqualElements] raise:Error. self deny: self nonEmptyWithoutEqualElements isEmpty. duplicate := true. self nonEmptyWithoutEqualElements detect: [:each | (self nonEmptyWithoutEqualElements occurrencesOf: each) > 1] ifNone: [duplicate := false]. self assert: duplicate = false. self shouldnt: [ self elementNotIn ] raise: Error. self assert: self empty isEmpty. self deny: self nonEmptyWithoutEqualElements isEmpty. self deny: (self nonEmptyWithoutEqualElements includes: self elementNotIn)! ! !LinkedListTest methodsFor: 'tests - fixture'! test0TStructuralEqualityTest self shouldnt: [self empty] raise: Error. self shouldnt: [self nonEmpty] raise: Error. self assert: self empty isEmpty. self deny: self nonEmpty isEmpty.! ! !LinkedListTest methodsFor: 'tests - includes' stamp: 'delaunay 4/28/2009 10:22'! 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 shouldnt: [ self collectionWithCopyNonIdentical ] raise: Error. collection := self collectionWithCopyNonIdentical. element := collection anyOne copy. "self assert: (collection includes: element)." self deny: (collection identityIncludes: element)! ! !LinkedListTest methodsFor: 'tests - includes'! 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 - includes'! testIncludesAllNoneThere "self debug: #testIncludesAllOfNoneThere'" self deny: (self empty includesAll: self nonEmpty ). self deny: (self nonEmpty includesAll: { self elementNotIn. self anotherElementNotIn })! ! !LinkedListTest methodsFor: 'tests - includes'! 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 - includes'! testIncludesAnyNoneThere "self debug: #testIncludesAnyOfNoneThere'" self deny: (self nonEmpty includesAny: self empty). self deny: (self nonEmpty includesAny: { self elementNotIn. self anotherElementNotIn })! ! !LinkedListTest methodsFor: 'tests - includes'! 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: 'tests - includes'! testIncludesElementIsThere "self debug: #testIncludesElementIsThere" self assert: (self nonEmpty includes: self nonEmpty anyOne).! ! !LinkedListTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! testIdentityIndexOf "self debug: #testIdentityIndexOf" | collection element | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection identityIndexOf: element) = (collection indexOf: element)! ! !LinkedListTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 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: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 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 - index access' stamp: 'delaunay 4/23/2009 15:14'! 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 - index access' stamp: 'delaunay 4/23/2009 15:14'! 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 - index access'! 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: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 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: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 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: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 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 - index access' stamp: 'delaunay 4/23/2009 15:14'! 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 - index access' stamp: 'delaunay 4/23/2009 15:14'! 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 - iterate on sequenced reable collections'! 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'! 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 - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! testDo! ! !LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections'! 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'! testFindFirstNotIn | result | result:=self empty findFirst: [:each | true]. self assert: result=0. ! ! !LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections'! 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: 'tests - iterate on sequenced reable collections'! testFindLastNotIn | result | result:=self empty findFirst: [:each | true]. self assert: result=0. ! ! !LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections'! 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: 'tests - iterate on sequenced reable collections'! 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: 'tests - iterate on sequenced reable collections'! testKeysAndValuesDoEmpty | result | result:= OrderedCollection new. self empty keysAndValuesDo: [:i :value| result add: (value+i)]. self assert: result isEmpty .! ! !LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! testReverseDoEmpty | result | result:= OrderedCollection new. self empty reverseDo: [: each | result add: each]. self assert: result isEmpty .! ! !LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! testWithCollectError self should: [self nonEmptyMoreThan1Element with: self empty collect:[:a :b | ]] raise: Error.! ! !LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections'! 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'! testWithDoError self should: [self nonEmptyMoreThan1Element with: self empty do:[:a :b | ]] raise: Error.! ! !LinkedListTest methodsFor: 'tests - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! 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 - iterating'! 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 - iterating'! testAllSatisfyEmpty self assert: ( self empty allSatisfy: [:each | false]). ! ! !LinkedListTest methodsFor: 'tests - iterating'! 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 - iterating'! 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 = self collectionWithoutNilElements size. ! ! !LinkedListTest methodsFor: 'tests - iterating'! testBasicCollectEmpty | res | res := self empty collect: [:each | each class]. self assert: res isEmpty ! ! !LinkedListTest methodsFor: 'tests - iterating'! testCollectOnEmpty self assert: (self empty collect: [:e | self fail]) isEmpty! ! !LinkedListTest methodsFor: 'tests - iterating'! testCollectThenSelectOnEmpty self assert: (self empty collect: [:e | self fail] thenSelect: [:e | self fail]) isEmpty! ! !LinkedListTest methodsFor: 'tests - iterating'! testDetect | res element | element := self collectionWithoutNilElements anyOne . res := self collectionWithoutNilElements detect: [:each | each = element]. self assert: (res = element). ! ! !LinkedListTest methodsFor: 'tests - iterating'! 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: 'tests - iterating'! 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 - iterating'! 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 - iterating'! 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: 'tests - iterating'! testInjectInto |result| result:= self collectionWithoutNilElements inject: 0 into: [:inj :ele | ele notNil ifTrue: [ inj + 1 ]]. self assert: self collectionWithoutNilElements size = result .! ! !LinkedListTest methodsFor: 'tests - iterating'! 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 - iterating'! testNoneSatisfyEmpty self assert: ( self empty noneSatisfy: [:each | false]). ! ! !LinkedListTest methodsFor: 'tests - iterating'! 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 - iterating'! testRejectEmpty | res | res := self empty reject: [:each | each odd]. self assert: res size = self empty size ! ! !LinkedListTest methodsFor: 'tests - iterating'! testRejectNoReject | res | res := self collectionWithoutNilElements reject: [:each | each notNil not]. self assert: res size = self collectionWithoutNilElements size. ! ! !LinkedListTest methodsFor: 'tests - iterating'! testSelect | res element | res := self collectionWithoutNilElements select: [:each | each notNil]. self assert: res size = self collectionWithoutNilElements size. element := self collectionWithoutNilElements anyOne. res := self collectionWithoutNilElements select: [:each | (each = element) not]. self assert: res size = (self collectionWithoutNilElements size - 1). ! ! !LinkedListTest methodsFor: 'tests - iterating'! testSelectOnEmpty self assert: (self empty select: [:e | self fail]) isEmpty ! ! !LinkedListTest methodsFor: 'tests - occurrencesOf'! testOccurrencesOf | collection | collection := self collectionWithoutEqualElements . collection do: [ :each | self assert: (collection occurrencesOf: each) = 1 ].! ! !LinkedListTest methodsFor: 'tests - occurrencesOf'! testOccurrencesOfEmpty | result | result := self empty occurrencesOf: (self collectionWithoutEqualElements anyOne). self assert: result = 0! ! !LinkedListTest methodsFor: 'tests - occurrencesOf'! testOccurrencesOfNotIn | result | result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences. self assert: result = 0! ! !LinkedListTest methodsFor: 'tests - printing'! 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 - printing'! 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 - printing'! 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 - printing'! 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: 'tests - printing'! 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 - printing'! 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 - remove'! testRemoveAllError "self debug: #testRemoveElementThatExists" | el aSubCollection | el := self elementNotIn. aSubCollection := self nonEmptyWithoutEqualElements copyWith: el. self should: [ | res | res := self nonEmptyWithoutEqualElements removeAll: aSubCollection ] raise: Error! ! !LinkedListTest methodsFor: 'tests - remove'! testRemoveAllFoundIn "self debug: #testRemoveElementThatExists" | el aSubCollection | el := self nonEmptyWithoutEqualElements anyOne. aSubCollection := (self nonEmptyWithoutEqualElements copyWithout: el) copyWith: self elementNotIn. self shouldnt: [ | res | res := self nonEmptyWithoutEqualElements removeAllFoundIn: aSubCollection ] raise: Error. self assert: self nonEmptyWithoutEqualElements size = 1. self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! ! !LinkedListTest methodsFor: 'tests - remove'! 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 - remove'! testRemoveElementFromEmpty "self debug: #testRemoveElementFromEmpty" self should: [ self empty remove: self nonEmptyWithoutEqualElements anyOne ] raise: Error! ! !LinkedListTest methodsFor: 'tests - remove'! 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 - remove'! testRemoveElementThatExists "self debug: #testRemoveElementThatExists" | el res | el := self nonEmptyWithoutEqualElements anyOne. self shouldnt: [ res := self nonEmptyWithoutEqualElements remove: el ] raise: Error. self assert: res == el! ! !LinkedListTest methodsFor: 'tests - remove'! testRemoveIfAbsent "self debug: #testRemoveElementThatExists" | el res | el := self elementNotIn. self shouldnt: [ res := self nonEmptyWithoutEqualElements remove: el ifAbsent: [ 33 ] ] raise: Error. self assert: res = 33! ! !LinkedListTest methodsFor: 'tests - set arithmetic'! 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 - set arithmetic'! numberOfSimilarElementsInIntersection ^ self collection occurrencesOf: self anotherElementOrAssociationIn! ! !LinkedListTest methodsFor: 'tests - set arithmetic'! 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 - set arithmetic'! 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 - set arithmetic'! 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 = 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 = separateCol! ! !LinkedListTest methodsFor: 'tests - set arithmetic'! 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'! 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 - set arithmetic'! 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 - set arithmetic'! 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 - set arithmetic'! 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 - set arithmetic'! testUnionOfEmpties "self debug: #testUnionOfEmpties" self assert: (self empty union: self empty) isEmpty. ! ! !LinkedListTest methodsFor: 'tests - subcollections access'! 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 - subcollections access'! 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: 'tests - subcollections access'! 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 - subcollections access'! 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: 'tests - subcollections access'! 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 - subcollections access'! 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: '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: '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: '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 - 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 - 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 class uses: TAddTest classTrait + TEmptyTest classTrait + TIterateTest classTrait + TIterateSequencedReadableTest classTrait + TPrintTest classTrait + TAsStringCommaAndDelimiterSequenceableTest classTrait + TIndexAccess classTrait + TSequencedElementAccessTest classTrait + TSubCollectionAccess classTrait + TConvertTest classTrait + TCopyPartOfSequenceable classTrait + TCopySequenceableSameContents classTrait + TCopySequenceableWithOrWithoutSpecificElements classTrait + TCopyTest classTrait + TCopySequenceableWithReplacement classTrait + TBeginsEndsWith classTrait + TRemoveTest classTrait + TSetArithmetic classTrait + TIncludesWithIdentityCheckTest classTrait + TStructuralEqualityTest classTrait + TOccurrencesTest classTrait instanceVariableNames: ''! AbstractBasicWidget subclass: #ListComposableModel instanceVariableNames: 'selectionHolder listHolder menuHolder shortcutsHolder multiSelectionHolder multiSelection allowToSelect listItemsCache filteringBlockHolder sortingBlockHolder wrapBlockHolder listAnnouncer' classVariableNames: '' poolDictionaries: '' category: 'Spec-Widgets'! !ListComposableModel commentStamp: '' prior: 0! 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). ! !ListComposableModel methodsFor: 'focus' stamp: 'BenjaminVanRyseghem 2/8/2013 13:20'! eventKeyStrokeForNextFocus "String describing the keystroke to perform to jump to the next widget" ^ Character arrowRight asShortcut! ! !ListComposableModel methodsFor: 'focus' stamp: 'BenjaminVanRyseghem 2/8/2013 13:21'! eventKeyStrokeForPreviousFocus "String describing the keystroke to perform to jump to the previous widget" ^ Character arrowLeft asShortcut! ! !ListComposableModel methodsFor: 'initialize' stamp: 'SD 4/19/2012 15:26'! defaultFilteringBlock ^ [:col | col]! ! !ListComposableModel methodsFor: 'initialize' stamp: 'StephaneDucasse 4/17/2012 19:15'! defaultSortingBlock ^ [:a :b | true]! ! !ListComposableModel methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 2/21/2013 23:25'! initialize super initialize. selectionHolder := SelectionValueHolder new. listHolder := Array new asValueHolder. sortingBlockHolder := self defaultSortingBlock asValueHolder. filteringBlockHolder := self defaultFilteringBlock asValueHolder. wrapBlockHolder := [ :object | object asStringOrText ] asValueHolder. menuHolder := [ :menu :shifted | nil ] asValueHolder. multiSelectionHolder := IdentityDictionary new asValueHolder. multiSelection := false asValueHolder. allowToSelect := true asValueHolder. listAnnouncer := Announcer new. self registerEvents. self on: Character space asShortcut do: [ self clickOnSelectedItem ]! ! !ListComposableModel methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 6/7/2012 12:28'! registerEvents listHolder whenChangedDo: [ self refreshListItems ]. filteringBlockHolder whenChangedDo: [ self refreshListItems ]. selectionHolder index whenChangedDo: [ self changed: #getIndex ]. multiSelection whenChangedDo: [ :b | self widget ifNotNil: [:w | w setMultipleSelection: b ] ]. wrapBlockHolder whenChangedDo:[ self changed: #listElementAt: ]. sortingBlockHolder whenChangedDo: [ listHolder contents: (listHolder contents sorted: sortingBlockHolder contents). self changed: #listElementAt: ]. ! ! !ListComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 02:20'! allowToSelect "Return whether the list items can be selected or not" ^ allowToSelect contents! ! !ListComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/16/2012 17:53'! allowToSelect: aBoolean "Set if the list items can be selected or not" allowToSelect contents: aBoolean. aBoolean ifFalse: [ self resetSelection ].! ! !ListComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 02:21'! beMultipleSelection "Make list selection multiple" self multiSelection: true! ! !ListComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 02:21'! beSingleSelection "Make list selection single" self multiSelection: false! ! !ListComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 02:39'! 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 contents! ! !ListComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 02:39'! 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 contents: aBlock! ! !ListComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 02:39'! filteringBlock "Return the filtering of the items" ^ filteringBlockHolder contents! ! !ListComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 02:38'! filteringBlock: aBlock "To set the filtering of the items" filteringBlockHolder contents: aBlock! ! !ListComposableModel methodsFor: 'protocol' stamp: 'ThierryGoubier 2/5/2013 15:43'! 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 contents. listHolder contents: (aList sorted: sortingBlockHolder contents). listAnnouncer announce: (ValueChanged oldContents: oldContents newContents: listHolder contents)! ! !ListComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 02:21'! listItems "Return the items of the list. They are your domain specific items" ^ listItemsCache ifNil: [ listItemsCache := filteringBlockHolder contents value: listHolder contents ] ! ! !ListComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 02:31'! listSize "Return the size of the list" ^ self listItems size! ! !ListComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 02:33'! menu "Return the block used to defined the menu" ^ menuHolder contents! ! !ListComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 02:34'! menu: aBlock "Set the block used to defined the menu" menuHolder contents: aBlock! ! !ListComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 02:22'! multiSelection "Return true if the list has a multiple selection. False if the list has a single selection" ^ multiSelection contents! ! !ListComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 02:22'! multiSelection: aBoolean "Make the list seelction become multiple if aBoolean is true. Otherwise set the selection as single" multiSelection contents: aBoolean. ! ! !ListComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 02:22'! resetFilteringBlock "Reset the filtering block with the default value which consists in showing everything" filteringBlockHolder contents: self defaultFilteringBlock! ! !ListComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 02:22'! resetSelection "Unselect every items" selectionHolder reset. multiSelectionHolder removeAll! ! !ListComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 02:22'! resetSortingBlock "Reset the sortering block with the default value which consists in not sorting" sortingBlockHolder contents: self defaultSortingBlock! ! !ListComposableModel 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! ! !ListComposableModel 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 ]! ! !ListComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 02:23'! selectedItem "Return the selected item. In the case of a multiple selection list, it returns the last selected item" ^ self selectedItemHolder contents! ! !ListComposableModel 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 ]! ! !ListComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/20/2012 16:21'! 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 contents: idx. selectionHolder selection contents: selection.! ! !ListComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 02:24'! setSelectedItem: anItem "Set the item you want to be selected" | index | self okToChange ifFalse: [ ^ self ]. index := self listItems identityIndexOf: anItem ifAbsent: [ ^ self ]. selectionHolder index contents: index. selectionHolder selection contents: anItem! ! !ListComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 02:40'! sortingBlock "Return the ordering of the items" ^ sortingBlockHolder contents! ! !ListComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 02:40'! sortingBlock: aBlock "To set the ordering of the items" sortingBlockHolder contents: aBlock! ! !ListComposableModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/13/2012 02:24'! updateList "Refresh the list" self changed: #listElementAt:. self resetSelection! ! !ListComposableModel 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! ! !ListComposableModel methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 7/13/2012 02:39'! whenDisplayBlockChanged: aBlock "Set a block to value when the filtering block block has changed" wrapBlockHolder whenChangedDo: aBlock! ! !ListComposableModel 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! ! !ListComposableModel methodsFor: 'protocol-events' stamp: 'ThierryGoubier 2/5/2013 15:40'! 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 newContents cull: announcement oldContents cull: announcement cull: ann ]. listAnnouncer weak on: ValueChanged do: block! ! !ListComposableModel 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! ! !ListComposableModel 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! ! !ListComposableModel 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! ! !ListComposableModel 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.! ! !ListComposableModel 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! ! !ListComposableModel 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! ! !ListComposableModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 2/8/2013 14:23'! clickOnSelectedItem | item | item := self selectedItem. ^ (item notNil and: [ item respondsTo: #click ]) ifTrue: [ ^ item click ]! ! !ListComposableModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/7/2012 13:23'! refreshListItems listItemsCache := nil. ^ self changed: #listElementAt:! ! !ListComposableModel methodsFor: 'private' stamp: 'StephaneDucasse 5/17/2012 18:04'! selectedItemHolder ^ selectionHolder selection! ! !ListComposableModel methodsFor: 'private-morphic' stamp: 'StephaneDucasse 5/17/2012 18:22'! getIndex "Morphic API - The method should only be used internally for the communication between the model and the morphic widget" "Return the index of the selected item" ^ selectionHolder index contents! ! !ListComposableModel methodsFor: 'private-morphic' stamp: 'StephaneDucasse 5/17/2012 18:24'! getSelectionStateFor: anIndex "Morphic API - The method should only be used internally for the communication between the model and the morphic widget" "Return the current state of the item -if selected or not - iun a multiple selection list" "Answer true if the item at index _anIndex_ is selected" ^ (multiSelectionHolder at: anIndex ifAbsent: [ ^ false ]) == true! ! !ListComposableModel methodsFor: 'private-morphic' stamp: 'StephaneDucasse 5/17/2012 18:25'! listElementAt: anIndex "Morphic API - The method should only be used internally for the communication between the model and the morphic widget" "Return the item at index _anIndex_" ^ self listItems at: anIndex ifAbsent: [ nil ]! ! !ListComposableModel methodsFor: 'private-morphic' stamp: 'BenjaminVanRyseghem 7/16/2012 19:10'! listElementAt: anIndex ifAbsent: aBlock "Morphic API - The method should only be used internally for the communication between the model and the morphic widget" "Return the item at index _anIndex_" ^ self listItems at: anIndex ifAbsent: aBlock! ! !ListComposableModel methodsFor: 'private-morphic' stamp: 'StephaneDucasse 5/17/2012 18:49'! menu: aMenu shifted: aBoolean "Morphic API - The method should only be used internally for the communication between the model and the morphic widget" "Build the menu when you right click on an item" ^ menuHolder contents cull: aMenu cull: aBoolean! ! !ListComposableModel methodsFor: 'private-morphic' stamp: 'StephaneDucasse 5/17/2012 18:50'! resetListSelection "Morphic API - The method should only be used internally for the communication between the model and the morphic widget" "Reset the selection manager for multiple selection lists" multiSelectionHolder removeAll! ! !ListComposableModel methodsFor: 'private-morphic' stamp: 'StephaneDucasse 5/17/2012 19:18'! setIndex: anIndex "Morphic API - The method should only be used internally for the communication between the model and the morphic widget" "Set the index of the selected item when you click on an item" self allowToSelect ifFalse: [ ^ self ]. self okToChange ifFalse: [ ^ self ]. selectionHolder index contents: anIndex. selectionHolder selection contents: (self listElementAt: anIndex).! ! !ListComposableModel methodsFor: 'private-morphic' stamp: 'StephaneDucasse 5/17/2012 18:55'! setSelectionStateFor: anIndex at: aBoolean "Morphic API - The method should only be used internally for the communication between the model and the morphic widget" "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! ! !ListComposableModel methodsFor: 'private-morphic' stamp: 'BenjaminVanRyseghem 7/14/2012 16:41'! wrapItem: anObject index: index "Morphic API - The method should only be used internally for the communication between the model and the morphic widget" "Return the item _anObject_ wrapped" ^ wrapBlockHolder contents cull: anObject cull: index! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ListComposableModel class instanceVariableNames: ''! !ListComposableModel class methodsFor: '*Spec-Builder' stamp: 'bvr 5/31/2012 13:36'! possibleEvents ^ #(whenListChanged whenSelectionChanged whenSelectedItemChanged whenSelectedIndexChanged)! ! !ListComposableModel class methodsFor: 'example' stamp: 'StephaneDucasse 5/17/2012 18:02'! example | instance | instance := self new. instance openWithSpec. instance items: (Smalltalk allClasses).! ! !ListComposableModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 2/8/2013 14:24'! defaultSpec ^ {#ListSpec. #model:. #model. #getListSizeSelector:. #listSize. #getIndexSelector:. #getIndex. #setIndexSelector:. #setIndex:. #getSelectionListSelector:. #getSelectionStateFor:. #setSelectionListSelector:. #setSelectionStateFor:at:. #getListElementSelector:. #listElementAt:. #resetListSelector:. #resetListSelection. #getMenuSelector:. #menu:shifted:. #setMultipleSelection:. {#model. #multiSelection}. #wrapSelector:. #wrapItem:index:. #borderWidth:. #(model borderWidth). #borderColor:. #(model borderColor). #setBalloonText:. { #model . #help}. #hResizing:. #spaceFill. #vResizing:. #spaceFill}! ! !ListComposableModel class methodsFor: 'specs'! title ^ 'List'! ! TestCase subclass: #ListComposableModelTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Spec-Tests'! !ListComposableModelTest commentStamp: '' prior: 0! testing ListComposableModel! !ListComposableModelTest methodsFor: 'tests' stamp: 'ThierryGoubier 2/5/2013 15:48'! testWhenListChanged "Two stages list changed notification." 50 timesRepeat: [ | list ok | list := ListComposableModel 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 ]! ! !ListComposableModelTest methodsFor: 'tests' stamp: 'ThierryGoubier 2/5/2013 15:54'! testWhenListChangedOldContents "access to old and new contents in whenListChanged." | list oldL newL ok | list := ListComposableModel 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)! ! MessageDialogWindow subclass: #ListDialogWindow instanceVariableNames: 'pattern list searchMorph listMorph listIndex answer listBlock listCreationProcess displayBlock browseBlock' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Windows'! !ListDialogWindow commentStamp: '' prior: 0! 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: 'accessing' stamp: 'CamilloBruni 8/11/2011 08:14'! answer ^ answer! ! !ListDialogWindow methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/18/2012 18:12'! answer: anObject answer := anObject! ! !ListDialogWindow methodsFor: 'actions' stamp: 'BenjaminVanRyseghem 6/26/2012 23:01'! cancel self answer: nil. super cancel! ! !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: '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: 'as yet unclassified' stamp: 'BenjaminVanRyseghem 12/18/2012 18:15'! ok self cancelled: false; delete! ! !ListDialogWindow methodsFor: 'button behavior' stamp: 'BenjaminVanRyseghem 6/26/2012 23:54'! browseAction | aString tmp block | aString := searchMorph content. (list detect: [ :item | (self displayItem: item) = aString] ifNone: [ nil ]) ifNotNilDo: [ :item| self accept: item ]. tmp := answer. block := self browseBlock. [ block value: tmp ] fork. self cancel! ! !ListDialogWindow methodsFor: 'button behavior' stamp: 'BenjaminVanRyseghem 6/26/2012 23:02'! browseBlock ^ browseBlock! ! !ListDialogWindow methodsFor: 'button behavior' stamp: 'BenjaminVanRyseghem 6/26/2012 23:02'! browseBlock: aBlock browseBlock := aBlock! ! !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: 'display' stamp: 'BenjaminVanRyseghem 6/26/2012 22:55'! displayBlock: aBlock displayBlock := aBlock! ! !ListDialogWindow methodsFor: 'display' stamp: 'BenjaminVanRyseghem 6/26/2012 22:56'! displayItem: anItem ^ self displayBlock cull: anItem cull: self! ! !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: 'events' stamp: 'BenjaminVanRyseghem 6/26/2012 22:34'! listKeystrokeDown listIndex = list size ifTrue: [ self listIndex: 0. self giveFocusToSearch. ^ true]. ^ false.! ! !ListDialogWindow methodsFor: 'events' stamp: 'BenjaminVanRyseghem 6/26/2012 22:34'! listKeystrokeUp listIndex = 1 ifTrue: [ self listIndex: 0. self giveFocusToSearch. ^ true]. ^ false.! ! !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: '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: 'events' stamp: 'BenjaminVanRyseghem 6/26/2012 22:34'! searchKeystrokeUp (searchMorph selectionInterval last == 0) ifFalse: [ ^ false ]. self listIndex: list size. self giveFocusToList. ^ true! ! !ListDialogWindow methodsFor: 'focus handling' stamp: 'CamilloBruni 8/11/2011 06:13'! defaultFocusMorph ^ searchMorph! ! !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: 'focus handling' stamp: 'BenjaminVanRyseghem 6/26/2012 22:34'! giveFocusToSearch searchMorph takeKeyboardFocus.! ! !ListDialogWindow methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/28/2012 15:57'! initialize list := #(). listIndex := 0. isResizeable := true. listBlock := [ :regex| #() ]. displayBlock := [:e | e printString ]. browseBlock := [:tmp | tmp browse ]. pattern := '.' asRegexIgnoringCase. super initialize. ! ! !ListDialogWindow methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 6/26/2012 23:39'! chooseFromOwner: aMorph ^ (aMorph openModal: self) answer! ! !ListDialogWindow methodsFor: 'item creation' stamp: 'BenjaminVanRyseghem 6/26/2012 23:01'! buildBrowseButton ^ (PluggableButtonMorph on: self getState: #state action: #browseAction) label: 'Browse'; yourself! ! !ListDialogWindow methodsFor: 'items creation' stamp: 'BenjaminVanRyseghem 6/26/2012 22:56'! buildListMorph ^ listMorph := PluggableListMorph new hResizing: #spaceFill; vResizing: #spaceFill; on: self list: #list selected: #listIndex changeSelected: #listIndex: menu: nil keystroke: nil; keystrokeSelector: #listKeystroke:; doubleClickSelector: #ok; wrapSelector: #displayItem:; yourself! ! !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: 'CamilloBruni 8/11/2011 05:32'! list ^ list! ! !ListDialogWindow methodsFor: 'morphic protocol' stamp: 'CamilloBruni 8/11/2011 05:34'! listChanged self changed: #list.! ! !ListDialogWindow methodsFor: 'morphic protocol' stamp: 'CamilloBruni 8/11/2011 08:02'! listIndex ^ listIndex ! ! !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: 'morphic protocol' stamp: 'BenjaminVanRyseghem 6/26/2012 22:59'! searchAccept: aString self searchUpdate: aString. list size = 1 ifTrue: [ ^ self accept: list first ]. (list detect: [ :item | (self displayItem: item) = aString] ifNone: [ nil]) ifNotNilDo: [ :item| ^ self accept: item ]. list ifNotEmpty: [ ^ self giveFocusToList].! ! !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: 'CamilloBruni 9/19/2011 16:34'! 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" WorldState addDeferredUIMessage: [self listChanged]] fork.! ! !ListDialogWindow methodsFor: 'open/close' stamp: 'CamilloBruni 8/11/2011 03:30'! initialExtent ^ 300 @ 400! ! !ListDialogWindow methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/26/2012 22:59'! accept: anItem self answer: anItem. self ok.! ! !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: 'private' stamp: 'CamilloBruni 8/11/2011 05:55'! no "overwrite de default"! ! !ListDialogWindow methodsFor: 'private' stamp: 'CamilloBruni 8/11/2011 05:55'! yes "overwrite de default"! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ListDialogWindow class instanceVariableNames: 'searchList'! !ListDialogWindow class methodsFor: 'accessing' stamp: 'CamilloBruni 8/11/2011 05:34'! searchList ^ searchList ifNil: [ searchList := OrderedCollection new ]! ! !ListDialogWindow class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 6/26/2012 23:40'! chooseFromOwner: aMorph ^ self new chooseFromOwner: aMorph! ! Object subclass: #ListItemWrapper instanceVariableNames: 'item model' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Explorer'! !ListItemWrapper commentStamp: '' prior: 0! Contributed by Bob Arning as part of the ObjectExplorer package. ! !ListItemWrapper methodsFor: 'accessing' stamp: 'RAA 7/21/2000 10:59'! balloonText ^nil! ! !ListItemWrapper methodsFor: 'accessing' stamp: 'RAA 3/31/1999 16:32'! contents ^Array new! ! !ListItemWrapper methodsFor: 'accessing' stamp: 'RAA 4/1/1999 20:09'! hasContents ^self contents isEmpty not! ! !ListItemWrapper methodsFor: 'accessing' stamp: 'dgd 9/26/2004 18:22'! icon "Answer a form to be used as icon" ^ nil! ! !ListItemWrapper methodsFor: 'accessing' stamp: 'gvc 8/23/2006 15:53'! item "Answer the item. It is useful!!" ^item! ! !ListItemWrapper methodsFor: 'accessing' stamp: 'MarcusDenker 2/19/2010 17:32'! item: newItem item := newItem! ! !ListItemWrapper methodsFor: 'accessing' stamp: 'gvc 10/26/2006 11:11'! model "Answer the model. It is useful!!" ^model! ! !ListItemWrapper methodsFor: 'accessing' stamp: 'AlainPlantec 12/16/2009 21:59'! preferredColor ^ nil! ! !ListItemWrapper methodsFor: 'accessing' stamp: 'RAA 3/30/1999 18:27'! setItem: anObject item := anObject! ! !ListItemWrapper methodsFor: 'accessing' stamp: 'RAA 3/31/1999 16:44'! setItem: anObject model: aModel item := anObject. model := aModel.! ! !ListItemWrapper methodsFor: 'accessing' stamp: 'IgorStasenko 4/15/2011 15:27'! theme ^ UITheme current! ! !ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 3/30/1999 18:13'! acceptDroppingObject: anotherItem ^item acceptDroppingObject: anotherItem! ! !ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 3/31/1999 12:25'! canBeDragged ^true! ! !ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 3/31/1999 16:24'! handlesMouseOver: evt ^false! ! !ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 3/31/1999 12:15'! hasEquivalentIn: aCollection aCollection detect: [ :each | each withoutListWrapper = item withoutListWrapper ] ifNone: [^false]. ^true! ! !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: 'as yet unclassified' stamp: 'RAA 3/31/1999 21:31'! settingSelector ^nil! ! !ListItemWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 3/31/1999 16:32'! wantsDroppedObject: anotherItem ^false! ! !ListItemWrapper methodsFor: 'as yet unclassified ' stamp: 'AlainPlantec 9/11/2011 05:42'! highlightingColor ^self theme currentSettings selectionTextColor! ! !ListItemWrapper methodsFor: 'converting' stamp: 'RAA 3/30/1999 18:17'! asString ^item asString! ! !ListItemWrapper methodsFor: 'converting' stamp: 'RAA 3/31/1999 12:13'! withoutListWrapper ^item withoutListWrapper! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ListItemWrapper class instanceVariableNames: ''! !ListItemWrapper class methodsFor: 'as yet unclassified' stamp: 'RAA 3/30/1999 18:28'! with: anObject ^self new setItem: anObject! ! !ListItemWrapper class methodsFor: 'as yet unclassified' stamp: 'RAA 3/31/1999 16:44'! with: anObject model: aModel ^self new setItem: anObject model: aModel! ! Object subclass: #ListModel instanceVariableNames: 'list selectionIndex' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !ListModel commentStamp: 'gvc 9/23/2008 11:31' prior: 0! Resusable model for a simple single selection list.! !ListModel methodsFor: 'accessing' stamp: 'GaryChambers 8/17/2010 16:09'! add: anItem "Add an item to the list and answer it." |answer| answer := self list add: anItem. self changed: #list. ^answer! ! !ListModel methodsFor: 'accessing' stamp: 'gvc 8/2/2007 12:14'! list "Answer the value of list" ^ list! ! !ListModel methodsFor: 'accessing' stamp: 'gvc 8/2/2007 12:14'! list: anObject "Set the value of list" list := anObject. self changed: #list! ! !ListModel methodsFor: 'accessing' stamp: 'gvc 9/23/2008 11:32'! selectedItem "Answer the currently selected item or nil if none." ^self selectionIndex = 0 ifTrue: [nil] ifFalse: [self list at: self selectionIndex]! ! !ListModel methodsFor: 'accessing' stamp: 'gvc 8/2/2007 12:14'! selectionIndex "Answer the value of selectionIndex" ^ selectionIndex! ! !ListModel methodsFor: 'accessing' stamp: 'gvc 8/2/2007 12:14'! selectionIndex: anObject "Set the value of selectionIndex" selectionIndex := anObject. self changed: #selectionIndex! ! !ListModel methodsFor: 'drag and drop' stamp: 'GaryChambers 8/8/2011 16:11'! dragItem: index "Answer the element at the given index." ^self list at: index! ! !ListModel methodsFor: 'drag and drop' stamp: 'GaryChambers 10/17/2011 13:47'! dropItem: anObject at: index "Drop an item at the given index." self list remove: anObject; add: anObject beforeIndex: index. self changed: #list; changed: #listOrder! ! !ListModel methodsFor: 'drag and drop' stamp: 'GaryChambers 8/8/2011 16:02'! dropWanted: anObject "If specified for the list, allow only things that are in the list to be dropped (reordering)." ^self list includes: anObject! ! !ListModel methodsFor: 'initialize-release' stamp: 'gvc 8/2/2007 12:14'! initialize "Initialize the receiver." super initialize. self list: #(); selectionIndex: 0! ! ComposableModel subclass: #ListSelectionModel instanceVariableNames: 'listModel textModel1 textModel2 textRefreshingProcess' classVariableNames: '' poolDictionaries: '' category: 'Spec-Examples-Widgets'! !ListSelectionModel commentStamp: '' prior: 0! A ListSelectionModel is a basic example to show multi selection on lists | l | l := ListSelectionModel new. l openWithSpec! !ListSelectionModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/9/2012 17:06'! listModel ^ listModel! ! !ListSelectionModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/9/2012 17:07'! textModel1 ^ textModel1! ! !ListSelectionModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/9/2012 17:07'! textModel2 ^ textModel2! ! !ListSelectionModel methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/12/2012 19:27'! initializePresenter listModel whenSelectionChanged: [ self updateText ]! ! !ListSelectionModel methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/12/2012 19:27'! initializeWidgets self instantiateModels: #( listModel ListComposableModel textModel1 TextModel textModel2 TextModel ). listModel beMultipleSelection. listModel items: Smalltalk allClasses.! ! !ListSelectionModel methodsFor: 'update' stamp: 'BenjaminVanRyseghem 2/9/2012 18:07'! 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: '; '). WorldState addDeferredUIMessage: [ textModel1 text: indexes. textModel2 text: items]] fork.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ListSelectionModel class instanceVariableNames: ''! !ListSelectionModel class methodsFor: 'specs' stamp: 'bvr 6/4/2012 17:19'! bottomSpec ^ {#Panel. #changeTableLayout. #listDirection:. #rightToLeft. #addMorph:. {#model. #textModel1.}. #addMorph:. {#model. #textModel2.}. #hResizing:. #spaceFill. #vResizing:. #spaceFill.}! ! !ListSelectionModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/15/2013 14:15'! defaultSpec ^{#ComposableSpec. #add:. {{ #model. #listModel.}. #layout:. {#(FrameLayout bottomFraction: 0.5).}}. #add:. {{ #model. #textModel1.}. #layout:. {#(FrameLayout topFraction: 0.5 rightFraction: 0.5). }}. #add:. {{ #model. #textModel2.}. #layout:. {#(FrameLayout leftFraction: 0.5 topFraction: 0.5) }}}.! ! AbstractSpec subclass: #ListSpec instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Spec-Core-Specs'! !ListSpec commentStamp: '' prior: 0! A ListSpec is a spec used to describe a list! !ListSpec methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/24/2012 01:21'! classSymbol ^ #List! ! Dictionary subclass: #LiteralDictionary instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Support'! !LiteralDictionary commentStamp: '' prior: 0! 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: '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"! ! !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 ! ! DictionaryTest subclass: #LiteralDictionaryTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Unordered'! !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 methodsFor: 'requirements' stamp: 'cyrille.delaunay 6/29/2009 12:57'! classToBeTested ^ LiteralDictionary! ! !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 class instanceVariableNames: ''! !LiteralDictionaryTest class methodsFor: 'building suites' stamp: 'cyrille.delaunay 6/29/2009 12:58'! shouldInheritSelectors ^true! ! LeafNode subclass: #LiteralNode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-ParseNodes'! !LiteralNode commentStamp: '' prior: 0! I am a parse tree leaf representing a literal string or number.! !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: '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: '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! ! !LiteralNode methodsFor: 'printing' stamp: 'eem 5/6/2008 14:46'! printOn: aStream indent: level key isVariableBinding ifTrue: [key key isNil ifTrue: [aStream nextPutAll: '###'; nextPutAll: key value soleInstance name] ifFalse: [aStream nextPutAll: '##'; nextPutAll: key key]] ifFalse: [key storeOn: aStream]! ! !LiteralNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! printWithClosureAnalysisOn: aStream indent: level key isVariableBinding ifTrue: [key key isNil ifTrue: [aStream nextPutAll: '###'; nextPutAll: key value soleInstance name] ifFalse: [aStream nextPutAll: '##'; nextPutAll: key key]] ifFalse: [key storeOn: aStream]! ! !LiteralNode methodsFor: 'testing'! isConstantNumber ^ key isNumber! ! !LiteralNode methodsFor: 'testing' stamp: 'di 4/5/2000 11:13'! isLiteral ^ true! ! !LiteralNode methodsFor: 'testing'! isSpecialConstant ^ code between: LdTrue and: LdMinus1+3! ! !LiteralNode methodsFor: 'testing'! literalValue ^key! ! !LiteralNode methodsFor: 'visiting' stamp: 'eem 9/6/2009 12:34'! accept: aVisitor ^aVisitor visitLiteralNode: self! ! VariableNode subclass: #LiteralVariableNode instanceVariableNames: 'writeNode' classVariableNames: '' poolDictionaries: '' category: 'Compiler-ParseNodes'! !LiteralVariableNode methodsFor: 'code generation' stamp: 'eem 5/15/2008 09:44'! emitCodeForLoad: stack encoder: encoder writeNode ifNotNil: [encoder genPushLiteral: index. stack push: 1]! ! !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: '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: 'eem 5/14/2008 18:11'! emitCodeForValue: stack encoder: encoder stack push: 1. ^encoder genPushLiteralVar: index! ! !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: 'FirstnameLastname 12/11/2009 13:21'! sizeCodeForStore: encoder self reserve: encoder. ^encoder sizeStoreLiteralVar: index ! ! !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 17:03'! sizeCodeForValue: encoder self reserve: encoder. ^encoder sizePushLiteralVar: index! ! !LiteralVariableNode methodsFor: 'visiting' stamp: 'eem 9/6/2009 12:34'! accept: aVisitor ^aVisitor visitLiteralVariableNode: self! ! CommandLineHandler subclass: #LoadUpdatesCommandLineHandler instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'UpdateStreamer-Core'! !LoadUpdatesCommandLineHandler commentStamp: '' prior: 0! Usage: update Documentation: The update the image to the latest version. ! !LoadUpdatesCommandLineHandler methodsFor: 'actions' stamp: 'MarcusDenker 2/28/2013 09:15'! loadUpdates UpdateStreamer new updateFromServer.! ! !LoadUpdatesCommandLineHandler methodsFor: 'actions' stamp: 'CamilloBruni 1/14/2013 16:12'! loadUpdatesFromFile ^ self loadUpdatesFromFile: (self optionAt: 'from-file') asFileReference ! ! !LoadUpdatesCommandLineHandler methodsFor: 'actions' stamp: 'CamilloBruni 1/14/2013 16:56'! loadUpdatesFromFile: updatesFile updatesFile exists ifFalse: [ ^ self exitFailure: (updatesFile fullName, ' does not exist!!') ]. UpdateStreamer new updateFromFile: updatesFile! ! !LoadUpdatesCommandLineHandler methodsFor: 'activation' stamp: 'CamilloBruni 1/14/2013 16:12'! activate self activateHelp ifTrue: [ ^ self ]. (self hasOption: 'from-file') ifTrue: [ self loadUpdatesFromFile ] ifFalse: [ self loadUpdates ]. Smalltalk snapshot: true andQuit: true.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! LoadUpdatesCommandLineHandler class instanceVariableNames: ''! !LoadUpdatesCommandLineHandler class methodsFor: 'accessing' stamp: 'MarcusDenker 11/7/2012 13:57'! commandName ^ 'update'! ! !LoadUpdatesCommandLineHandler class methodsFor: 'accessing' stamp: 'CamilloBruni 2/6/2013 18:16'! description ^ 'Load updates'! ! Object subclass: #Loader instanceVariableNames: '' classVariableNames: 'PackagesBeforeLastLoad' poolDictionaries: '' category: 'ScriptLoader20'! !Loader commentStamp: 'LaurentLaffont 3/4/2011 22:44' prior: 0! 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: 'accessing' stamp: 'StephaneDucasse 9/10/2010 17:34'! currentMajorVersionNumber ^ self class currentMajorVersionNumber ! ! !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:51'! currentChangedPackages "self new currentChangedPackages" ^ self currentPackages select: [:each | each needsSaving or: [ (PackagesBeforeLastLoad includes: each ancestry ancestorString) not ] ]! ! !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: '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: 'initialize' stamp: 'StephaneDucasse 9/10/2010 17:49'! initialize super initialize. PackagesBeforeLastLoad ifNil: [ PackagesBeforeLastLoad := Set new ]! ! !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 methodsFor: 'private' stamp: 'MarcusDenker 10/21/2012 11:07'! packagesNotToSavePatternNames ^ #( 'ScriptLoader*' 'SLICE*' 'Slice*' 'slice*' ).! ! !Loader methodsFor: 'private' stamp: 'StephaneDucasse 9/10/2010 17:51'! resetPackagesBeforeLastLoad PackagesBeforeLastLoad := Set new! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Loader class instanceVariableNames: ''! !Loader class methodsFor: 'private' stamp: 'StephaneDucasse 9/10/2010 17:22'! packageToBeTestedFolderName ^ 'packages-to-be-tested'! ! !Loader class methodsFor: 'private' stamp: 'CamilloBruni 5/26/2012 12:18'! waitingCacheFolder ^ self packageToBeTestedFolderName asFileReference ensureDirectory; yourself ! ! Object subclass: #Locale instanceVariableNames: 'id shortDate longDate time decimalSymbol digitGrouping currencySymbol currencyNotation measurement offsetLocalToUTC offsetVMToUTC dstActive' classVariableNames: 'Activated Current CurrentPlatform KnownLocales LanguageSymbols LocaleChangeListeners PlatformEncodings' poolDictionaries: '' category: 'System-Localization'! !Locale commentStamp: '' prior: 0! 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 8/31/2005 17:03'! determineLocale self localeID: self determineLocaleID! ! !Locale methodsFor: 'accessing' stamp: 'mir 8/31/2005 16:32'! determineLocaleID "Locale current determineLocaleID" | langCode isoLang countryCode isoCountry | langCode := self fetchISO2Language. isoLang := langCode ifNil: [^self localeID] ifNotNil: [langCode]. countryCode := self primCountry. isoCountry := countryCode ifNil: [^LocaleID isoLanguage: isoLang] ifNotNil: [countryCode]. ^LocaleID isoLanguage: isoLang isoCountry: isoCountry! ! !Locale methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:39'! isoCountry ^self localeID isoCountry! ! !Locale methodsFor: 'accessing' stamp: 'nk 8/31/2004 09:39'! isoLanguage ^self localeID isoLanguage! ! !Locale methodsFor: 'accessing' stamp: 'mir 7/15/2004 12:41'! isoLocale "-" ^self isoCountry ifNil: [self isoLanguage] ifNotNil: [self isoLanguage , '-' , self isoCountry]! ! !Locale methodsFor: 'accessing' stamp: 'mir 7/15/2004 15:52'! languageEnvironment ^LanguageEnvironment localeID: self localeID! ! !Locale methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:55'! localeID ^id! ! !Locale methodsFor: 'accessing' stamp: 'mir 7/15/2004 14:55'! localeID: anID id := anID! ! !Locale methodsFor: 'accessing' stamp: 'tak 8/4/2005 15:18'! printOn: aStream super printOn: aStream. aStream nextPutAll: '(' , id printString , ')'! ! !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: 'system primitives' stamp: 'tpr 6/1/2005 18:45'! primCurrencyNotation "Returns boolean if symbol is pre- (true) or post-fix (false)" ^true! ! !Locale methodsFor: 'system primitives' stamp: 'tpr 6/1/2005 18:47'! primCurrencySymbol "Returns string with currency symbol" ^'$'! ! !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: 'system primitives' stamp: 'tpr 6/2/2005 13:42'! primDecimalSymbol "Returns string with e.g. '.' or ','" ^'.'! ! !Locale methodsFor: 'system primitives' stamp: 'tpr 6/2/2005 13:42'! primDigitGrouping "Returns string with e.g. '.' or ',' (thousands etc)" ^','! ! !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: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: '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: '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: '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: '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: '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 class instanceVariableNames: ''! !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! ! !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: 'yo 7/28/2004 20:39'! currentPlatform: locale CurrentPlatform := locale. LanguageEnvironment startUp. ! ! !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: 'mir 7/15/2004 14:31'! isoLanguage: isoLanguage isoCountry: isoCountry ^self localeID: (LocaleID isoLanguage: isoLanguage isoCountry: isoCountry)! ! !Locale class methodsFor: 'accessing' stamp: 'mir 7/15/2004 12:42'! isoLocale: aString ! ! !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: '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: '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: 'accessing' stamp: 'mir 7/15/2004 19:07'! switchToID: localeID "Locale switchToID: (LocaleID isoLanguage: 'de') " self switchTo: (Locale localeID: localeID)! ! !Locale class methodsFor: 'initialization' stamp: 'AlainPlantec 1/5/2010 12:24'! initialize "Locale initialize" Smalltalk addToStartUpList: Locale. ! ! !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: 'initialization' stamp: 'nk 8/29/2004 13:20'! platformEncodings PlatformEncodings isEmptyOrNil ifTrue: [ self initializePlatformEncodings ]. ^PlatformEncodings ! ! !Locale class methodsFor: 'notification' stamp: 'mir 6/30/2004 16:15'! addLocalChangedListener: anObjectOrClass self localeChangedListeners add: anObjectOrClass! ! !Locale class methodsFor: 'notification' stamp: 'MarcusDenker 3/24/2011 16:36'! localeChanged! ! !Locale class methodsFor: 'notification' stamp: 'mir 6/30/2004 16:15'! localeChangedListeners ^LocaleChangeListeners ifNil: [LocaleChangeListeners := OrderedCollection new]! ! !Locale class methodsFor: 'platform specific' stamp: 'MarcusDenker 7/13/2012 14:30'! defaultEncodingName: languageSymbol | encodings platformName osVersion | platformName := OSPlatform platformName. osVersion := OSPlatform 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: 'settings' stamp: 'AlainPlantec 12/11/2009 10:59'! activated ^ Activated ifNil: [Activated := false]! ! !Locale class methodsFor: 'settings' stamp: 'AlainPlantec 12/11/2009 10:59'! activated: aBoolean Activated := aBoolean! ! !Locale class methodsFor: 'system startup' stamp: 'CamilloBruni 7/17/2012 16:11'! localTimeZone | offset abbreviation | offset := Duration minutes: self current primTimezone. abbreviation := String streamContents: [ :s | s nextPutAll: 'LT'; print: offset hours; nextPut: $:. s nextPutAll: (offset minutes printPaddedWith: $0 to: 2) ]. ^ TimeZone offset: offset name: 'Local Time' abbreviation: abbreviation! ! !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: '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: '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: 'private' stamp: 'mir 7/15/2004 16:44'! knownLocales "KnownLocales := nil" ^KnownLocales ifNil: [KnownLocales := self initKnownLocales]! ! Object subclass: #LocaleID instanceVariableNames: 'isoLanguage isoCountry' classVariableNames: '' poolDictionaries: '' category: 'System-Localization'! !LocaleID methodsFor: 'accessing' stamp: 'mir 9/1/2005 14:17'! displayCountry ^(ISOLanguageDefinition iso2Countries at: self isoCountry asUppercase ifAbsent: [ self isoCountry ]) ! ! !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: '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: 'accessing' stamp: 'mir 7/15/2004 14:34'! parent ^self class isoLanguage: self isoLanguage! ! !LocaleID methodsFor: 'accessing' stamp: 'HilaireFernandes 5/6/2010 21:30'! translator ^ NaturalLanguageTranslator localeID: self ! ! !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: 'comparing' stamp: 'mir 7/15/2004 14:23'! hash ^self isoLanguage hash bitXor: self isoCountry hash! ! !LocaleID methodsFor: 'initialize' stamp: 'mir 7/15/2004 12:44'! isoLanguage: langString isoCountry: countryStringOrNil isoLanguage := langString. isoCountry := countryStringOrNil! ! !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 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: '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: 'testing' stamp: 'mir 7/15/2004 14:34'! hasParent ^self isoCountry notNil! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! LocaleID class instanceVariableNames: ''! !LocaleID class methodsFor: 'accessing' stamp: 'mir 7/15/2004 15:09'! current ^Locale current localeID! ! !LocaleID class methodsFor: 'accessing' stamp: 'bf 9/26/2007 16:24'! previous ^Locale previous localeID! ! !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: 'mir 7/15/2004 12:46'! isoLanguage: langString isoCountry: countryStringOrNil ^self new isoLanguage: langString isoCountry: countryStringOrNil! ! !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: 'HilaireFernandes 4/30/2010 18:00'! posixName: aString ^ self isoString: (aString copyReplaceAll: '_' with: '-')! ! Object subclass: #LoggingSystemProgressItemMorph instanceVariableNames: 'start end' classVariableNames: '' poolDictionaries: '' category: 'Deprecated20'! !LoggingSystemProgressItemMorph methodsFor: 'callbacks' stamp: 'SeanDeNigris 8/30/2012 10:51'! onChange: aJob self log: start printString,' ', end printString, ' ', aJob currentValue printString.! ! !LoggingSystemProgressItemMorph methodsFor: 'callbacks' stamp: 'SeanDeNigris 8/30/2012 10:52'! onEnd: aJob self log: aJob title, ' complete'.! ! !LoggingSystemProgressItemMorph methodsFor: 'callbacks' stamp: 'SeanDeNigris 8/30/2012 10:51'! onStart: aJob self log: aJob title.! ! !LoggingSystemProgressItemMorph methodsFor: 'compatibility' stamp: 'SeanDeNigris 8/30/2012 10:50'! current: aNumber self log: start printString,' ', end printString, ' ', aNumber printString.! ! !LoggingSystemProgressItemMorph methodsFor: 'compatibility' stamp: 'SeanDeNigris 6/21/2012 00:27'! end: aNumber end := aNumber.! ! !LoggingSystemProgressItemMorph methodsFor: 'compatibility' stamp: 'SeanDeNigris 8/30/2012 10:50'! log: aString self traceCr: aString.! ! !LoggingSystemProgressItemMorph methodsFor: 'compatibility' stamp: 'SeanDeNigris 6/21/2012 00:27'! start: aNumber start := aNumber.! ! AbstractFont subclass: #LogicalFont instanceVariableNames: 'realFont emphasis familyName fallbackFamilyNames pointSize stretchValue weightValue slantValue derivatives boldDerivative italicDerivative boldItalicDerivative' classVariableNames: '' poolDictionaries: '' category: 'FreeType-FontManager'! !LogicalFont commentStamp: 'LaurentLaffont 6/8/2011 22:20' prior: 0! I describe a font.! !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: '*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: 'accessing' stamp: 'tween 3/17/2007 10:49'! clearRealFont realFont := nil! ! !LogicalFont methodsFor: 'accessing' stamp: 'tween 8/27/2007 11:18'! fallbackFamilyNames ^fallbackFamilyNames! ! !LogicalFont methodsFor: 'accessing' stamp: 'tween 8/27/2007 11:19'! fallbackFamilyNames: aSequencableCollection fallbackFamilyNames := aSequencableCollection! ! !LogicalFont methodsFor: 'accessing' stamp: 'tween 3/16/2007 16:25'! familyName ^familyName! ! !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: 'accessing' stamp: 'tween 3/16/2007 17:39'! familySizeFace "should have default in AbstractFont" ^{self familyName. self pointSize. self emphasis}! ! !LogicalFont methodsFor: 'accessing' stamp: 'tween 8/18/2007 16:32'! forceBold weightValue := (self weightValue max: 700).! ! !LogicalFont methodsFor: 'accessing' stamp: 'tween 8/18/2007 16:34'! forceItalicOrOblique self slantValue = 0 ifTrue:[slantValue := 1]! ! !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: 'accessing' stamp: 'tween 8/18/2007 21:47'! forceNotItalic "leave oblique style in place" slantValue = 1 ifTrue:[slantValue := 0].! ! !LogicalFont methodsFor: 'accessing' stamp: 'tween 3/16/2007 16:07'! pointSize ^pointSize! ! !LogicalFont methodsFor: 'accessing' stamp: 'tween 3/16/2007 13:58'! pointSize: aNumber pointSize := aNumber! ! !LogicalFont methodsFor: 'accessing' stamp: 'tween 8/18/2007 19:49'! realFont ^realFont ifNil:[realFont := self findRealFont]! ! !LogicalFont methodsFor: 'accessing' stamp: 'tween 3/16/2007 15:57'! setEmphasis: code emphasis := code! ! !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 8/17/2007 00:27'! slantValue: anObject "Set the value of slantValue" slantValue := anObject! ! !LogicalFont methodsFor: 'accessing' stamp: 'tween 8/18/2007 19:46'! stretchValue "Answer the value of stretchValue" ^ stretchValue ifNil:[stretchValue := 5]! ! !LogicalFont methodsFor: 'accessing' stamp: 'tween 8/17/2007 00:27'! stretchValue: anObject "Set the value of stretchValue" stretchValue := anObject! ! !LogicalFont methodsFor: 'accessing' stamp: 'tween 8/18/2007 19:46'! weightValue "Answer the value of weightValue" ^ weightValue ifNil:[weightValue := 400]! ! !LogicalFont methodsFor: 'accessing' stamp: 'tween 8/17/2007 00:27'! weightValue: anObject "Set the value of weightValue" weightValue := anObject! ! !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: '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: '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: 'derivatives' stamp: 'tween 3/16/2007 17:43'! derivativeFont: newFont mainFont: ignore self derivativeFont: newFont! ! !LogicalFont methodsFor: 'derivatives' stamp: 'tween 3/16/2007 15:46'! derivativeFonts derivatives ifNil: [^ #()]. ^derivatives copyWithout: nil! ! !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: '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: 'emphasis' stamp: 'tween 9/22/2007 12:41'! emphasis: code ^self emphasized: code! ! !LogicalFont methodsFor: 'emphasis' stamp: 'tween 3/16/2007 15:59'! emphasisString ^AbstractFont emphasisStringFor: emphasis! ! !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: '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:02'! baseKern ^self realFont baseKern! ! !LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 4/5/2007 08:30'! characterFormAt: aCharacter ^self realFont characterFormAt: aCharacter! ! !LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/16/2007 13:38'! descent ^self realFont descent! ! !LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/16/2007 14:02'! descentKern ^self realFont descentKern! ! !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/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: '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: '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: '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/29/2007 13:43'! hasDistinctGlyphsForAll: asciiString ^self realFont hasDistinctGlyphsForAll: asciiString! ! !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 3/16/2007 13:33'! height ^self realFont height! ! !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: '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/29/2007 14:04'! isSymbolFont ^self realFont isSymbolFont! ! !LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/16/2007 13:38'! isTTCFont ^self realFont isTTCFont! ! !LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/21/2007 09:16'! kerningLeft: leftChar right: rightChar ^self realFont kerningLeft: leftChar right: rightChar! ! !LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/31/2007 17:13'! linearWidthOf: aCharacter ^self realFont linearWidthOf: aCharacter! ! !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: 'forwarded to realFont' stamp: 'tween 3/16/2007 14:03'! widthOf: anObject ^self realFont widthOf: anObject! ! !LogicalFont methodsFor: 'forwarded to realFont' stamp: 'tween 3/28/2007 14:56'! widthOfString: aString ^self realFont widthOfString: aString! ! !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: 'forwarded to realFont' stamp: 'tween 3/16/2007 14:03'! xTable ^self realFont xTable! ! !LogicalFont methodsFor: 'initialize-release' stamp: 'tween 3/16/2007 17:42'! initialize: aFont familyName := aFont familyName. emphasis := aFont emphasis.! ! !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: '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: 'testing' stamp: 'tween 9/29/2007 10:56'! isBold ^self isBoldOrBolder! ! !LogicalFont methodsFor: 'testing' stamp: 'tween 9/29/2007 10:48'! isBoldOrBolder ^(weightValue ifNil:[400]) >= 700! ! !LogicalFont methodsFor: 'testing' stamp: 'tween 9/29/2007 10:57'! isItalic ^self isItalicOrOblique! ! !LogicalFont methodsFor: 'testing' stamp: 'tween 9/29/2007 10:47'! isItalicOrOblique slantValue ifNil:[slantValue := 0]. ^slantValue = 1 or:[slantValue = 2]! ! !LogicalFont methodsFor: 'testing' stamp: 'tween 3/16/2007 15:48'! isRegular ^emphasis = 0! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! LogicalFont class instanceVariableNames: 'all'! !LogicalFont class methodsFor: 'accessing' stamp: 'tween 8/11/2007 01:22'! all ^all ifNil:[ all := WeakSet new addAll: self allInstances; yourself]! ! !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:59'! slantBackslanted ^2! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:58'! slantBook ^0! ! !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: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:00'! slantKursiv ^1! ! !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:59'! slantOblique ^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:59'! slantSlanted ^2! ! !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 12:41'! squeakStretchCondensed ^8! ! !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:55'! stretchCompact ^4! ! !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:56'! stretchCondensed ^3! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:56'! stretchExpanded ^7! ! !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:53'! stretchExtraCompressed ^1! ! !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:55'! stretchExtraExpanded ^8! ! !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:54'! stretchNarrow ^4! ! !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:55'! stretchSemiCondensed ^4! ! !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:53'! stretchUltraCompressed ^1! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:53'! stretchUltraCondensed ^1! ! !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:56'! stretchUltraExtended ^9! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:55'! stretchWide ^6! ! !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:51'! weightBold ^700! ! !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:51'! weightExtraBlack ^950! ! !LogicalFont class methodsFor: 'emphasis values' stamp: 'tween 9/29/2007 11:50'! weightExtraBold ^800! ! !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:49'! weightExtraThin ^100! ! !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:52'! weightLight ^300! ! !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:52'! weightNord ^900! ! !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:50'! weightSemiBold ^600! ! !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:53'! weightUltra ^800! ! !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:50'! weightUltraBold ^800! ! !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:49'! weightUltraThin ^100! ! !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: '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: '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: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: 'instance creation' stamp: 'tween 8/11/2007 01:23'! new ^self all add: super new! ! !LogicalFont class methodsFor: 'shutdown' stamp: 'tween 4/3/2007 16:19'! shutDown: quitting self allSubInstances do: [:i | i clearRealFont].! ! Object subclass: #LogicalFontManager instanceVariableNames: 'fontProviders' classVariableNames: '' poolDictionaries: 'TextConstants' category: 'FreeType-FontManager'! !LogicalFontManager commentStamp: 'LaurentLaffont 6/8/2011 22:20' prior: 0! 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 families' stamp: 'nice 1/5/2010 15:59'! 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 detect:[:fontFamily | fontFamily familyName = textStyleFamilyName] ifNone:[]) notNil]. answer addAll: textStyleFamilies. ^(answer asSortedCollection: [:a :b | a familyName <= b familyName]) asArray. ! ! !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: 'initialize-release' stamp: 'tween 3/14/2007 22:56'! initialize super initialize. fontProviders := OrderedCollection new: 10 ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! LogicalFontManager class instanceVariableNames: 'current'! !LogicalFontManager class methodsFor: 'accessing' stamp: 'tween 3/17/2007 13:53'! current " current := nil. self current " ^current ifNil:[current := self defaultCurrent]! ! !LogicalFontManager class methodsFor: 'accessing' stamp: 'AlainPlantec 9/17/2011 16:52'! unload current ifNotNil: [current initialize]. current := nil. ! ! !LogicalFontManager class methodsFor: 'instance creation' stamp: 'tween 9/8/2007 14:45'! defaultCurrent ^self new addFontProvider: FreeTypeFontProvider current; yourself! ! ProtocolClientError subclass: #LoginFailedException instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Network-Protocols'! !LoginFailedException commentStamp: 'mir 5/12/2003 17:57' prior: 0! 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! ! MessageDialogWindow subclass: #LongMessageDialogWindow instanceVariableNames: 'entryText' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Windows'! !LongMessageDialogWindow commentStamp: 'gvc 9/23/2008 11:36' prior: 0! 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:11'! entryText "Answer the value of entryText" ^ entryText! ! !LongMessageDialogWindow methodsFor: 'accessing' stamp: 'gvc 4/15/2008 22:50'! entryText: anObject "Set the value of entryText" entryText := anObject. self changed: #entryText! ! !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: '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: '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! ! TestCase subclass: #LongTestCase instanceVariableNames: '' classVariableNames: 'RunLongTestCases' poolDictionaries: '' category: 'SUnit-Core-Extensions'! !LongTestCase commentStamp: 'DamirLaurent 5/2/2011 22:17' prior: 0! 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 instanceVariableNames: ''! !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: 'accessing' stamp: 'StephaneDucasse 10/18/2010 12:21'! runLongTestCases "Tell the system that long tests should be run" self shouldRun: true.! ! !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: 'accessing' stamp: 'StephaneDucasse 10/18/2010 12:21'! shouldRun: aBoolean "Set whether long tests should be run or not" RunLongTestCases := aBoolean! ! !LongTestCase class methodsFor: 'initialization' stamp: 'DamirLaurent 5/2/2011 21:32'! initialize self runLongTestCases! ! !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: '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: '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 ! ! TestCase subclass: #LongTestCaseTest instanceVariableNames: 'longTestCaseSettingValue' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Core-Extensions'! !LongTestCaseTest methodsFor: 'setup' stamp: 'StephaneDucasse 10/18/2010 12:19'! setUp longTestCaseSettingValue := LongTestCase shouldRun! ! !LongTestCaseTest methodsFor: 'setup' stamp: 'StephaneDucasse 10/18/2010 12:20'! tearDown LongTestCase shouldRun: longTestCaseSettingValue! ! !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: '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. ! ! LongTestCase subclass: #LongTestCaseTestUnderTest instanceVariableNames: '' classVariableNames: 'RunStatus' poolDictionaries: '' category: 'SUnit-Core-Extensions'! !LongTestCaseTestUnderTest methodsFor: 'testing' stamp: 'md 11/14/2004 21:30'! testWhenRunMarkTestedToTrue RunStatus := true.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! LongTestCaseTestUnderTest class instanceVariableNames: ''! !LongTestCaseTestUnderTest class methodsFor: 'accessing' stamp: 'sd 9/25/2004 14:02'! hasRun ^ RunStatus! ! !LongTestCaseTestUnderTest class methodsFor: 'accessing' stamp: 'md 11/14/2004 21:37'! markAsNotRun ^ RunStatus := false! ! Magnitude subclass: #LookupKey instanceVariableNames: 'key' classVariableNames: '' poolDictionaries: '' category: 'Collections-Support'! !LookupKey commentStamp: '' prior: 0! 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: 'ajh 9/12/2002 12:04'! canAssign ^ true! ! !LookupKey methodsFor: 'accessing'! key "Answer the lookup key of the receiver." ^key! ! !LookupKey methodsFor: 'accessing'! key: anObject "Store the argument, anObject, as the lookup key of the receiver." key := anObject! ! !LookupKey methodsFor: 'accessing' stamp: 'ajh 3/24/2003 21:14'! name ^ self key isString ifTrue: [self key] ifFalse: [self key printString]! ! !LookupKey methodsFor: 'comparing'! < aLookupKey "Refer to the comment in Magnitude|<." ^key < aLookupKey key! ! !LookupKey methodsFor: 'comparing'! = aLookupKey self species = aLookupKey species ifTrue: [^key = aLookupKey key] ifFalse: [^false]! ! !LookupKey methodsFor: 'comparing'! hash "Hash is reimplemented because = is implemented." ^key hash! ! !LookupKey methodsFor: 'printing'! 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: 'testing' stamp: 'ar 8/14/2001 22:39'! isVariableBinding "Return true if I represent a literal variable binding" ^true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! LookupKey class instanceVariableNames: ''! !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! ! MCPatchOperation subclass: #MCAddition instanceVariableNames: 'definition' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Patching'! !MCAddition commentStamp: '' prior: 0! A MCAddition represents the operation to add an entity to a snapshot. ! !MCAddition methodsFor: 'accessing' stamp: 'ab 6/1/2003 13:09'! baseDefinition ^ nil! ! !MCAddition methodsFor: 'accessing' stamp: 'StephaneDucasse 6/24/2011 14:53'! basicApplyTo: anObject anObject addDefinition: definition! ! !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: 'ab 8/22/2003 02:26'! inverse ^ MCRemoval of: definition! ! !MCAddition methodsFor: 'accessing' stamp: 'nk 2/23/2005 18:39'! sourceString ^(self toSource asText) addAttribute: TextColor red; yourself! ! !MCAddition methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/28/2011 15:25'! summary ^ definition summary! ! !MCAddition methodsFor: 'accessing' stamp: 'nk 2/23/2005 18:17'! targetClass ^definition actualClass ! ! !MCAddition methodsFor: 'accessing' stamp: 'ab 6/1/2003 13:09'! targetDefinition ^ definition! ! !MCAddition methodsFor: 'accessing' stamp: 'ab 7/18/2003 16:45'! toSource ^ definition source! ! !MCAddition methodsFor: 'initializing' stamp: 'stephaneducasse 2/4/2006 20:47'! intializeWithDefinition: aDefinition definition := aDefinition! ! !MCAddition methodsFor: 'testing' stamp: 'cwp 11/28/2002 07:22'! isAddition ^ true! ! !MCAddition methodsFor: 'testing' stamp: 'nk 2/25/2005 17:28'! isClassPatch ^definition isClassDefinition! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCAddition class instanceVariableNames: ''! !MCAddition class methodsFor: 'as yet unclassified' stamp: 'cwp 11/27/2002 10:03'! of: aDefinition ^ self new intializeWithDefinition: aDefinition! ! Object subclass: #MCAncestry instanceVariableNames: 'ancestors stepChildren' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Versioning'! !MCAncestry commentStamp: '' prior: 0! Abstract superclass of records of ancestry.! !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: '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'! ancestorString ^ String streamContents: [:s | self ancestors do: [:ea | s nextPutAll: ea name] separatedBy: [s nextPutAll: ', ']]! ! !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: 'ancestry' stamp: 'avi 2/12/2004 20:57'! ancestors ^ ancestors ifNil: [#()]! ! !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/17/2005 16:03'! breadthFirstAncestors ^ Array streamContents: [:s | self breadthFirstAncestorsDo: [:ea | s nextPut: ea]]! ! !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: '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: '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: '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: [#()]! ! !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: '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 9/17/2005 16:03'! withBreadthFirstAncestors ^ (Array with: self), self breadthFirstAncestors! ! !MCAncestry methodsFor: 'initializing' stamp: 'alain.plantec 5/28/2009 10:02'! initialize super initialize. ancestors := #(). stepChildren := #()! ! MCTestCase subclass: #MCAncestryTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Monticello'! !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: '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! ! !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: 'building' stamp: 'jf 8/16/2003 22:55'! twoPersonTree ^ self treeFrom: #(c1 ((a4 ((a1) (b3 ((b2 ((a1))))))) (b5 ((b2 ((a1)))))))! ! !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: '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: '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: '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! ! MCDirectoryRepository subclass: #MCCacheRepository instanceVariableNames: 'packageCaches seenFiles cacheEnabled' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Repositories'! !MCCacheRepository methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! cacheForPackage: aPackage packageCaches ifNil: [packageCaches := Dictionary new]. ^ packageCaches at: aPackage ifAbsentPut: [MCPackageCache new]! ! !MCCacheRepository methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 2/28/2012 20:10'! loadVersionFromFileNamed: aString ^ self versionReaderForFileNamed: aString do: [:r | r version]! ! !MCCacheRepository methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 18:15'! newFileNames ^ self allFileNames difference: self seenFileNames! ! !MCCacheRepository methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 15:13'! packageForFileNamed: aString ^ self packageCache at: aString ifAbsentPut: [self versionReaderForFileNamed: aString do: [:r | r package]]! ! !MCCacheRepository methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! seenFileNames ^ seenFiles ifNil: [seenFiles := OrderedCollection new]! ! !MCCacheRepository methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 7/6/2012 16:59'! storeVersion: aVersion cacheEnabled == true ifFalse: [ ^ self ]. (self includesFileNamed: aVersion fileName) ifTrue: [ ^ self ]. ^ super storeVersion: aVersion.! ! !MCCacheRepository methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 7/6/2012 16:13'! versionInfoForFileNamed: aString ^ self infoCache at: aString ifAbsentPut: [ self versionReaderForFileNamed: aString do: [:r | r info]]! ! !MCCacheRepository methodsFor: 'as yet unclassified' 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: 'initialize-release' stamp: 'CamilloBruni 7/6/2012 16:20'! initialize cacheEnabled := true. super initialize.! ! !MCCacheRepository methodsFor: 'utility' stamp: 'CamilloBruni 7/6/2012 16:20'! disable cacheEnabled := false.! ! !MCCacheRepository methodsFor: 'utility' stamp: 'CamilloBruni 7/6/2012 16:20'! disableCacheDuring: aBlock self disable. aBlock ensure: [ self enable ].! ! !MCCacheRepository methodsFor: 'utility' stamp: 'CamilloBruni 7/6/2012 16:20'! enable cacheEnabled := true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCCacheRepository class instanceVariableNames: 'default'! !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' stamp: 'avi 10/9/2003 12:56'! description ^ nil! ! !MCCacheRepository class methodsFor: 'accessing' stamp: 'SeanDeNigris 7/17/2012 15:38'! uniqueInstance self resetIfInvalid. ^ default ifNil: [default := self new directory: self defaultDirectory]! ! !MCCacheRepository class methodsFor: 'accessing settings' stamp: 'SeanDeNigris 7/17/2012 15:34'! cacheDirectory ^self uniqueInstance directory asAbsolute ! ! !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: 'defaults' stamp: 'SeanDeNigris 7/17/2012 15:38'! defaultDirectory ^ 'package-cache' asFileReference ensureDirectory; yourself! ! !MCCacheRepository class methodsFor: 'initialize-release' stamp: 'SeanDeNigris 7/17/2012 15:36'! initialize self resetIfInvalid! ! !MCCacheRepository class methodsFor: 'utility' stamp: 'SeanDeNigris 7/17/2012 15:34'! disableCacheDuring: aBlock self uniqueInstance disableCacheDuring: aBlock! ! !MCCacheRepository class methodsFor: 'private' stamp: 'SeanDeNigris 7/17/2012 15:36'! resetIfInvalid "Reset if invalid" default notNil and: [default directory exists ifFalse: [default := nil]]! ! MCTestCase subclass: #MCChangeNotificationTest instanceVariableNames: 'workingCopy' classVariableNames: '' poolDictionaries: '' category: 'Tests-Monticello'! !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. ! ! !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: 'running' stamp: 'GuillermoPolito 8/24/2012 14:26'! tearDown "workingCopy unregister"! ! !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: '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: '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: 'private' stamp: 'bf 5/20/2005 16:19'! foreignMethod "see testForeignMethodModified"! ! Notification subclass: #MCChangeSelectionRequest instanceVariableNames: 'patch label' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Versioning'! !MCChangeSelectionRequest methodsFor: '*MonticelloGUI' stamp: 'avi 9/14/2004 15:01'! defaultAction ^ (MCChangeSelector new patch: patch; label: label) showModally! ! !MCChangeSelectionRequest methodsFor: 'as yet unclassified' stamp: 'avi 9/14/2004 15:02'! label ^ label! ! !MCChangeSelectionRequest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! label: aString label := aString! ! !MCChangeSelectionRequest methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 15:12'! patch ^ patch! ! !MCChangeSelectionRequest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! patch: aPatch patch := aPatch! ! MCPatchBrowser subclass: #MCChangeSelector instanceVariableNames: 'kept' classVariableNames: '' poolDictionaries: '' category: 'MonticelloGUI'! !MCChangeSelector methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 16:07'! buttonSpecs ^ #((Select select 'Select these changes') (Cancel cancel 'Cancel the operation') )! ! !MCChangeSelector methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 16:26'! cancel self answer: nil! ! !MCChangeSelector methodsFor: 'as yet unclassified' stamp: 'avi 9/14/2004 15:01'! defaultLabel ^ 'Change Selector'! ! !MCChangeSelector methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 16:13'! innerButtonRow ^ self buttonRow: #(('Select All' selectAll 'select all changes') ('Select None' selectNone 'select no changes'))! ! !MCChangeSelector methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! kept ^ kept ifNil: [kept := Set new]! ! !MCChangeSelector methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 16:22'! listSelectionAt: aNumber ^ self kept includes: (self items at: aNumber)! ! !MCChangeSelector methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'avi 9/11/2004 16:26'! select self answer: (MCPatch operations: kept)! ! !MCChangeSelector methodsFor: 'as yet unclassified' stamp: 'avi 9/14/2004 15:00'! selectAll kept addAll: self items. self changed: #list! ! !MCChangeSelector methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! selectNone kept := Set new. self changed: #list! ! !MCChangeSelector methodsFor: 'as yet unclassified ' stamp: 'AlainPlantec 12/1/2009 21:46'! widgetSpecs MCCodeTool showAnnotationPane ifFalse: [ ^#( ((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)) )]. ^ #( ((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: annotations) (0 0.4 1 0.4) (0 30 0 60)) ((textMorph: text) (0 0.4 1 1) (0 60 0 0)) )! ! MCDefinition subclass: #MCClassDefinition instanceVariableNames: 'name superclassName variables category type comment commentStamp traitComposition classTraitComposition' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Modeling'! !MCClassDefinition commentStamp: '' prior: 0! A MCClassDefinition represents a class.! !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 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: '*Ring-Monticello' stamp: 'VeronicaUquillas 7/14/2011 11:12'! asRingDefinition | ring | ring:= (RGFactory current createClassNamed: self className) category: self category; superclassName: self superclassName; traitCompositionSource: self traitCompositionString; addInstanceVariables: self instVarNames; addClassVariables: self classVarNames; addPoolDictionaries: 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: 'accessing' stamp: 'lr 3/14/2010 21:13'! actualClass ^ Smalltalk globals classNamed: self className! ! !MCClassDefinition methodsFor: 'accessing' stamp: 'cwp 11/24/2002 06:23'! category ^ category! ! !MCClassDefinition methodsFor: 'accessing' stamp: 'cwp 7/7/2003 23:32'! classInstVarNames ^ self selectVariables: #isClassInstanceVariable! ! !MCClassDefinition methodsFor: 'accessing' stamp: 'ab 11/13/2002 01:52'! className ^ name! ! !MCClassDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 20:07'! classTraitComposition ^classTraitComposition! ! !MCClassDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 21:55'! classTraitCompositionString ^self classTraitComposition ifNil: ['{}'].! ! !MCClassDefinition methodsFor: 'accessing' stamp: 'nice 10/20/2009 22:03'! classVarNames ^(self selectVariables: #isClassVariable) asArray sort! ! !MCClassDefinition methodsFor: 'accessing' stamp: 'ab 1/15/2003 13:42'! comment ^ comment! ! !MCClassDefinition methodsFor: 'accessing' stamp: 'cwp 8/10/2003 16:40'! commentStamp ^ commentStamp! ! !MCClassDefinition methodsFor: 'accessing' stamp: 'ab 12/5/2002 21:24'! description ^ Array with: name ! ! !MCClassDefinition methodsFor: 'accessing' stamp: 'cwp 7/7/2003 23:33'! instVarNames ^ self selectVariables: #isInstanceVariable! ! !MCClassDefinition methodsFor: 'accessing' stamp: 'cwp 7/7/2003 23:53'! poolDictionaries ^ self selectVariables: #isPoolImport! ! !MCClassDefinition methodsFor: 'accessing' stamp: 'cwp 7/7/2003 23:28'! selectVariables: aSelector ^ variables select: [:v | v perform: aSelector] thenCollect: [:v | v name]! ! !MCClassDefinition methodsFor: 'accessing' stamp: 'ab 7/19/2003 18:00'! sortKey ^ self className! ! !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: 'accessing' stamp: 'ab 11/13/2002 17:41'! superclassName ^ superclassName! ! !MCClassDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 20:16'! traitComposition ^traitComposition! ! !MCClassDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 21:55'! traitCompositionString ^self traitComposition ifNil: ['{}'].! ! !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: '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: '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: 'comparing' stamp: 'ab 5/24/2003 14:12'! provisions ^ Array with: name! ! !MCClassDefinition methodsFor: 'comparing' stamp: 'StephaneDucasse 2/11/2012 09:14'! requirements ^superclassName == #nil ifTrue: [self poolDictionaries] ifFalse: [(Array with: superclassName), self poolDictionaries]! ! !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: '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: '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: '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: 'installing' stamp: 'MartinDias 1/14/2013 15:56'! createClass | superClass class composition | superClass := superclassName == #nil ifFalse: [ Smalltalk globals at: superclassName ]. [ class := ClassBuilder new 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 evaluatorClass 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 evaluatorClass 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: '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: '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: 'installing' stamp: 'NicoPaez 10/1/2010 10:21'! unload Smalltalk globals removeClassNamed: name! ! !MCClassDefinition methodsFor: 'printing' stamp: 'cwp 7/7/2003 23:35'! classInstanceVariablesString ^ self stringForVariablesOfType: #isClassInstanceVariable! ! !MCClassDefinition methodsFor: 'printing' stamp: 'eem 4/30/2009 16:47'! classVariablesString ^ self stringForSortedVariablesOfType: #isClassVariable! ! !MCClassDefinition methodsFor: 'printing' stamp: 'cwp 8/2/2003 02:03'! definitionString ^ String streamContents: [:stream | self printDefinitionOn: stream]! ! !MCClassDefinition methodsFor: 'printing' stamp: 'cwp 7/7/2003 23:35'! instanceVariablesString ^ self stringForVariablesOfType: #isInstanceVariable! ! !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: '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: '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: 'printing' stamp: 'eem 4/30/2009 16:47'! sharedPoolsString ^ self stringForSortedVariablesOfType: #isPoolImport! ! !MCClassDefinition methodsFor: 'printing' stamp: 'cwp 7/10/2003 01:29'! source ^ self definitionString! ! !MCClassDefinition methodsFor: 'printing' stamp: 'ab 11/16/2002 17:33'! summary ^ name! ! !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: 'testing' stamp: 'cwp 8/2/2003 02:54'! hasClassInstanceVariables ^ (self selectVariables: #isClassInstanceVariable) isEmpty not! ! !MCClassDefinition methodsFor: 'testing' stamp: 'al 10/9/2005 21:59'! hasClassTraitComposition ^self classTraitCompositionString ~= '{}'! ! !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: 'testing' stamp: 'ab 5/24/2003 13:49'! isCodeDefinition ^ true! ! !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: 'visiting' 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 class instanceVariableNames: ''! !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: '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)! ! !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: '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: '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 ! ! MCTestCase subclass: #MCClassDefinitionTest instanceVariableNames: 'previousChangeSet' classVariableNames: '' poolDictionaries: '' category: 'Tests-Monticello'! !MCClassDefinitionTest methodsFor: 'running' stamp: 'Alexandre Bergel 5/22/2010 11:23'! setUp Smalltalk globals at: #MCMockClassC ifPresent: [ :c | c removeFromSystem ]! ! !MCClassDefinitionTest methodsFor: 'running' stamp: 'Alexandre Bergel 5/22/2010 11:23'! tearDown 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: '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: '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: 'stephaneducasse 2/4/2006 20:47'! testDefinitionString | d | d := self mockClassA asClassDefinition. self assert: d definitionString = self mockClassA definition.! ! !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: '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: '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: '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 methodsFor: 'tests' stamp: 'StephaneDucasse 5/27/2010 19:58'! 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: '{TPureBehavior}' classTraitComposition: '{}' category: self mockCategoryName instVarNames: #() classVarNames: #() poolDictionaryNames: #() classInstVarNames: #() type: #normal comment: (self commentForClass: className) commentStamp: (self commentStampForClass: className). self shouldnt: [d load] raise: Error. self assert: (Smalltalk hasClassNamed: 'MCMockClassC'). cls := Smalltalk at: #MCMockClassC. self assert: (cls methodDict includesKey: #>>). self assert: ((Smalltalk at: #MCMockClassC) traitComposition allTraits includes: TPureBehavior).! ! !MCClassDefinitionTest methodsFor: 'tests' stamp: 'StephaneDucasse 5/27/2010 19:59'! 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: 'TPureBehavior' classTraitComposition: '{}' category: self mockCategoryName instVarNames: #() classVarNames: #() poolDictionaryNames: #() classInstVarNames: #() type: #normal comment: (self commentForClass: className) commentStamp: (self commentStampForClass: className). self shouldnt: [d load] raise: Error. self assert: (Smalltalk hasClassNamed: 'MCMockClassC'). cls := Smalltalk at: #MCMockClassC. self assert: (cls methodDict includesKey: #>>). self assert: ((Smalltalk at: #MCMockClassC) traitComposition allTraits includes: TPureBehavior).! ! !MCClassDefinitionTest methodsFor: 'tests' stamp: 'StephaneDucasse 5/27/2010 19:59'! 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: 'TPureBehavior + TClassAndTraitDescription' classTraitComposition: '{}' category: self mockCategoryName instVarNames: #() classVarNames: #() poolDictionaryNames: #() classInstVarNames: #() type: #normal comment: (self commentForClass: className) commentStamp: (self commentStampForClass: className). self shouldnt: [d load] raise: Error. self assert: (Smalltalk hasClassNamed: 'MCMockClassC'). cls := Smalltalk at: #MCMockClassC. self assert: (cls methodDict includesKey: #>>). self assert: (cls methodDict includesKey: #comment). self assert: ((Smalltalk at: #MCMockClassC) traitComposition allTraits includes: TPureBehavior). self assert: ((Smalltalk at: #MCMockClassC) traitComposition allTraits includes: TClassAndTraitDescription).! ! !MCClassDefinitionTest methodsFor: 'tests' stamp: 'Alexandre Bergel 6/29/2010 15:51'! 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: 'TPureBehavior - {#>> . #withAllSubclassesDo:}' classTraitComposition: '{}' category: self mockCategoryName instVarNames: #() classVarNames: #() poolDictionaryNames: #() classInstVarNames: #() type: #normal comment: (self commentForClass: className) commentStamp: (self commentStampForClass: className). self shouldnt: [d load] raise: Error. self assert: (Smalltalk hasClassNamed: 'MCMockClassC'). cls := Smalltalk at: #MCMockClassC. self assert: (cls selectors includesAllOf: {#withAllSuperclasses . #traits}). self deny: (cls selectors includesAnyOf: {#>> . #withAllSubclassesDo:}).! ! !MCClassDefinitionTest methodsFor: 'private' stamp: 'cwp 8/10/2003 01:20'! classAComment ^ self class classAComment! ! !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 class instanceVariableNames: ''! !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.'! ! !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: 'lr 3/14/2010 21:13'! restoreClassAComment Smalltalk globals at: #MCMockClassA ifPresent: [ :a | a classComment: self classAComment stamp: self classACommentStamp ]! ! MCVariableDefinition subclass: #MCClassInstanceVariableDefinition instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Modeling'! !MCClassInstanceVariableDefinition commentStamp: '' prior: 0! A MCClassInstanceVariableDefinition represents a class instance variable.! !MCClassInstanceVariableDefinition methodsFor: 'testing' stamp: 'cwp 7/7/2003 23:31'! isClassInstanceVariable ^ true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCClassInstanceVariableDefinition class instanceVariableNames: ''! !MCClassInstanceVariableDefinition class methodsFor: 'as yet unclassified' stamp: 'cwp 7/7/2003 22:59'! type ^ #classInstance! ! MCDefinition subclass: #MCClassTraitDefinition instanceVariableNames: 'baseTrait classTraitComposition category' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Modeling'! !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: '*Ring-Monticello' stamp: 'VeronicaUquillas 7/20/2011 15:56'! classDefinitionString ^self definitionString! ! !MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 20:23'! baseTrait ^baseTrait ! ! !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: 'accessing' stamp: 'al 12/15/2005 11:31'! className ^self baseTrait! ! !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: 'accessing' stamp: 'al 10/9/2005 21:59'! definitionString ^self baseTrait , ' classTrait uses: ' , self classTraitCompositionString. ! ! !MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 20:24'! description ^Array with: baseTrait with: classTraitComposition! ! !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'! requirements ^Array with: baseTrait! ! !MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 20:25'! sortKey ^ self baseTrait name , '.classTrait'! ! !MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 20:25'! source ^self definitionString! ! !MCClassTraitDefinition methodsFor: 'accessing' stamp: 'al 10/9/2005 20:25'! summary ^self baseTrait , ' classTrait' ! ! !MCClassTraitDefinition methodsFor: 'accessing' stamp: 'nice 10/31/2009 13:11'! = aDefinition ^ (super = aDefinition) and: [baseTrait = aDefinition baseTrait and: [self classTraitCompositionString = aDefinition classTraitCompositionString]] ! ! !MCClassTraitDefinition methodsFor: 'as yet unclassified' stamp: 'al 10/9/2005 20:23'! accept: aVisitor ^ aVisitor visitClassTraitDefinition: self.! ! !MCClassTraitDefinition methodsFor: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:47'! initializeWithBaseTraitName: aTraitName classTraitComposition: aString baseTrait := aTraitName. classTraitComposition := aString.! ! !MCClassTraitDefinition methodsFor: 'initialization' stamp: 'damiencassou 7/30/2009 12:12'! initializeWithBaseTraitName: aTraitName classTraitComposition: aString category: aCategoryString baseTrait := aTraitName. classTraitComposition := aString. category := aCategoryString! ! !MCClassTraitDefinition methodsFor: 'installing' stamp: 'jb 7/1/2011 10:52'! load self class evaluatorClass evaluate: self definitionString! ! !MCClassTraitDefinition methodsFor: 'testing' stamp: 'adrian-lienhard 5/11/2009 16:47'! isClassDefinition "Traits are treated the same like classes." ^ true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCClassTraitDefinition class instanceVariableNames: ''! !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).! ! MCDoItParser subclass: #MCClassTraitParser instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Chunk Format'! !MCClassTraitParser commentStamp: '' prior: 0! MCClassTraitParser identifies classTrait. ! !MCClassTraitParser methodsFor: 'actions' stamp: 'SvenVanCaekenberghe 1/8/2012 14:45'! addDefinitionsTo: aCollection | tokens definition traitCompositionString | tokens := Scanner new scanTokens: source. traitCompositionString := (source readStream match: 'uses:'; upToEnd) trimBoth. definition := MCClassTraitDefinition baseTraitName: (tokens at: 1) classTraitComposition: traitCompositionString. aCollection add: definition ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCClassTraitParser class instanceVariableNames: ''! !MCClassTraitParser class methodsFor: 'factory identification hook' stamp: 'al 10/9/2005 20:43'! pattern ^ '*classTrait*uses:*'! ! MCVariableDefinition subclass: #MCClassVariableDefinition instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Modeling'! !MCClassVariableDefinition commentStamp: '' prior: 0! 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 instanceVariableNames: ''! !MCClassVariableDefinition class methodsFor: 'as yet unclassified' stamp: 'cwp 7/7/2003 22:58'! type ^ #class! ! MCTool subclass: #MCCodeTool instanceVariableNames: 'items' classVariableNames: 'ShowAnnotationPane' poolDictionaries: '' category: 'MonticelloGUI'! !MCCodeTool commentStamp: 'nk 11/10/2003 22:00' prior: 0! 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: '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: '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: 'nk 11/10/2003 20:54'! 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 browseAllCallsOn: (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: '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: '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: '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! ! !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: 'subclassresponsibility' stamp: 'nk 11/10/2003 22:01'! annotations "Build an annotations string for the various browsers" ^''! ! !MCCodeTool methodsFor: 'subclassresponsibility' stamp: 'nk 11/10/2003 22:02'! selectedClass "Answer the class 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'! 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'! selectedMessageName "Answer the name of the selected message" self subclassResponsibility! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCCodeTool class instanceVariableNames: ''! !MCCodeTool class methodsFor: 'settings' stamp: 'AlainPlantec 12/1/2009 21:42'! showAnnotationPane ^ ShowAnnotationPane ifNil: [ShowAnnotationPane := false]! ! !MCCodeTool class methodsFor: 'settings' stamp: 'AlainPlantec 12/1/2009 21:43'! showAnnotationPane: aBoolean ShowAnnotationPane := aBoolean! ! Object subclass: #MCConfiguration instanceVariableNames: 'name dependencies repositories log' classVariableNames: 'DefaultLog UpgradeIsMerge' poolDictionaries: '' category: 'MonticelloConfigurations'! !MCConfiguration commentStamp: 'StephaneDucasse 11/29/2011 22:23' prior: 0! 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: '*MonticelloGUI' stamp: 'BenjaminVanRyseghem 2/8/2012 17:09'! browse ^ (MCConfigurationBrowser new configuration: self) show! ! !MCConfiguration methodsFor: 'accessing' stamp: 'bf 3/21/2005 16:32'! dependencies ^dependencies ifNil: [dependencies := OrderedCollection new]! ! !MCConfiguration methodsFor: 'accessing' stamp: 'bf 3/21/2005 18:40'! dependencies: aCollection dependencies := aCollection! ! !MCConfiguration methodsFor: 'accessing' stamp: 'bf 3/22/2005 18:22'! fileName ^ self name, '.', self writerClass extension ! ! !MCConfiguration methodsFor: 'accessing' stamp: 'bf 6/9/2005 15:58'! log ^log ifNil: [Transcript]! ! !MCConfiguration methodsFor: 'accessing' stamp: 'ar 4/28/2005 11:55'! log: aStream log := aStream.! ! !MCConfiguration methodsFor: 'accessing' stamp: 'bf 3/22/2005 18:23'! name ^name! ! !MCConfiguration methodsFor: 'accessing' stamp: 'bf 3/22/2005 18:23'! name: aString name := aString! ! !MCConfiguration methodsFor: 'accessing' stamp: 'bf 3/23/2005 17:35'! repositories ^repositories ifNil: [repositories := OrderedCollection new]! ! !MCConfiguration methodsFor: 'accessing' stamp: 'bf 3/23/2005 17:36'! repositories: aCollection repositories := aCollection! ! !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: 'accessing' stamp: 'bf 3/22/2005 10:50'! writerClass ^ MCMcmWriter ! ! !MCConfiguration methodsFor: 'actions' stamp: 'bf 3/22/2005 10:51'! fileOutOn: aStream self writerClass fileOut: self on: aStream! ! !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: '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: 'actions' stamp: 'AlainPlantec 12/17/2009 22:59'! upgrade ^self class upgradeIsMerge ifTrue: [self upgradeByMerging] ifFalse: [self upgradeByLoading]! ! !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: 'copying' stamp: 'bf 11/26/2005 20:22'! postCopy dependencies := dependencies shallowCopy. repositories := repositories shallowCopy.! ! !MCConfiguration methodsFor: 'faking' stamp: 'bf 3/24/2005 01:19'! changes ^MCPatch operations: #()! ! !MCConfiguration methodsFor: 'faking' stamp: 'bf 3/24/2005 01:17'! info ^MCVersionInfo new! ! !MCConfiguration methodsFor: 'initialize' stamp: 'ar 5/27/2005 17:28'! initialize super initialize. log := DefaultLog.! ! !MCConfiguration methodsFor: 'testing' stamp: 'bf 3/22/2005 22:56'! isCacheable ^false! ! !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: '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: 'private' stamp: 'StephaneDucasse 2/20/2010 23:07'! 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] ifNotEmptyDo: [: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 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 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 16:07'! logError: aString self log cr; nextPutAll: 'ERROR: '; nextPutAll: aString; cr; flush. ! ! !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: 'bf 6/9/2005 16:08'! logWarning: aString self log cr; nextPutAll: 'WARNING: '; nextPutAll: aString; cr; flush. ! ! !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: 'private' stamp: 'bf 3/20/2006 19:10'! mergeVersionsSilently: aCollection ^self suppressMergeDialogWhile: [self mergeVersions: aCollection]! ! !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: 'private' stamp: 'bf 3/16/2006 19:07'! nameForChangeset ^self name ifNil: [self class name]! ! !MCConfiguration methodsFor: 'private' stamp: 'bf 3/20/2006 19:09'! suppressMergeDialogWhile: aBlock ^[aBlock value] on: MCMergeResolutionRequest do: [:request | request merger conflicts isEmpty ifTrue: [request resume: true] ifFalse: [request pass]]! ! !MCConfiguration methodsFor: 'private' stamp: 'md 9/18/2005 15:56'! versionNamed: verName for: aDependency from: repo | baseName fileName ver | (repo filterFileNames: repo cachedFileNames forVersionNamed: verName) ifNotEmptyDo: [: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 class instanceVariableNames: ''! !MCConfiguration class methodsFor: 'accessing' stamp: 'ar 5/27/2005 17:27'! defaultLog "Answer the default configuration log" ^DefaultLog! ! !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: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: '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 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: 'converting' stamp: 'bf 3/24/2005 01:51'! repositoryToArray: aRepository ^ {aRepository description}! ! !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: 'settings' stamp: 'AlainPlantec 12/17/2009 22:58'! upgradeIsMerge ^ UpgradeIsMerge ifNil: [UpgradeIsMerge := false]! ! !MCConfiguration class methodsFor: 'settings' stamp: 'AlainPlantec 12/17/2009 22:58'! upgradeIsMerge: aBoolean UpgradeIsMerge := aBoolean! ! !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: '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: '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. ]. ! ! MCTool subclass: #MCConfigurationBrowser instanceVariableNames: 'configuration dependencyIndex repositoryIndex' classVariableNames: '' poolDictionaries: '' category: 'MonticelloGUI'! !MCConfigurationBrowser commentStamp: 'StephaneDucasse 11/29/2011 22:23' prior: 0! 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: 'accessing' stamp: 'bf 3/21/2005 16:03'! configuration ^configuration ifNil: [configuration := MCConfiguration new]! ! !MCConfigurationBrowser methodsFor: 'accessing' stamp: 'bf 3/21/2005 14:56'! configuration: aConfiguration configuration := aConfiguration! ! !MCConfigurationBrowser methodsFor: 'accessing' stamp: 'bf 3/21/2005 16:35'! dependencies ^self configuration dependencies ! ! !MCConfigurationBrowser methodsFor: 'accessing' stamp: 'bf 4/19/2005 16:02'! dependencies: aCollection self configuration dependencies: aCollection. self changed: #dependencyList; changed: #description ! ! !MCConfigurationBrowser methodsFor: 'accessing' stamp: 'bf 3/23/2005 17:41'! repositories ^ self configuration repositories! ! !MCConfigurationBrowser methodsFor: 'accessing' stamp: 'bf 3/23/2005 21:15'! repositories: aCollection ^self configuration repositories: aCollection ! ! !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: '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: '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: 'actions' stamp: 'bf 4/19/2005 17:42'! load self configuration load. self changed: #dependencyList; changed: #description ! ! !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: 'actions' stamp: 'bf 4/19/2005 17:42'! merge self configuration merge. self changed: #dependencyList; changed: #description ! ! !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: 'actions' stamp: 'bf 3/23/2005 21:05'! remove self canRemove ifTrue: [ self list removeAt: self index. self changedList. self updateIndex. ]. ! ! !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: '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: '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: '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: 'actions' stamp: 'bf 4/19/2005 17:43'! upgrade self configuration upgrade. self changed: #dependencyList; changed: #description ! ! !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:36'! checkDependencies ^self checkModified and: [self checkMissing]! ! !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: '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: '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: 'dependencies' stamp: 'bf 3/23/2005 17:56'! selectedDependency ^ self dependencies at: self dependencyIndex ifAbsent: []! ! !MCConfigurationBrowser methodsFor: 'dependencies' stamp: 'marcus.denker 11/10/2008 10:04'! selectedPackage ^ self selectedDependency ifNotNil: [:dep | dep package]! ! !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: '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: '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: 'morphic ui' stamp: 'bf 4/19/2005 16:51'! defaultExtent ^ 350@500! ! !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: '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: '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: 'morphic ui' stamp: 'bf 3/23/2005 21:11'! pickRepository ^self pickRepositorySatisfying: [:ea | true] ! ! !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: '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: 'morphic ui' stamp: 'tbn 7/6/2010 17:05'! repositoryMenu: aMenu ^self fillMenu: aMenu fromSpecs: #( ('Add repository...' addRepository) )! ! !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: '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: '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: '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: 'repositories' stamp: 'bf 3/23/2005 21:15'! repositoryList ^self repositories collect: [:ea | ea description] ! ! !MCConfigurationBrowser methodsFor: 'repositories' stamp: 'bf 3/23/2005 17:58'! selectedRepository ^ self repositories at: self repositoryIndex ifAbsent: []! ! !MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 5/27/2005 19:54'! changedButtons self changed: #canMoveDown. self changed: #canMoveUp. self changed: #canRemove.! ! !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: 'selection' stamp: 'bf 3/23/2005 17:56'! dependencyIndex ^dependencyIndex ifNil: [0]! ! !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: 'selection' stamp: 'bf 3/23/2005 20:43'! index ^self dependencyIndex max: self repositoryIndex! ! !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: 'selection' stamp: 'bf 3/23/2005 20:51'! list self dependencyIndex > 0 ifTrue: [^self dependencies]. self repositoryIndex > 0 ifTrue: [^self repositories]. ^#()! ! !MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 3/23/2005 20:52'! maxIndex ^ self list size! ! !MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 3/23/2005 17:57'! repositoryIndex ^repositoryIndex ifNil: [0]! ! !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: 'selection' stamp: 'bf 3/23/2005 23:16'! selectDependency: aDependency self dependencyIndex: (self dependencies indexOf: aDependency)! ! !MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 3/23/2005 23:15'! selectRepository: aRepository self repositoryIndex: (self repositories indexOf: aRepository)! ! !MCConfigurationBrowser methodsFor: 'selection' stamp: 'bf 3/23/2005 21:00'! updateIndex self index > 0 ifTrue: [self index: (self index min: self maxIndex)]! ! !MCConfigurationBrowser methodsFor: 'testing' stamp: 'bf 3/23/2005 20:44'! canMoveDown ^self index between: 1 and: self maxIndex - 1 ! ! !MCConfigurationBrowser methodsFor: 'testing' stamp: 'bf 3/23/2005 20:44'! canMoveUp ^self index > 1! ! !MCConfigurationBrowser methodsFor: 'testing' stamp: 'bf 3/23/2005 20:45'! canRemove ^self index > 0! ! !MCConfigurationBrowser methodsFor: 'testing' stamp: 'bf 3/21/2005 17:15'! includesPackage: aPackage ^self dependencies anySatisfy: [:each | each package = aPackage]! ! !MCConfigurationBrowser methodsFor: 'updating' stamp: 'bf 5/23/2005 17:44'! updateFromImage self configuration updateFromImage. self changed: #dependencyList; changed: #description ! ! !MCConfigurationBrowser methodsFor: 'updating' stamp: 'bf 5/23/2005 17:44'! updateFromRepositories self configuration updateFromRepositories. self changed: #dependencyList; changed: #description ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCConfigurationBrowser class instanceVariableNames: ''! !MCConfigurationBrowser class methodsFor: 'opening' stamp: 'bf 3/21/2005 19:50'! open ^self new show! ! Stream subclass: #MCDataStream instanceVariableNames: 'byteStream topCall basePos' classVariableNames: 'TypeMap' poolDictionaries: '' category: 'Monticello-Storing'! !MCDataStream commentStamp: '' prior: 0! 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'! atEnd "Answer true if the stream is at the end." ^ byteStream atEnd! ! !MCDataStream methodsFor: 'other'! byteStream ^ byteStream! ! !MCDataStream methodsFor: 'other'! close "Close the stream." | bytes | byteStream closed ifFalse: [ bytes := byteStream position. byteStream close] ifTrue: [bytes := 'unknown']. ^ bytes! ! !MCDataStream methodsFor: 'other' stamp: 'nk 3/12/2004 21:56'! contents ^byteStream contents! ! !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: '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'! 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: '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: 'other'! reset "Reset the stream." byteStream reset! ! !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: '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: '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: '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: 'other'! size "Answer the stream's size." ^ byteStream size! ! !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: '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: '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: 'write and read'! getCurrentReference "PRIVATE -- Return the currentReference posn. Overridden by ReferenceStream." ^ 0! ! !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: 'MarianoMartinezPeck 6/5/2012 15:22'! next "Answer the next object in the stream." | type selector anObject isARefType pos internalObject | type := byteStream next. type ifNil: [pos := byteStream position. "absolute!!!!" 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']. pos. "so can see it in debugger" ^ nil]. type = 0 ifTrue: [pos := byteStream position. "absolute!!!!" 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: [pos := byteStream position. "absolute!!!!" 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: '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'! 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: '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: ' 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: 'tk 3/13/98 22:16'! objectIfBlocked: anObject "We don't do any blocking" ^ anObject! ! !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: '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'! 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: '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: 'MarianoMartinezPeck 6/5/2012 15:31'! readClass ^ self error: 'Classes cannot be materialized with DataStream'! ! !MCDataStream methodsFor: 'write and read'! readFalse "PRIVATE -- Read the contents of a False." ^ false! ! !MCDataStream methodsFor: 'write and read'! 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: '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'! readInteger "PRIVATE -- Read the contents of a SmallInteger." ^ byteStream nextInt32 "signed!!!!!!"! ! !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: 'write and read'! readNil "PRIVATE -- Read the contents of an UndefinedObject." ^ nil! ! !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 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: '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 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 6/8/1998 21:03'! readString | str | byteStream ascii. str := byteStream nextString. byteStream binary. ^ str ! ! !MCDataStream methodsFor: 'write and read' stamp: 'tk 6/8/1998 21:27'! readStringOld ^ byteStream nextStringOld! ! !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: 'write and read'! readTrue "PRIVATE -- Read the contents of a True." ^ true! ! !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: '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: '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: 'tk 9/24/2000 15:39'! replace: original with: proxy "We may wish to remember that in some field, the original object is being replaced by the proxy. For the hybred scheme that collects with a DummyStream and writes an ImageSegment, it needs to hold onto the originals so they will appear in outPointers, and be replaced." "do nothing"! ! !MCDataStream methodsFor: 'write and read'! setCurrentReference: refPosn "PRIVATE -- Set currentReference to refPosn. Noop here. Cf. ReferenceStream."! ! !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/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: 'write and read'! writeArray: anArray "PRIVATE -- Write the contents of an Array." byteStream nextNumber: 4 put: anArray size. self nextPutAll: anArray.! ! !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: '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: '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'! writeFalse: aFalse "PRIVATE -- Write the contents of a False."! ! !MCDataStream methodsFor: 'write and read'! 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'! writeInstance: anObject "PRIVATE -- Write the contents of an arbitrary instance." ^ anObject storeDataOn: self! ! !MCDataStream methodsFor: 'write and read'! writeInteger: anInteger "PRIVATE -- Write the contents of a SmallInteger." byteStream nextInt32Put: anInteger "signed!!!!!!!!!!"! ! !MCDataStream methodsFor: 'write and read'! writeNil: anUndefinedObject "PRIVATE -- Write the contents of an UndefinedObject."! ! !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: 'tk 6/8/1998 20:57'! writeString: aString "PRIVATE -- Write the contents of a String." byteStream nextStringPut: aString.! ! !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: 'TestRunner 1/21/2010 21:58'! writeSymbol: aSymbol "PRIVATE -- Write the contents of a Symbol." self writeString: aSymbol! ! !MCDataStream methodsFor: 'write and read'! writeTrue: aTrue "PRIVATE -- Write the contents of a True."! ! !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: '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 class instanceVariableNames: ''! !MCDataStream class methodsFor: 'cleanup' stamp: 'StephaneDucasse 3/9/2010 16:24'! cleanUp "Re-initialize DataStream to avoid hanging onto obsolete classes" self initialize! ! !MCDataStream class methodsFor: 'initialize-release' stamp: 'MarcusDenker 5/31/2012 10:52'! 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:" "DataStream initialize" | refTypes t | refTypes := OrderedCollection new. t := TypeMap := Dictionary 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: '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: '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: '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: 'di 2/15/98 14:03'! new ^ self basicNew! ! !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: '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: '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: '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: '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: 'RAA 7/28/2000 08:33'! unStream: aString ^(self on: ((RWBinaryOrTextStream with: aString) reset; binary)) next! ! BaseStreamTest subclass: #MCDataStreamTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Monticello'! !MCDataStreamTest methodsFor: 'testing' stamp: 'MarianoMartinezPeck 6/17/2012 12:37'! baseStreamType ^ MCDataStream! ! Object subclass: #MCDefinition instanceVariableNames: '' classVariableNames: 'Instances' poolDictionaries: '' category: 'Monticello-Base'! !MCDefinition commentStamp: '' prior: 0! A MCDefinition is the root of inheritance of entities representing code. ! !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: '*Polymorph-Tools-Diff' stamp: 'gvc 4/1/2009 12:11'! className "Answer the class name here or nil if not applicable." ^nil! ! !MCDefinition methodsFor: '*Polymorph-Tools-Diff' stamp: 'gvc 4/1/2009 12:14'! fullClassName "Answer the className by default." ^self className! ! !MCDefinition methodsFor: 'accessing' stamp: 'ab 5/24/2003 14:12'! provisions ^ #()! ! !MCDefinition methodsFor: 'accessing' stamp: 'ab 5/24/2003 14:12'! requirements ^ #()! ! !MCDefinition methodsFor: 'annotations' stamp: 'StephaneDucasse 12/30/2012 17:54'! annotations ^self annotations: Annotation annotationRequests! ! !MCDefinition methodsFor: 'annotations' stamp: 'AlainPlantec 1/7/2010 22:19'! annotations: requests "Answer a string for an annotation pane, trying to fulfill the CodeHolder annotationRequests." ^String streamContents: [ :s | self printAnnotations: requests on: s ].! ! !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: 'comparing' stamp: 'ab 7/19/2003 18:14'! description self subclassResponsibility! ! !MCDefinition methodsFor: 'comparing' stamp: 'nk 10/21/2003 23:18'! fullTimeStamp ^TimeStamp current! ! !MCDefinition methodsFor: 'comparing' stamp: 'ab 7/19/2003 18:14'! hash ^ self description hash! ! !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:25'! isSameRevisionAs: aDefinition ^ self = aDefinition! ! !MCDefinition methodsFor: 'comparing' stamp: 'ab 7/19/2003 18:04'! sortKey self subclassResponsibility ! ! !MCDefinition methodsFor: 'comparing' stamp: 'ab 7/19/2003 17:59'! <= other ^ self sortKey <= other sortKey! ! !MCDefinition methodsFor: 'comparing' stamp: 'nice 10/31/2009 13:08'! = aDefinition ^(aDefinition isKindOf: MCDefinition) and: [self isRevisionOf: aDefinition]! ! !MCDefinition methodsFor: 'installing' stamp: 'AdrianLienhard 1/21/2010 22:14'! addMethodAdditionTo: aCollection self load! ! !MCDefinition methodsFor: 'installing' stamp: 'ab 7/18/2003 21:31'! load ! ! !MCDefinition methodsFor: 'installing' stamp: 'avi 2/17/2004 13:19'! loadOver: aDefinition self load ! ! !MCDefinition methodsFor: 'installing' stamp: 'ab 7/18/2003 19:48'! postload! ! !MCDefinition methodsFor: 'installing' stamp: 'avi 2/17/2004 13:19'! postloadOver: aDefinition self postload! ! !MCDefinition methodsFor: 'installing' stamp: 'ab 11/14/2002 00:08'! unload! ! !MCDefinition methodsFor: 'printing' stamp: 'ab 7/18/2003 19:43'! printOn: aStream super printOn: aStream. aStream nextPutAll: '(', self summary, ')'! ! !MCDefinition methodsFor: 'printing' stamp: 'ab 7/19/2003 18:23'! summary self subclassResponsibility ! ! !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'! isClassDefinition ^false! ! !MCDefinition methodsFor: 'testing' stamp: 'bf 11/12/2004 14:46'! isClassDefinitionExtension "Answer true if this definition extends the regular class definition" ^false! ! !MCDefinition methodsFor: 'testing' stamp: 'ab 12/4/2002 21:51'! isMethodDefinition ^false! ! !MCDefinition methodsFor: 'testing' stamp: 'cwp 7/11/2003 01:32'! isOrganizationDefinition ^false! ! !MCDefinition methodsFor: 'testing' stamp: 'bf 8/12/2009 22:55'! isScriptDefinition ^false! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCDefinition class instanceVariableNames: ''! !MCDefinition class methodsFor: 'cleanup' stamp: 'StephaneDucasse 3/9/2010 16:33'! cleanUp "Flush caches" self clearInstances.! ! !MCDefinition class methodsFor: 'cleanup' stamp: 'stephaneducasse 2/4/2006 20:47'! clearInstances WeakArray removeWeakDependent: Instances. Instances := nil! ! !MCDefinition class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:47'! instanceLike: aDefinition Instances ifNil: [Instances := WeakSet new]. ^ (Instances like: aDefinition) ifNil: [Instances add: aDefinition]! ! Object subclass: #MCDefinitionIndex instanceVariableNames: 'definitions' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Patching'! !MCDefinitionIndex commentStamp: 'LaurentLaffont 3/31/2011 21:06' prior: 0! I'm a simple container of MCDefinitions which can be added or removed.! !MCDefinitionIndex methodsFor: 'as yet unclassified' stamp: 'ab 6/2/2003 00:38'! addAll: aCollection aCollection do: [:ea | self add: ea]! ! !MCDefinitionIndex methodsFor: 'as yet unclassified' stamp: 'StephaneDucasse 5/6/2010 08:52'! add: aDefinition ^ definitions at: aDefinition description put: aDefinition! ! !MCDefinitionIndex methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'ab 6/2/2003 00:42'! definitions ^ definitions values! ! !MCDefinitionIndex methodsFor: 'as yet unclassified' stamp: 'alain.plantec 5/28/2009 10:02'! initialize super initialize. definitions := Dictionary new! ! !MCDefinitionIndex methodsFor: 'as yet unclassified' stamp: 'ab 6/2/2003 00:40'! remove: aDefinition definitions removeKey: aDefinition description ifAbsent: []! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCDefinitionIndex class instanceVariableNames: ''! !MCDefinitionIndex class methodsFor: 'as yet unclassified' stamp: 'ab 6/2/2003 01:29'! definitions: aCollection ^ self new addAll: aCollection! ! Object subclass: #MCDependencySorter instanceVariableNames: 'required provided orderedItems' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Loading'! !MCDependencySorter commentStamp: '' prior: 0! A MCDependencySorter computes the dependencies to a set of entities.! !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: '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: 'building' stamp: 'avi 10/7/2004 22:47'! addExternalProvisions: aCollection (aCollection intersection: self externalRequirements) 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: '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: 'stephaneducasse 2/4/2006 20:47'! addProvision: anObject | newlySatisfied | provided add: anObject. newlySatisfied := required removeKey: anObject ifAbsent: [#()]. self addAll: newlySatisfied.! ! !MCDependencySorter methodsFor: 'private' stamp: 'ab 5/22/2003 23:23'! addRequirements: aCollection for: anObject aCollection do: [:ea | self addRequirement: ea for: anObject]! ! !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: 'private' stamp: 'ab 5/22/2003 23:24'! itemsRequiring: anObject ^ required at: anObject ifAbsentPut: [Set new]! ! !MCDependencySorter methodsFor: 'private' stamp: 'ab 5/22/2003 23:22'! unresolvedRequirementsFor: anItem ^ anItem requirements difference: provided! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCDependencySorter class instanceVariableNames: ''! !MCDependencySorter class methodsFor: 'as yet unclassified' stamp: 'ab 5/23/2003 14:17'! items: aCollection ^ self new addAll: aCollection! ! !MCDependencySorter class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! sortItems: aCollection | sorter | sorter := self items: aCollection. sorter externalRequirements do: [:req | sorter addProvision: req]. ^ sorter orderedItems.! ! TestCase subclass: #MCDependencySorterTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Monticello'! !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:11'! testCycle self assertItems: #( (a (x) (y)) (b (y) (x))) orderAs: #() withRequired: #() toLoad: #(a b) ! ! !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'! testMultiRequirementOrdering self assertItems: #( (a (x) (z)) (b (y) ()) (c (z) ()) (d () (x y z))) orderAs: #(b c a d) withRequired: #() toLoad: #()! ! !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: '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:12'! testUnusedAlternateProvider self assertItems: #( (a (x) (z)) (b () (x)) (c (x) ())) orderAs: #(c b) withRequired: #(z) toLoad: #(a) ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCDependencySorterTest class instanceVariableNames: ''! !MCDependencySorterTest class methodsFor: 'testing' stamp: 'JorgeRessia 3/16/2010 20:26'! isUnitTest ^false! ! ListItemWrapper subclass: #MCDependentsWrapper instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MonticelloGUI'! !MCDependentsWrapper methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'ar 2/14/2004 02:31'! asString ^item description! ! !MCDependentsWrapper methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'ar 2/14/2004 02:31'! hasContents ^item requiredPackages isEmpty not! ! !MCDependentsWrapper methodsFor: 'as yet unclassified' stamp: 'c 8/10/2010 22:15'! hash ^ (self item package name hash * 37) + self model hash ! ! MCRepository subclass: #MCDictionaryRepository instanceVariableNames: 'description dict' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Repositories'! !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: '*gofer-core-accessing' stamp: 'lr 12/11/2009 22:31'! goferPriority ^ 10! ! !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: 'TestRunner 12/13/2009 14:57'! goferVersionFrom: aVersionReference ^ self dictionary detect: [ :version | version info name = aVersionReference name ]! ! !MCDictionaryRepository methodsFor: '*metacello-mc' stamp: 'DaleHenrichs 3/5/2010 14:45'! asRepositorySpecFor: aMetacelloMCProject ^(aMetacelloMCProject repositorySpec) description: 'dictionary://Metacello_Dictionary'; type: 'dictionary'; yourself! ! !MCDictionaryRepository methodsFor: '*metacello-mc' stamp: 'dkh 12/22/2009 12:06'! 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! ! !MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'ab 8/20/2003 21:04'! allVersionInfos ^ dict values collect: [:ea | ea info]! ! !MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'avi 8/26/2004 14:20'! basicStoreVersion: aVersion dict at: aVersion info put: aVersion! ! !MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! closestAncestorVersionFor: anAncestry ifNone: errorBlock | info | info := anAncestry breadthFirstAncestors detect: [:ea | self includesVersionWithInfo: ea] ifNone: [^ errorBlock value]. ^ self versionWithInfo: info! ! !MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'ab 7/26/2003 02:47'! description ^ description ifNil: ['cache']! ! !MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! description: aString description := aString ! ! !MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'ab 7/26/2003 02:47'! dictionary ^ dict! ! !MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! dictionary: aDictionary dict := aDictionary! ! !MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'ab 7/21/2003 23:39'! includesVersionNamed: aString ^ dict anySatisfy: [:ea | ea info name = aString]! ! !MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'ab 8/21/2003 19:49'! includesVersionWithInfo: aVersionInfo ^ dict includesKey: aVersionInfo! ! !MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'alain.plantec 5/28/2009 10:02'! initialize super initialize. dict := Dictionary new. ! ! !MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! sortedVersionInfos | sorter | sorter := MCVersionSorter new. self allVersionInfos do: [:ea | sorter addVersionInfo: ea]. ^ sorter sortedVersionInfos ! ! !MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'ab 8/16/2003 18:22'! versionWithInfo: aVersionInfo ifAbsent: errorBlock ^ dict at: aVersionInfo ifAbsent: errorBlock! ! !MCDictionaryRepository methodsFor: 'as yet unclassified' stamp: 'ab 8/21/2003 12:56'! = other ^ self == other! ! MCRepositoryTest subclass: #MCDictionaryRepositoryTest instanceVariableNames: 'dict' classVariableNames: '' poolDictionaries: '' category: 'Tests-Monticello'! !MCDictionaryRepositoryTest methodsFor: 'actions' stamp: 'ab 8/16/2003 17:53'! addVersion: aVersion dict at: aVersion info put: aVersion! ! !MCDictionaryRepositoryTest methodsFor: 'running' stamp: 'stephaneducasse 2/4/2006 20:47'! setUp repository := MCDictionaryRepository new dictionary: self dictionary! ! !MCDictionaryRepositoryTest methodsFor: 'utility' stamp: 'ab 7/19/2003 16:06'! deleteNode: aNode dict removeKey: aNode! ! !MCDictionaryRepositoryTest methodsFor: 'utility' stamp: 'stephaneducasse 2/4/2006 20:47'! dictionary ^ dict ifNil: [dict := Dictionary new]! ! MCVersion subclass: #MCDiffyVersion instanceVariableNames: 'base patch' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Versioning'! !MCDiffyVersion methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2004 23:17'! baseInfo ^ base! ! !MCDiffyVersion methodsFor: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'bf 5/30/2005 17:39'! fileName ^ (self class nameForVer: info name base: base name), '.', self writerClass extension! ! !MCDiffyVersion methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'avi 2/13/2004 23:24'! isDiffy ^ true! ! !MCDiffyVersion methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2004 23:17'! patch ^ patch! ! !MCDiffyVersion methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! snapshot ^ snapshot ifNil: [snapshot := MCPatcher apply: patch to: self baseSnapshot]! ! !MCDiffyVersion methodsFor: 'as yet unclassified' stamp: 'avi 2/19/2004 22:03'! summary ^ '(Diff against ', self baseInfo name, ')', String cr, super summary! ! !MCDiffyVersion methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2004 23:17'! writerClass ^ MCMcdWriter ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCDiffyVersion class instanceVariableNames: ''! !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! ! !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: '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 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:19'! verNameFrom: diffName ^diffName copyUpTo: $(! ! MCFileBasedRepository subclass: #MCDirectoryRepository instanceVariableNames: 'directory' classVariableNames: 'DefaultDirectoryName' poolDictionaries: '' category: 'Monticello-Repositories'! !MCDirectoryRepository methodsFor: '*gofer-core-accessing' stamp: 'lr 12/11/2009 22:32'! goferPriority ^ 5! ! !MCDirectoryRepository methodsFor: '*metacello-mc' stamp: 'DaleHenrichs 3/5/2010 14:44'! asRepositorySpecFor: aMetacelloMCProject ^(aMetacelloMCProject repositorySpec) description: directory fullName; type: 'directory'; yourself! ! !MCDirectoryRepository methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'CamilloBruni 5/4/2012 19:04'! description ^ directory fullName! ! !MCDirectoryRepository methodsFor: 'as yet unclassified' stamp: 'ab 7/6/2003 17:49'! directory ^ directory! ! !MCDirectoryRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! directory: aDirectory directory := aDirectory! ! !MCDirectoryRepository methodsFor: 'as yet unclassified' stamp: 'SeanDeNigris 6/18/2012 15:58'! includesFileNamed: aString "HACK: speed up the cache hits" ^ (directory / aString) exists.! ! !MCDirectoryRepository methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'CamilloBruni 5/4/2012 21:35'! initialize super initialize. directory := FileSystem workingDirectory! ! !MCDirectoryRepository methodsFor: 'as yet unclassified' stamp: 'nk 11/2/2003 10:55'! isValid ^directory exists! ! !MCDirectoryRepository methodsFor: 'as yet unclassified' stamp: 'StephaneDucasse 6/17/2012 18:51'! loadAllFileNames ^ (directory entries sort: [:a :b | a modificationTime >= b modificationTime]) collect: [:ea | ea basename]! ! !MCDirectoryRepository methodsFor: 'as yet unclassified' stamp: 'SeanDeNigris 6/29/2012 15:49'! readStreamForFileNamed: aString do: aBlock | val | directory / aString readStreamDo: [ :stream| val := aBlock value: stream ]. ^ val! ! !MCDirectoryRepository methodsFor: 'as yet unclassified' stamp: 'SeanDeNigris 6/29/2012 15:50'! writeStreamForFileNamed: aString replace: shouldReplace do: aBlock | file | file := directory / aString. shouldReplace ifTrue: [ file delete ]. file writeStreamDo: [ :stream | aBlock value: stream ].! ! !MCDirectoryRepository methodsFor: 'comparing' stamp: 'CamilloBruni 5/24/2012 09:36'! hash ^ directory hash! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCDirectoryRepository class instanceVariableNames: ''! !MCDirectoryRepository class methodsFor: 'instance creation' stamp: 'CamilloBruni 5/4/2012 21:35'! defaultDirectoryName ^ DefaultDirectoryName ifNil: [ DefaultDirectoryName := FileSystem workingDirectory fullName].! ! !MCDirectoryRepository class methodsFor: 'instance creation' stamp: 'SeanDeNigris 4/21/2010 14:38'! defaultDirectoryName: aDirectoryName DefaultDirectoryName := aDirectoryName.! ! !MCDirectoryRepository class methodsFor: 'instance creation' stamp: 'ab 7/24/2003 21:20'! description ^ 'directory'! ! !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]! ! MCRepositoryTest subclass: #MCDirectoryRepositoryTest instanceVariableNames: 'directory' classVariableNames: '' poolDictionaries: '' category: 'Tests-Monticello'! !MCDirectoryRepositoryTest methodsFor: 'accessing' stamp: 'GuillermoPolito 7/3/2012 10:24'! directory directory ifNil: [directory := 'mctest' asFileReference. directory ensureDirectory]. ^ directory! ! !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: 'running' stamp: 'stephaneducasse 2/4/2006 20:47'! setUp repository := MCDirectoryRepository new directory: self directory! ! !MCDirectoryRepositoryTest methodsFor: 'running' stamp: 'CamilloBruni 7/6/2012 16:08'! tearDown self directory deleteAll. ! ! PackageInfo subclass: #MCDirtyPackageInfo instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Mocks'! !MCDirtyPackageInfo methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! classes ^ Array new: 0.! ! !MCDirtyPackageInfo methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! packageName ^ 'MCDirtyPackage'! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCDirtyPackageInfo class instanceVariableNames: ''! !MCDirtyPackageInfo class methodsFor: 'as yet unclassified' stamp: 'avi 2/22/2004 14:04'! initialize [self new register] on: MessageNotUnderstood do: []! ! !MCDirtyPackageInfo class methodsFor: 'as yet unclassified' stamp: 'cwp 7/21/2003 19:45'! wantsChangeSetLogging ^ false! ! Object subclass: #MCDoItParser instanceVariableNames: 'source' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Chunk Format'! !MCDoItParser commentStamp: '' prior: 0! 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: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! source: aString source := aString! ! !MCDoItParser methodsFor: 'actions' stamp: 'avi 3/10/2004 12:40'! addDefinitionsTo: aCollection self subclassResponsibility ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCDoItParser class instanceVariableNames: ''! !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: 'instance creation' stamp: 'avi 3/10/2004 12:30'! subclassForDoit: aString ^ self concreteSubclasses detect: [:ea | ea pattern match: aString] ifNone: []! ! !MCDoItParser class methodsFor: 'testing' stamp: 'avi 3/10/2004 12:51'! isAbstract ^ self pattern isNil! ! !MCDoItParser class methodsFor: 'private' stamp: 'avi 3/10/2004 12:29'! concreteSubclasses ^ self allSubclasses reject: [:c | c isAbstract]! ! PackageInfo subclass: #MCEmptyPackageInfo instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Mocks'! !MCEmptyPackageInfo methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! classes ^ #()! ! !MCEmptyPackageInfo methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! methods ^ #()! ! !MCEmptyPackageInfo methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! packageName ^ 'MCEmptyPackage'! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCEmptyPackageInfo class instanceVariableNames: ''! !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! ! MCRepository subclass: #MCFileBasedRepository instanceVariableNames: 'cache allFileNames cacheFileNames' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Repositories'! !MCFileBasedRepository methodsFor: '*MonticelloGUI' stamp: 'avi 2/28/2004 18:32'! morphicOpen: aWorkingCopy (MCFileRepositoryInspector repository: self workingCopy: aWorkingCopy) show! ! !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: '*gofer-core-accessing' stamp: 'lr 12/12/2009 11:29'! goferVersionFrom: aVersionReference ^ self loadVersionFromFileNamed: aVersionReference name , '.mcz'! ! !MCFileBasedRepository methodsFor: '*metacello-mc' stamp: 'dkh 10/20/2009 11:25'! 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: 'as yet unclassified' stamp: 'CamilloBruni 4/20/2012 17:57'! allFileNames cacheFileNames == true ifFalse: [ ^ self loadAllFileNames ]. ^ allFileNames ifNil: [ allFileNames := self loadAllFileNames]! ! !MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'ab 8/21/2003 20:01'! allFileNamesForVersionNamed: aString ^ self filterFileNames: self readableFileNames forVersionNamed: aString! ! !MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 3/2/2012 13:01'! allFileNamesOrCache cacheFileNames ifFalse: [ ^ self allFileNames ]. ^ allFileNames ifNil: [ allFileNames := self allFileNames]! ! !MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'ab 8/21/2003 00:40'! allVersionNames ^ self readableFileNames collect: [:ea | self versionNameFromFileName: ea]! ! !MCFileBasedRepository methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! cache ^ cache ifNil: [cache := Dictionary new]! ! !MCFileBasedRepository methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'bf 6/9/2005 15:47'! cachedFileNames ^cache == nil ifTrue: [#()] ifFalse: [cache keys]! ! !MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! canReadFileNamed: aString | reader | reader := MCVersionReader readerClassForFileNamed: aString. ^ reader notNil! ! !MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 16:40'! closestAncestorVersionFor: anAncestry ifNone: errorBlock ^ self cacheAllFileNamesDuring: [super closestAncestorVersionFor: anAncestry ifNone: errorBlock]! ! !MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'ab 8/21/2003 20:01'! filterFileNames: aCollection forVersionNamed: aString ^ aCollection select: [:ea | (self versionNameFromFileName: ea) = aString] ! ! !MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! flushCache cache := nil! ! !MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 1/26/2012 19:49'! includesFileNamed: aString "slow default implementation" ^ self allFileNames includes: aString! ! !MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'ab 8/21/2003 00:36'! includesVersionNamed: aString ^ self allVersionNames includes: aString! ! !MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 3/2/2012 13:03'! loadAllFileNames self subclassResponsibility! ! !MCFileBasedRepository methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'avi 9/17/2005 18:37'! loadVersionInfoFromFileNamed: aString ^ self versionReaderForFileNamed: aString do: [:r | r info] ! ! !MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 4/20/2012 18:14'! maxCacheSize ^ 512! ! !MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 1/26/2012 19:50'! notifyList (self includesFileNamed: 'notify') ifFalse: [^ #()]. ^ self readStreamForFileNamed: 'notify' do: [:s | s upToEnd lines]! ! !MCFileBasedRepository methodsFor: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'avi 9/18/2005 22:43'! resizeCache: aDictionary [aDictionary size <= self maxCacheSize] whileFalse: [aDictionary removeKey: aDictionary keys atRandom]! ! !MCFileBasedRepository methodsFor: 'as yet unclassified' 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 methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 18:37'! versionInfoFromFileNamed: aString self cache at: aString ifPresent: [:v | ^ v info]. ^ self loadVersionInfoFromFileNamed: aString! ! !MCFileBasedRepository methodsFor: 'as yet unclassified' stamp: 'bf 5/30/2005 22:52'! versionNameFromFileName: aString ^ (aString copyUpToLast: $.) copyUpTo: $(! ! !MCFileBasedRepository methodsFor: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'avi 10/31/2003 14:32'! writeStreamForFileNamed: aString do: aBlock ^ self writeStreamForFileNamed: aString replace: false do: aBlock! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCFileBasedRepository class instanceVariableNames: ''! !MCFileBasedRepository class methodsFor: 'as yet unclassified' stamp: 'avi 2/3/2005 00:43'! flushAllCaches self allSubInstancesDo: [:ea | ea flushCache]! ! !MCFileBasedRepository class methodsFor: 'cleanup' stamp: 'StephaneDucasse 3/9/2010 16:33'! cleanUp "Flush caches" self flushAllCaches.! ! MCTestCase subclass: #MCFileInTest instanceVariableNames: 'stream expected diff' classVariableNames: '' poolDictionaries: '' category: 'Tests-Monticello'! !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: 'running' stamp: 'stephaneducasse 2/4/2006 20:47'! setUp expected := self mockSnapshot. stream := RWBinaryOrTextStream on: String new.! ! !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: 'cwp 8/10/2003 02:08'! alterInitialState self mockClassA touchCVar! ! !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: '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:40'! assertInitializersOrder | initializationOrder | initializationOrder := self mockClassA initializationOrder. self assert: initializationOrder = 2. ! ! !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: 'testing' stamp: 'GuillermoPolito 8/24/2012 15:06'! testStWriter "self debug: #testStWriter" self assertFileOutFrom: MCStWriter canBeFiledInWith: [ CodeImporter evaluateReadStream: stream readStream]. ! ! MCVersionInspector subclass: #MCFileRepositoryInspector instanceVariableNames: 'repository versions loaded newer inherited packageList selectedPackage selectedVersion order versionInfo pattern packagePattern versionPattern' classVariableNames: 'Order' poolDictionaries: '' category: 'MonticelloGUI'! !MCFileRepositoryInspector commentStamp: 'LaurentLaffont 2/5/2011 17:35' prior: 0! 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: 'as yet unclassified' stamp: 'StephaneDucasse 1/23/2013 21:58'! addVersionInformationExtractedFrom: each to: packageNames | name | name := (each copyUpToLast: $.) copyUpTo: $(. name last isDigit ifTrue: [ versions add: {(packageNames add: (name copyUpToLast: $-)). "pkg name" ((name copyAfterLast: $-) copyUpTo: $.). "user" (((name copyAfterLast: $-) copyAfter: $.) asInteger ifNil: [ 0 ]). "version" each }]! ! !MCFileRepositoryInspector methodsFor: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'bf 11/16/2004 11:56'! merge super merge. self refresh. ! ! !MCFileRepositoryInspector methodsFor: 'as yet unclassified' stamp: 'StephaneDucasse 1/24/2013 12:05'! refresh | packageNames | packageNames := Set new. packageList := nil. versions := OrderedCollection new. repository readableFileNames do: [ :each | self addVersionInformationExtractedFrom: each to: packageNames ]. versions := versions select: [ :each | (each at: 3) isNumber ]. newer := Set new. inherited := Set new. loaded := Set new. self allManagers do: [ :each | | latest | self computeLoadedAndInheritedFromManager: each. 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 ] ]. self changed: #packageList; changed: #packageSelection; changed: #versionList! ! !MCFileRepositoryInspector methodsFor: 'as yet unclassified' 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: 'initialize-release' stamp: 'StephaneDucasse 1/23/2013 21:39'! initialize super initialize. loaded := Set new.! ! !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: 'Lr 12/9/2010 17:25'! defaultExtent ^ 640 @ 480! ! !MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'lr 9/26/2003 20:06'! defaultLabel ^'Repository: ' , repository description! ! !MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 9/17/2005 17:21'! hasVersion ^ selectedVersion notNil! ! !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: '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 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: 'bf 2/24/2005 18:29'! packageHighlight: aString newer ifNil: [newer := #()]. ^(loaded anySatisfy: [:each | (each copyUpToLast: $-) = aString]) ifTrue: [ Text string: aString attribute: (TextEmphasis new emphasisCode: ( ((newer includes: aString) ifTrue: [5] ifFalse: [4])))] ifFalse: [aString]! ! !MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'CamilloBruni 4/24/2012 14:55'! packageList | result loadedPackages | versions ifNil: [ ^ #() ]. 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 ifNotNil: [ result := result select: [ :package| packagePattern search: package name ]]. ^packageList := result collect: [ :each | self packageHighlight: each ]! ! !MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'lr 9/26/2003 17:25'! packageListMenu: aMenu ^aMenu! ! !MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'CamilloBruni 1/16/2012 21:52'! packageSearchAccept: aString aString isEmptyOrNil ifTrue: [ packagePattern := nil ] ifFalse: [ packagePattern := [ aString asRegexIgnoringCase ] on: RegexSyntaxError do: [ aString ]]. self changed: #packageList.! ! !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: 'morphic ui' stamp: 'lr 9/26/2003 20:17'! packageSelection ^self packageList indexOf: selectedPackage! ! !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: 'SeanDeNigris 7/17/2012 15:49'! saveChanges | repo workingCopy | repo := repository. workingCopy := MCWorkingCopy forPackage: (MCPackage new name: selectedPackage). workingCopy newVersion ifNotNil: [:v | (MCVersionInspector new version: v) show. Cursor wait showWhile: [repo storeVersion: v]. MCCacheRepository uniqueInstance cacheAllFileNamesDuring: [repo cacheAllFileNamesDuring: [v allAvailableDependenciesDo: [:dep | (repo includesVersionNamed: dep info name) ifFalse: [repo storeVersion: dep]]]]]! ! !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: '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: 'stephaneducasse 2/4/2006 20:47'! versionInfo ^ versionInfo ifNil: [versionInfo := repository versionInfoFromFileNamed: selectedVersion]! ! !MCFileRepositoryInspector methodsFor: 'morphic ui' stamp: 'MartinDias 1/8/2013 15:21'! versionList | result sortBlock | result := selectedPackage isNil ifTrue: [ versions ifNil: [ ^ #() ]] ifFalse: [ (versions ifNil: [ ^ #() ]) select: [ :each | selectedPackage = each first ] ]. sortBlock := (self orderSpecs at: order) value. sortBlock isNil ifFalse: [ result := result asSortedCollection: [:a :b | [sortBlock value: a value: b] on: Error do: [true]]]. versionPattern ifNotNil: [ result := result select: [ :package| versionPattern search: package name ]]. ^ result collect: [ :each | self versionHighlight: each fourth ]! ! !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: 'CamilloBruni 1/16/2012 21:52'! versionSearchAccept: aString aString isEmptyOrNil ifTrue: [ versionPattern := nil ] ifFalse: [ versionPattern := [ aString asRegexIgnoringCase ] on: RegexSyntaxError do: [ aString ]]. self changed: #versionList.! ! !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 20:18'! versionSelection ^self versionList indexOf: selectedVersion! ! !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: '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 class instanceVariableNames: 'packageSearchList versionSearchList'! !MCFileRepositoryInspector class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'FernandoOlivero 4/12/2011 09:47'! taskbarIcon "Answer the icon for the receiver in a task bar." ^self theme smallSaveIcon! ! !MCFileRepositoryInspector class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! order Order isNil ifTrue: [ Order := 5 ]. ^Order! ! !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! ! !MCFileRepositoryInspector class methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 8/4/2011 14:24'! versionSearchList ^ versionSearchList ifNil: [ versionSearchList := OrderedCollection new]. ! ! MCVersionSorter subclass: #MCFilteredVersionSorter instanceVariableNames: 'target' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Versioning'! !MCFilteredVersionSorter methodsFor: 'as yet unclassified' stamp: 'bf 5/28/2005 01:14'! addVersionInfo: aVersionInfo (aVersionInfo hasAncestor: target) ifTrue: [super addVersionInfo: aVersionInfo] ! ! !MCFilteredVersionSorter methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! target: aVersionInfo target := aVersionInfo! ! Object subclass: #MCFrontier instanceVariableNames: 'frontier bag' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Versioning'! !MCFrontier methodsFor: 'accessing' stamp: 'avi 9/17/2005 22:02'! frontier ^frontier! ! !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: 'initialization' stamp: 'avi 9/17/2005 22:11'! frontier: f bag: remaining frontier := f asOrderedCollection. bag := remaining! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCFrontier class instanceVariableNames: ''! !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 ^ self frontierOnAll: (Array with: aVersionInfo)! ! !MCFrontier class methodsFor: 'instance creation' stamp: 'avi 9/17/2005 22:07'! frontierOn: aVersionInfo and: otherVersionInfo ^ self frontierOnAll: (Array with: aVersionInfo with: otherVersionInfo)! ! MCFileBasedRepository subclass: #MCFtpRepository instanceVariableNames: 'host directory user password connection' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Repositories'! !MCFtpRepository methodsFor: '*metacello-platform' stamp: 'DaleHenrichs 3/5/2010 14:49'! 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: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! directory: dirPath directory := dirPath! ! !MCFtpRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! host: hostname host := hostname! ! !MCFtpRepository methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 3/2/2012 13:02'! loadAllFileNames ^ self clientDo: [:client | self parseDirectoryListing: client getDirectory]! ! !MCFtpRepository methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! password: passwordString password := passwordString! ! !MCFtpRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! user: userString user := userString! ! !MCFtpRepository methodsFor: 'required' stamp: 'avi 9/17/2003 12:52'! description ^ 'ftp://', user, '@', host, '/', directory! ! !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: '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 class instanceVariableNames: ''! !MCFtpRepository class methodsFor: '*MonticelloGUI' stamp: 'bkv 2/18/2004 21:02'! fillInTheBlankRequest ^ 'FTP Repository:' ! ! !MCFtpRepository class methodsFor: '*MonticelloGUI' stamp: 'bkv 2/18/2004 21:02'! morphicConfigure ^ self fillInTheBlankConfigure! ! !MCFtpRepository class methodsFor: 'as yet unclassified' stamp: 'avi 9/16/2003 13:57'! creationTemplate ^ 'MCFtpRepository host: ''modules.squeakfoundation.org'' directory: ''mc'' user: ''squeak'' password: ''squeak''' ! ! !MCFtpRepository class methodsFor: 'as yet unclassified' stamp: 'avi 9/16/2003 13:57'! description ^ 'FTP'! ! !MCFtpRepository class methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'bkv 2/18/2004 20:38'! templateCreationSelector ^ #host:directory:user:password: ! ! MCRepository subclass: #MCGOODSRepository instanceVariableNames: 'hostname port connection' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Repositories'! !MCGOODSRepository methodsFor: '*MonticelloGUI' stamp: 'avi 2/28/2004 20:10'! morphicOpen: aWorkingCopy (MCRepositoryInspector repository: self workingCopy: aWorkingCopy) show! ! !MCGOODSRepository methodsFor: 'as yet unclassified' stamp: 'avi 8/26/2004 14:20'! basicStoreVersion: aVersion self root at: aVersion info put: aVersion. self db commit.! ! !MCGOODSRepository methodsFor: 'as yet unclassified' stamp: 'lr 3/14/2010 21:13'! db (connection isNil or: [ connection isConnected not ]) ifTrue: [ connection := Smalltalk globals at: #KKDatabase ifPresent: [ :cl | cl onHost: hostname port: port ] ]. ^ connection! ! !MCGOODSRepository methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 20:35'! description ^ 'goods://', hostname asString, ':', port asString! ! !MCGOODSRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! host: aString hostname := aString! ! !MCGOODSRepository methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 20:17'! packages ^ (self root collect: [:ea | ea package]) asSet asSortedCollection! ! !MCGOODSRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! port: aNumber port := aNumber! ! !MCGOODSRepository methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 14:35'! root self db root ifNil: [self db root: Dictionary new]. ^ self db root! ! !MCGOODSRepository methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 20:18'! versionsAvailableForPackage: aPackage ^ self root asArray select: [:ea | ea package = aPackage] thenCollect: [:ea | ea info]! ! !MCGOODSRepository methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 20:21'! versionWithInfo: aVersionInfo ifAbsent: errorBlock ^ self root at: aVersionInfo ifAbsent: errorBlock! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCGOODSRepository class instanceVariableNames: ''! !MCGOODSRepository class methodsFor: '*MonticelloGUI' stamp: 'avi 2/28/2004 20:33'! fillInTheBlankRequest ^ 'GOODS Repository:'! ! !MCGOODSRepository class methodsFor: '*MonticelloGUI' stamp: 'avi 2/28/2004 20:35'! morphicConfigure ^ self fillInTheBlankConfigure! ! !MCGOODSRepository class methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 20:36'! creationTemplate ^ 'MCGOODSRepository host: ''localhost'' port: 6100'! ! !MCGOODSRepository class methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 14:33'! description ^ 'GOODS'! ! !MCGOODSRepository class methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 20:36'! host: hostname port: portNumber ^ self new host: hostname; port: portNumber! ! MCHttpRepository subclass: #MCGemstoneRepository instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Repositories'! !MCGemstoneRepository commentStamp: 'CamilloBruni 2/8/2012 18:10' prior: 0! 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 class instanceVariableNames: ''! !MCGemstoneRepository class methodsFor: 'accessing' stamp: 'CamilloBruni 10/21/2012 13:24'! baseURL ^ 'http://ss3.gemstone.com/ss/'! ! !MCGemstoneRepository class methodsFor: 'accessing' stamp: 'CamilloBruni 2/8/2012 18:12'! description ^ 'ss3.gemstone.com'! ! MCFileBasedRepository subclass: #MCHttpRepository instanceVariableNames: 'location user password readerCache' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Repositories'! !MCHttpRepository methodsFor: '*keychain' stamp: 'BenjaminVanRyseghem 10/25/2012 14:53'! keyChainGroupSelector ^ #monticelloDefault! ! !MCHttpRepository methodsFor: '*metacello-mc' stamp: 'DaleHenrichs 3/5/2010 14:45'! asRepositorySpecFor: aMetacelloMCProject ^(aMetacelloMCProject repositorySpec) description: self description; type: 'http'; yourself! ! !MCHttpRepository methodsFor: 'accessing' stamp: 'CamilloBruni 9/14/2012 17:24'! description ^ self location! ! !MCHttpRepository methodsFor: 'accessing' stamp: 'CamilloBruni 9/14/2012 17:24'! location ^ location! ! !MCHttpRepository methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! location: aUrlString location := aUrlString! ! !MCHttpRepository methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! password: passwordString password := passwordString! ! !MCHttpRepository methodsFor: 'accessing' stamp: 'CamilloBruni 9/18/2012 18:35'! project "Return a project name" ^ (self location splitOn: $/) last! ! !MCHttpRepository methodsFor: 'accessing' stamp: 'PavelKrivanek 2/8/2013 13:21'! user self userAndPasswordFromSettingsDo: [:usr :pwd | ^usr]. "not in settings" user isEmptyOrNil ifFalse: [ ^user ]. ^ Smalltalk globals at: #UsersManager ifPresent: [:usersManager | (usersManager default currentUser userNamePasswordFor: self keyChainGroupSelector) ifNotNil: [ :usr | usr username ] ifNil: [ '' ]] ifAbsent: [ '' ]! ! !MCHttpRepository methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! user: userString user := userString! ! !MCHttpRepository methodsFor: 'actions' stamp: 'al 12/12/2005 11:06'! flushCache super flushCache. readerCache := nil.! ! !MCHttpRepository methodsFor: 'actions' stamp: 'CamilloBruni 9/14/2012 17:24'! locationWithTrailingSlash ^ (self location endsWith: '/') ifTrue: [self location] ifFalse: [self location, '/']! ! !MCHttpRepository methodsFor: 'actions' stamp: 'stephaneducasse 2/4/2006 20:47'! 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 unescapePercents]]. ^ names! ! !MCHttpRepository methodsFor: 'actions' stamp: 'DamienCassou 2/14/2013 11:40'! password self userAndPasswordFromSettingsDo: [:usr :pwd | ^pwd]. self user isEmpty ifTrue: [^password ifNil: ['']]. password isEmptyOrNil ifTrue: [ password := (UsersManager 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: 'actions' stamp: 'ab 8/21/2003 13:08'! urlForFileNamed: aString ^ self locationWithTrailingSlash, aString encodeForHTTP! ! !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: '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: 'actions' stamp: 'marcus.denker 11/10/2008 10:04'! versionReaderForFileNamed: aString do: aBlock ^ (self versionReaderForFileNamed: aString) ifNotNil: aBlock! ! !MCHttpRepository methodsFor: 'converting' stamp: 'CamilloBruni 9/14/2012 17:24'! asCreationTemplate ^self class creationTemplateLocation: self location user: user password: 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: '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: 'i/o' stamp: 'CamilloBruni 9/27/2012 20:59'! loadAllFileNames | client | self displayProgress: 'Loading all file names from ', self description during: [ (client := self httpClient) 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: 'i/o' stamp: 'SvenVanCaekenberghe 6/5/2012 21:47'! readStreamForFileNamed: aString do: aBlock | client | self displayProgress: 'Downloading ', aString during: [ (client := self httpClient) 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: 'i/o' stamp: 'SvenVanCaekenberghe 6/5/2012 21:52'! writeStreamForFileNamed: aString replace: ignoreBoolean do: aBlock | entity | entity := self entityStreamContents: aBlock. self displayProgress: 'Uploading ', aString during: [ self httpClient entity: entity; ifFail: [ :exception | 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: '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: '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 methodsFor: 'private' stamp: 'SvenVanCaekenberghe 1/15/2013 14:59'! 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; setAcceptEncodingGzip; signalProgress: true; yourself! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCHttpRepository class instanceVariableNames: ''! !MCHttpRepository class methodsFor: '*MonticelloGUI' stamp: 'bkv 2/18/2004 21:00'! fillInTheBlankRequest ^ 'HTTP Repository:' ! ! !MCHttpRepository class methodsFor: '*MonticelloGUI' stamp: 'bkv 2/18/2004 21:01'! morphicConfigure ^ self fillInTheBlankConfigure! ! !MCHttpRepository class methodsFor: 'accessing' stamp: 'CamilloBruni 10/21/2012 13:25'! baseURL ^ ''! ! !MCHttpRepository class methodsFor: 'accessing' stamp: 'ab 7/24/2003 21:20'! description ^ 'HTTP'! ! !MCHttpRepository class methodsFor: 'creation template' stamp: 'CamilloBruni 10/21/2012 13:24'! creationTemplate ^self creationTemplateLocation: self baseURL user: '' password: '' ! ! !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: 'initialization' stamp: 'bf 7/28/2005 19:44'! clearPasswords self allSubInstancesDo: [:ea | ea password: '']. ! ! !MCHttpRepository class methodsFor: 'instance creation' stamp: 'SeanDeNigris 8/26/2012 15:50'! inboxRepository ^ self location: 'http://ss3.gemstone.com/ss/PharoInbox/'.! ! !MCHttpRepository class methodsFor: 'instance creation' stamp: 'SeanDeNigris 8/26/2012 18:20'! location: location ^ MCServerRegistry uniqueInstance repositoryAt: location credentialsDo: [ :username :password | self new location: location; user: username; password: password ].! ! !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 10/21/2012 13:26'! project: aProjectIdentifier ^ self location: self baseURL, aProjectIdentifier! ! MCVariableDefinition subclass: #MCInstanceVariableDefinition instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Modeling'! !MCInstanceVariableDefinition commentStamp: '' prior: 0! A MCInstanceVariableDefinition represents an instance variable definition.! !MCInstanceVariableDefinition methodsFor: 'testing' stamp: 'cwp 7/7/2003 23:32'! isInstanceVariable ^ true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCInstanceVariableDefinition class instanceVariableNames: ''! !MCInstanceVariableDefinition class methodsFor: 'as yet unclassified' stamp: 'cwp 7/7/2003 22:59'! type ^ #instance! ! MCMczReader subclass: #MCMcdReader instanceVariableNames: 'baseInfo patch' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Storing'! !MCMcdReader methodsFor: 'as yet unclassified' stamp: 'avi 2/14/2004 21:33'! baseInfo ^ baseInfo ifNil: [self loadBaseInfo]! ! !MCMcdReader methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'avi 2/14/2004 21:37'! buildPatchFrom: oldDefinitions to: newDefinitions ^ MCPatch fromBase: (MCSnapshot fromDefinitions: oldDefinitions) target: (MCSnapshot fromDefinitions: newDefinitions)! ! !MCMcdReader methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! loadBaseInfo ^ baseInfo := self extractInfoFrom: (self parseMember: 'base')! ! !MCMcdReader methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'avi 2/14/2004 21:34'! patch ^ patch ifNil: [self loadPatch]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCMcdReader class instanceVariableNames: ''! !MCMcdReader class methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2004 23:09'! extension ^ 'mcd'! ! MCMczWriter subclass: #MCMcdWriter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Storing'! !MCMcdWriter methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! writeBaseInfo: aVersionInfo | string | string := self serializeVersionInfo: aVersionInfo. self addString: string at: 'base'. ! ! !MCMcdWriter methodsFor: 'as yet unclassified' stamp: 'avi 2/17/2004 01:48'! writeDefinitions: aVersion self writeBaseInfo: aVersion baseInfo. self writePatch: aVersion patch.! ! !MCMcdWriter methodsFor: 'as yet unclassified' stamp: 'avi 2/17/2004 02:07'! writeNewDefinitions: aCollection self addString: (self serializeDefinitions: aCollection) at: 'new/source.', self snapshotWriterClass extension.! ! !MCMcdWriter methodsFor: 'as yet unclassified' stamp: 'avi 2/17/2004 02:07'! writeOldDefinitions: aCollection self addString: (self serializeDefinitions: aCollection) at: 'old/source.', self snapshotWriterClass extension.! ! !MCMcdWriter methodsFor: 'as yet unclassified' 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 class instanceVariableNames: ''! !MCMcdWriter class methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2004 23:09'! readerClass ^ MCMcdReader! ! MCVersionReader subclass: #MCMcmReader instanceVariableNames: 'fileName configuration' classVariableNames: '' poolDictionaries: '' category: 'MonticelloConfigurations'! !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 methodsFor: 'accessing' stamp: 'bf 3/23/2005 01:17'! configurationName ^fileName ifNotNil: [(fileName findTokens: '/\:') last copyUpToLast: $.]! ! !MCMcmReader methodsFor: 'accessing' stamp: 'bf 3/23/2005 01:17'! fileName: aString fileName := aString! ! !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 11/16/2005 11:01'! loadVersionInfo info := self configuration! ! !MCMcmReader methodsFor: 'accessing' stamp: 'bf 11/16/2005 11:01'! version ^self configuration! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCMcmReader class instanceVariableNames: ''! !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! ! MCWriter subclass: #MCMcmWriter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MonticelloConfigurations'! !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 instanceVariableNames: ''! !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. ! ! MCTestCase subclass: #MCMczInstallerTest instanceVariableNames: 'expected diff' classVariableNames: '' poolDictionaries: '' category: 'Tests-Monticello'! !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: '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: '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: 'CamilloBruni 7/23/2012 19:51'! deleteFile self fileName asFileReference ensureDeleted! ! !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 18:16'! fileStream ^ FileStream forceNewFileNamed: self fileName.! ! !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: 'cwp 8/7/2003 19:36'! tearDown expected snapshot updatePackage: self mockPackage. self deleteFile.! ! !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 instanceVariableNames: ''! !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 ]! ! MCVersionReader subclass: #MCMczReader instanceVariableNames: 'zip infoCache' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Storing'! !MCMczReader methodsFor: 'as yet unclassified' 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 methodsFor: 'as yet unclassified' stamp: 'marcus.denker 11/10/2008 10:04'! extractDefinitionsFrom: member | reader | (MCSnapshotReader readerClassForFileNamed: member fileName) ifNotNil: [:rc | reader := rc on: member contentStream text. definitions addAll: reader definitions] ! ! !MCMczReader methodsFor: 'as yet unclassified' stamp: 'avi 1/19/2004 16:11'! extractDependencyFrom: zipMember ^ MCVersionDependency package: (MCPackage named: (zipMember fileName copyAfterLast: $/)) info: (self extractInfoFrom: (self parseMember: zipMember fileName))! ! !MCMczReader methodsFor: 'as yet unclassified' stamp: 'StephaneDucasse 8/17/2012 15:50'! extractInfoFrom: dict ^MCWorkingCopy infoFromDictionary: dict cache: self infoCache! ! !MCMczReader methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! infoCache ^ infoCache ifNil: [infoCache := Dictionary new]! ! !MCMczReader methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! parseMember: fileName | tokens | tokens := (self scanner scanTokens: (self zip contentsOf: fileName)) first. ^ self associate: tokens! ! !MCMczReader methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 20:33'! scanner ^ MCScanner! ! !MCMczReader methodsFor: 'as yet unclassified' 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: '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: 'loading' stamp: 'stephaneducasse 2/4/2006 20:47'! loadDependencies dependencies := (self zip membersMatching: 'dependencies/*') collect: [:m | self extractDependencyFrom: m]. dependencies := dependencies asArray. ! ! !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: 'BenjaminVanRyseghem 8/31/2012 15:10'! loadVersionInfo info := self extractInfoFrom: (self parseMember: 'version')! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCMczReader class instanceVariableNames: ''! !MCMczReader class methodsFor: 'accessing' stamp: 'cwp 8/1/2003 14:59'! extension ^ 'mcz'! ! !MCMczReader class methodsFor: 'testing' stamp: 'avi 1/19/2004 14:48'! supportsDependencies ^ true! ! !MCMczReader class methodsFor: 'testing' stamp: 'cwp 8/1/2003 12:19'! supportsVersions ^ true! ! MCWriter subclass: #MCMczWriter instanceVariableNames: 'zip infoWriter' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Storing'! !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: 'accessing' stamp: 'cwp 8/1/2003 00:06'! zip ^ zip! ! !MCMczWriter methodsFor: 'initializing' stamp: 'alain.plantec 5/28/2009 10:03'! initialize super initialize. zip := ZipArchive new. ! ! !MCMczWriter methodsFor: 'serializing' stamp: 'stephaneducasse 2/4/2006 20:47'! serializeDefinitions: aCollection | writer s | s := RWBinaryOrTextStream on: String new. writer := self snapshotWriterClass on: s. writer writeDefinitions: aCollection. ^ s contents! ! !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: 'serializing' stamp: 'cwp 8/13/2003 01:06'! serializePackage: aPackage ^ '(name ''', aPackage name, ''')'! ! !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: '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 2/17/2004 01:48'! writePackage: aPackage self addString: (self serializePackage: aPackage) at: 'package'! ! !MCMczWriter methodsFor: 'visiting' stamp: 'avi 9/28/2004 14:26'! writeSnapshot: aSnapshot self addString: (self serializeDefinitions: aSnapshot definitions) at: 'snapshot/source.', self snapshotWriterClass extension. self addString: (self serializeInBinary: aSnapshot) at: 'snapshot.bin'! ! !MCMczWriter methodsFor: 'visiting' stamp: 'stephaneducasse 2/4/2006 20:47'! writeVersionDependency: aVersionDependency | string | string := (self serializeVersionInfo: aVersionDependency versionInfo). self addString: string at: 'dependencies/', aVersionDependency package name! ! !MCMczWriter methodsFor: 'visiting' stamp: 'stephaneducasse 2/4/2006 20:47'! writeVersionInfo: aVersionInfo | string | string := self serializeVersionInfo: aVersionInfo. self addString: string at: 'version'. ! ! !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: 'writing' stamp: 'avi 2/17/2004 02:17'! flush zip writeTo: stream. stream close! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCMczWriter class instanceVariableNames: ''! !MCMczWriter class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! fileOut: aVersion on: aStream | inst | inst := self on: aStream. inst writeVersion: aVersion. inst flush. ! ! !MCMczWriter class methodsFor: 'as yet unclassified' stamp: 'cwp 8/1/2003 12:35'! readerClass ^ MCMczReader! ! MCPatchBrowser subclass: #MCMergeBrowser instanceVariableNames: 'conflicts merger ok' classVariableNames: '' poolDictionaries: '' category: 'MonticelloGUI'! !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: '*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'! 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: '*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: '*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: '*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: '*Polymorph-Tools-Diff' stamp: 'gvc 4/2/2009 13:14'! selection: aNumber "Notify change of conflicts too." super selection: aNumber. self changed: #selectionIsConflicted! ! !MCMergeBrowser methodsFor: 'accessing' stamp: 'ab 7/18/2003 16:32'! items ^ conflicts, items! ! !MCMergeBrowser methodsFor: 'actions' stamp: 'ab 7/22/2003 00:51'! canMerge ^ merger isMerged! ! !MCMergeBrowser methodsFor: 'actions' stamp: 'ab 7/18/2003 17:52'! cancel self answer: false! ! !MCMergeBrowser methodsFor: 'actions' stamp: 'ab 7/18/2003 18:41'! clearChoice self conflictSelectionDo: [selection clearChoice. self changed: #text; changed: #list]! ! !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: '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 16:37'! getOperationMenu: aMenu ^ aMenu! ! !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 17:52'! merge merger isMerged ifFalse: [self inform: 'You must resolve all the conflicts first'] ifTrue: [self answer: true] ! ! !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: 'CamilloBruni 8/4/2011 15:10'! selectionIsConflicted selection ifNil: [ ^ false ]. ^ selection isConflict! ! !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: 'morphic ui' stamp: 'ab 7/19/2003 21:31'! defaultLabel ^ 'Merge Browser'! ! !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: 'morphic ui' stamp: 'AlainPlantec 12/1/2009 21:46'! widgetSpecs "ToolBuilder doesn't know about innerButtonRow. Made explicit here." MCCodeTool showAnnotationPane ifFalse: [ ^#( ((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)) )]. ^ #( ((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: annotations) (0 0.4 1 0.4) (0 32 0 62)) ((textMorph: text) (0 0.4 1 1) (0 62 0 0)) )! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCMergeBrowser class instanceVariableNames: ''! !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]! ! Warning subclass: #MCMergeOrLoadWarning instanceVariableNames: 'versions' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Loading'! !MCMergeOrLoadWarning commentStamp: '' prior: 0! 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: 'accessing' stamp: 'abc 8/8/2011 12:53'! versions: aCollection versions := aCollection! ! !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 class instanceVariableNames: ''! !MCMergeOrLoadWarning class methodsFor: 'as yet unclassified' stamp: 'abc 8/8/2011 12:50'! signalFor: aVersionCollection ^ self new versions: aVersionCollection; signal! ! Object subclass: #MCMergeRecord instanceVariableNames: 'version packageSnapshot ancestorInfo ancestor ancestorSnapshot imagePatch mergePatch' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Versioning'! !MCMergeRecord methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! ancestorInfo ^ ancestorInfo ifNil: [ancestorInfo := version info commonAncestorWith: version workingCopy ancestry]! ! !MCMergeRecord methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! ancestorSnapshot ^ ancestorSnapshot ifNil: [ancestorSnapshot := version workingCopy findSnapshotWithVersionInfo: self ancestorInfo]! ! !MCMergeRecord methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! imagePatch ^ imagePatch ifNil: [imagePatch := self packageSnapshot patchRelativeToBase: self ancestorSnapshot]! ! !MCMergeRecord methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! initializeWithVersion: aVersion version := aVersion! ! !MCMergeRecord methodsFor: 'as yet unclassified' stamp: 'abc 2/13/2004 17:14'! isAncestorMerge ^ version workingCopy ancestry hasAncestor: version info! ! !MCMergeRecord methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! mergePatch ^ mergePatch ifNil: [mergePatch := version snapshot patchRelativeToBase: self ancestorSnapshot]! ! !MCMergeRecord methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! packageSnapshot ^ packageSnapshot ifNil: [packageSnapshot := version package snapshot]! ! !MCMergeRecord methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'abc 2/13/2004 15:52'! version ^ version! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCMergeRecord class instanceVariableNames: ''! !MCMergeRecord class methodsFor: 'as yet unclassified' stamp: 'abc 2/13/2004 15:52'! version: aVersion ^ self basicNew initializeWithVersion: aVersion! ! Notification subclass: #MCMergeResolutionRequest instanceVariableNames: 'merger' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Versioning'! !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: '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: '*Polymorph-Tools-Diff' stamp: 'StephaneDucasse 12/30/2012 09:54'! viewPatchMerger "Open a modal diff tools browser to perform the merge." |m modalMorph| m := (PSMCMergeMorph forMerger: self merger) fromDescription: 'Working copy' translated; toDescription: messageText. modalMorph := (UIManager default respondsTo: #modalMorph) ifTrue: [UIManager default modalMorph] ifFalse: [World]. modalMorph openModal: ( m newWindow title: messageText). ^m merged! ! !MCMergeResolutionRequest methodsFor: 'as yet unclassified' stamp: 'ab 7/18/2003 18:19'! merger ^ merger! ! !MCMergeResolutionRequest methodsFor: 'as yet unclassified' stamp: 'EstebanLorenzano 11/7/2012 16:13'! merger: aMerger merger := aMerger! ! Object subclass: #MCMerger instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Merging'! !MCMerger commentStamp: '' prior: 0! A MCMerger is an abstract responsible for performing merge operations and detecting conflicts.! !MCMerger methodsFor: 'accessing' stamp: 'StephaneDucasse 6/24/2011 15:14'! conflicts ^ self operations select: #isConflict ! ! !MCMerger methodsFor: 'accessing' stamp: 'ab 6/2/2003 01:11'! mergedSnapshot ^ MCPatcher apply: self to: self baseSnapshot! ! !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 6/24/2011 15:18'! addConflictWithOperation: anOperation self operations add: anOperation beConflict! ! !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: '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: '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! ! !MCMerger methodsFor: 'testing' stamp: 'ab 6/5/2003 19:09'! isMerged ^ self conflicts allSatisfy: [:ea | ea isResolved]! ! MCTestCase subclass: #MCMergingTest instanceVariableNames: 'conflictBlock conflicts' classVariableNames: '' poolDictionaries: '' category: 'Tests-Monticello'! !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: 'asserting' stamp: 'ab 1/15/2003 16:46'! assert: aCollection hasElements: anArray self assert: (aCollection collect: [:ea | ea token]) asSet = anArray 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 00:28'! testAdditiveConflictlessMerge self assertMerge: #(a1 b1) with: #(a1 c1) base: #(a1) gives: #(a1 b1 c1) 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'! testIdenticalModification self assertMerge: #(a2 b1) with: #(a2 b1) base: #(a1 b1) gives: #(a2 b1) conflicts: #()! ! !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)).! ! !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: '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: '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: '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: '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 6/2/2003 01:38'! testSimultaneousModification self assertMerge: #(a2) with: #(a3) base: #(a1) gives: #(a3) conflicts: #((a3 a2)).! ! !MCMergingTest methodsFor: 'tests' stamp: 'ab 12/5/2002 01:27'! testSimultaneousRemove self assertMerge: #(a1) with: #(a1) base: #(a1 b1) gives: #(a1) conflicts: #()! ! !MCMergingTest methodsFor: 'tests' stamp: 'ab 12/5/2002 01:31'! testSubtractiveConflictlessMerge self assertMerge: #(a1 b1) with: #() base: #(a1) gives: #(b1) conflicts: #()! ! MCDefinition subclass: #MCMethodDefinition instanceVariableNames: 'classIsMeta source category selector className timeStamp' classVariableNames: 'Definitions InitializersEnabled' poolDictionaries: '' category: 'Monticello-Modeling'! !MCMethodDefinition commentStamp: '' prior: 0! A MCMethodDefinition represents a method definition. It captures the following information. Instance Variables category: classIsMeta: className: selector: source: timeStamp: ! !MCMethodDefinition methodsFor: '*Polymorph-Tools-Diff' stamp: 'BenjaminVanRyseghem 9/28/2011 15:24'! shortSummaryPrefix ^ self definition selector asString! ! !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: 'accessing' stamp: 'lr 3/14/2010 21:13'! actualClass ^ Smalltalk globals at: className ifPresent: [ :class | classIsMeta ifTrue: [ class classSide ] ifFalse: [ class ] ]! ! !MCMethodDefinition methodsFor: 'accessing' stamp: 'ab 11/13/2002 01:59'! category ^ category! ! !MCMethodDefinition methodsFor: 'accessing' stamp: 'cwp 11/25/2002 07:26'! classIsMeta ^ classIsMeta! ! !MCMethodDefinition methodsFor: 'accessing' stamp: 'ab 11/15/2002 01:12'! className ^className! ! !MCMethodDefinition methodsFor: 'accessing' stamp: 'StephaneDucasse 7/7/2010 18:47'! fullTimeStamp ^TimeStamp fromMethodTimeStamp: timeStamp! ! !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/15/2002 01:11'! selector ^selector! ! !MCMethodDefinition methodsFor: 'accessing' stamp: 'ab 11/13/2002 01:59'! source ^ source! ! !MCMethodDefinition methodsFor: 'accessing' stamp: 'ab 1/15/2003 13:42'! timeStamp ^ timeStamp! ! !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: '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: 'comparing' stamp: 'ab 5/24/2003 14:11'! requirements ^ Array with: className! ! !MCMethodDefinition methodsFor: 'comparing' stamp: 'ab 7/19/2003 18:01'! sortKey ^ self className, '.', (self classIsMeta ifTrue: ['meta'] ifFalse: ['nonmeta']), '.', self selector! ! !MCMethodDefinition methodsFor: 'comparing' stamp: 'CamilloBruni 2/28/2012 13:44'! = aDefinition ^(super = aDefinition) and: [aDefinition category = self category and: [aDefinition timeStamp = self timeStamp and: [aDefinition source = self source]]]! ! !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: 'installing' stamp: 'avi 9/17/2003 22:27'! isExtensionMethod ^ category beginsWith: '*'! ! !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 methodsFor: 'installing' stamp: 'avi 11/10/2003 15:45'! isOverrideMethod "this oughta check the package" ^ self isExtensionMethod and: [category endsWith: '-override']! ! !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: 'installing' stamp: 'ar 12/12/2009 17:05'! removeSelector: aSelector fromClass: aClass "Safely remove the given selector from the target class. Be careful not to remove the selector when it has wondered to another package." | 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. ! ! !MCMethodDefinition methodsFor: 'installing' stamp: 'StephaneDucasse 5/28/2011 13:34'! scanForPreviousVersion | sourceFilesCopy method position | method := self actualClass compiledMethodAt: selector ifAbsent: [ ^ nil ]. position := method filePosition. sourceFilesCopy := SourceFiles collect: [ :x | x isNil ifTrue: [ nil ] ifFalse: [ x readOnlyCopy ] ]. [ | file prevPos tokens preamble methodCategory stamp prevFileIndex | method fileIndex = 0 ifTrue: [ ^ nil ]. file := sourceFilesCopy at: method fileIndex. [ position notNil & file notNil ] whileTrue: [ file position: (0 max: position - 150). "Skip back to before the preamble" [ file position < (position - 1) ] whileTrue: [ preamble := file nextChunk ]. "then pick it up from the front" "Preamble is likely a linked method preamble, if we're in a changes file (not the sources file). Try to parse it for prior source position and file index" prevPos := nil. stamp := ''. (preamble findString: 'methodsFor:' startingAt: 1) > 0 ifTrue: [ tokens := Scanner new scanTokens: preamble ] ifFalse: [ tokens := Array new "ie cant be back ref" ]. ((tokens size between: 7 and: 8) and: [ (tokens at: tokens size - 5) = #methodsFor: ]) ifTrue: [ (tokens at: tokens size - 3) = #stamp: ifTrue: [ "New format gives change stamp and unified prior pointer" stamp := tokens at: tokens size - 2. prevPos := tokens last. prevFileIndex := sourceFilesCopy fileIndexFromSourcePointer: prevPos. prevPos := sourceFilesCopy filePositionFromSourcePointer: prevPos ] ifFalse: [ "Old format gives no stamp; prior pointer in two parts" prevPos := tokens at: tokens size - 2. prevFileIndex := tokens last ]. (prevPos = 0 or: [ prevFileIndex = 0 ]) ifTrue: [ prevPos := nil ] ]. ((tokens size between: 5 and: 6) and: [ (tokens at: tokens size - 3) = #methodsFor: ]) ifTrue: [ (tokens at: tokens size - 1) = #stamp: ifTrue: [ "New format gives change stamp and unified prior pointer" stamp := tokens at: tokens size ] ]. methodCategory := tokens after: #methodsFor: ifAbsent: [ 'as yet unclassifed' ]. methodCategory = category ifFalse: [ methodCategory = (Smalltalk globals at: #Categorizer ifAbsent: [ Smalltalk globals at: #ClassOrganizer ]) default ifTrue: [ methodCategory := methodCategory , ' ' ]. ^ ChangeRecord new file: file position: position type: #method class: className category: methodCategory meta: classIsMeta stamp: stamp ]. position := prevPos. prevPos notNil ifTrue: [ file := sourceFilesCopy at: prevFileIndex ] ]. ^ nil ] ensure: [ sourceFilesCopy do: [ :x | x notNil ifTrue: [ x close ] ] ]! ! !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: 'ab 12/5/2002 21:25'! description ^ Array with: className with: selector with: classIsMeta! ! !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: 'printing' stamp: 'BenjaminVanRyseghem 9/28/2011 15:26'! summary ^ selector! ! !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: 'testing' stamp: 'ab 5/24/2003 13:49'! isCodeDefinition ^ true! ! !MCMethodDefinition methodsFor: 'testing' stamp: 'ab 8/8/2003 17:05'! isInitializer ^ selector = #initialize and: [classIsMeta] ! ! !MCMethodDefinition methodsFor: 'testing' stamp: 'GuillermoPolito 1/11/2012 22:53'! isLoadable ^self actualClass notNil! ! !MCMethodDefinition methodsFor: 'testing' stamp: 'ab 12/4/2002 21:52'! isMethodDefinition ^true! ! !MCMethodDefinition methodsFor: 'visiting' stamp: 'ab 7/18/2003 21:47'! accept: aVisitor ^ aVisitor visitMethodDefinition: self! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCMethodDefinition class instanceVariableNames: ''! !MCMethodDefinition class methodsFor: 'class initialization' stamp: 'CamilloBruni 6/2/2012 00:13'! cachedDefinitions Definitions ifNil: [ Definitions := WeakIdentityKeyDictionary new ]. ^ Definitions! ! !MCMethodDefinition class methodsFor: 'class 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: 'class initialization' stamp: 'ab 8/22/2003 18:14'! initialize Smalltalk addToShutDownList: self! ! !MCMethodDefinition class methodsFor: 'class initialization' stamp: 'StephaneDucasse 12/28/2012 21:31'! shutDown "Free up all cached monticello method definitions" self flushMethodCache ! ! !MCMethodDefinition class methodsFor: 'cleanup' stamp: 'StephaneDucasse 3/9/2010 16:34'! cleanUp "Flush caches" self shutDown.! ! !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: '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: '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 ^ InitializersEnabled ifNil: [true]! ! !MCMethodDefinition class methodsFor: 'settings' stamp: 'PavelKrivanek 6/22/2011 11:40'! initializersEnabled: aBoolean InitializersEnabled := aBoolean! ! MCTestCase subclass: #MCMethodDefinitionTest instanceVariableNames: 'navigation isModified' classVariableNames: '' poolDictionaries: '' category: 'Tests-Monticello'! !MCMethodDefinitionTest methodsFor: 'mocks' stamp: 'EstebanLorenzano 2/21/2013 18:13'! override ^ 1! ! !MCMethodDefinitionTest methodsFor: 'running' stamp: 'cwp 11/13/2003 14:15'! ownPackage ^ MCWorkingCopy forPackage: (MCPackage named: 'Monticello')! ! !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: '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: '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: '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)! ! !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'. ! ! Object subclass: #MCMock instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Mocks'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCMock class instanceVariableNames: ''! !MCMock class methodsFor: 'as yet unclassified' stamp: 'cwp 7/21/2003 19:40'! wantsChangeSetLogging ^ false! ! SharedPool subclass: #MCMockAPoolDictionary instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Mocks'! MCMockClassA subclass: #MCMockASubclass instanceVariableNames: 'x' classVariableNames: 'Y' poolDictionaries: '' category: 'MonticelloMocks'! !MCMockASubclass methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! variables ^ x + Y + MCMockClassA! ! !MCMockASubclass methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! variables2 ^ ivar + CVar! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCMockASubclass class instanceVariableNames: ''! !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.]! ! 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.! !MCMockClassA methodsFor: 'boolean' stamp: 'cwp 7/13/2003 02:49'! falsehood ^ false! ! !MCMockClassA methodsFor: 'boolean' stamp: 'ab 7/7/2003 23:21'! moreTruth ^ true! ! !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: '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'! c ^ 'c1'! ! !MCMockClassA methodsFor: 'numeric' stamp: 'GuillermoPolito 8/24/2012 15:31'! d ^ 'd'! ! !MCMockClassA methodsFor: 'numeric' stamp: 'GuillermoPolito 8/24/2012 15:22'! one ^ 1! ! !MCMockClassA methodsFor: 'numeric' stamp: 'GuillermoPolito 8/24/2012 15:28'! two ^ 2! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCMockClassA class instanceVariableNames: ''! !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: 'pavel.krivanek 10/14/2010 16:21'! initialize CVar := #initialized. InitializationOrder := 1. ! ! !MCMockClassA class methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! one ^ 1! ! !MCMockClassA class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! touchCVar CVar := #touched! ! MCMock subclass: #MCMockClassB instanceVariableNames: 'ivarb' classVariableNames: 'CVar' poolDictionaries: 'MCMockAPoolDictionary' category: 'MonticelloMocks'! !MCMockClassB commentStamp: '' prior: 0! This comment has a bang!! Bang!! Bang!!! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCMockClassB class instanceVariableNames: 'ciVar'! Object subclass: #MCMockClassD instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MonticelloMocks'! !MCMockClassD methodsFor: 'as yet unclassified' stamp: 'cwp 7/8/2003 21:21'! one ^ 1! ! Object variableSubclass: #MCMockClassE instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MonticelloMocks'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCMockClassE class instanceVariableNames: ''! !MCMockClassE class methodsFor: 'as yet unclassified' stamp: 'cwp 7/8/2003 21:22'! two ^ 2! ! Object subclass: #MCMockClassF instanceVariableNames: '' classVariableNames: 'Foo' poolDictionaries: '' category: 'MonticelloMocks'! Object variableWordSubclass: #MCMockClassG instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MonticelloMocks'! Object variableByteSubclass: #MCMockClassH instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MonticelloMocks'! Object weakSubclass: #MCMockClassI instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MonticelloMocks'! MCDefinition subclass: #MCMockDefinition instanceVariableNames: 'token' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Mocks'! !MCMockDefinition methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! asString ^ token! ! !MCMockDefinition methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! description ^ token first! ! !MCMockDefinition methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! hash ^ token hash! ! !MCMockDefinition methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! printString ^ token! ! !MCMockDefinition methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! summary ^ token! ! !MCMockDefinition methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! token ^ token! ! !MCMockDefinition methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! token: aString token := aString! ! !MCMockDefinition methodsFor: 'as yet unclassified' stamp: 'MarianoMartinezPeck 5/30/2012 17:12'! = definition self == definition ifTrue: [ ^ true ]. self species = definition species ifFalse: [ ^ false ]. ^definition token = token! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCMockDefinition class instanceVariableNames: ''! !MCMockDefinition class methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! token: aString ^ self new token: aString! ! !MCMockDefinition class methodsFor: 'as yet unclassified' stamp: 'cwp 7/21/2003 19:46'! wantsChangeSetLogging ^ false! ! Object subclass: #MCMockDependency instanceVariableNames: 'name children hasResolution' classVariableNames: '' poolDictionaries: '' category: 'Tests-Monticello'! !MCMockDependency methodsFor: 'accessing' stamp: 'cwp 11/7/2004 14:43'! children ^ children collect: [:ea | self class fromTree: ea]! ! !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: 'accessing' stamp: 'cwp 11/7/2004 14:38'! name ^ name! ! !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: '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: '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: 'resolving' stamp: 'cwp 11/7/2004 14:42'! hasResolution ^ hasResolution! ! !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 class instanceVariableNames: ''! !MCMockDependency class methodsFor: 'instance creation' stamp: 'cwp 11/7/2004 14:43'! fromTree: anArray ^ self new initializeWithTree: anArray! ! MCMock subclass: #MCMockDependentItem instanceVariableNames: 'name provides requires' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Mocks'! !MCMockDependentItem methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! name ^ name! ! !MCMockDependentItem methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! name: aString name := aString! ! !MCMockDependentItem methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! provides: anArray provides := anArray! ! !MCMockDependentItem methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! provisions ^ provides ifNil: [#()]! ! !MCMockDependentItem methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 23:21'! requirements ^ requires ifNil: [#()]! ! !MCMockDependentItem methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! requires: anArray requires := anArray! ! !MCMockDependentItem methodsFor: 'as yet unclassified' stamp: 'bf 5/20/2005 16:15'! <= other ^ self name <= other name! ! RPackage subclass: #MCMockRPackage instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'RPackage-Tests'! !MCMockRPackage commentStamp: 'cyrilledelaunay 1/24/2011 16:16' prior: 0! This class should be used instead of MCMockPackageInfo in the monticello tests! !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:33:00+01:00'! classes ^ self classNames select: [ :tmpName | Smalltalk globals hasClassNamed: tmpName ] thenCollect: [ :tmpName | Smalltalk globals at: tmpName ]! ! !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:50:00+01:00'! name ^ self packageName! ! !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 class instanceVariableNames: ''! !MCMockRPackage class methodsFor: 'initialize-release' stamp: 'StephaneDucasse 6/3/2012 23:29'! initialize [self packageOrganizerClass default registerPackage: self new ] on: MessageNotUnderstood do: []! ! MCPatchOperation subclass: #MCModification instanceVariableNames: 'obsoletion modification' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Patching'! !MCModification commentStamp: '' prior: 0! A MCModification represents the operation to modify an entity to a snapshot. ! !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: '*Polymorph-Tools-Diff' stamp: 'gvc 1/14/2009 14:11'! 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: [self fromSource]! ! !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'! baseDefinition ^ obsoletion! ! !MCModification methodsFor: 'accessing' stamp: 'StephaneDucasse 6/24/2011 14:53'! basicApplyTo: anObject anObject modifyDefinition: obsoletion to: modification! ! !MCModification methodsFor: 'accessing' stamp: 'cwp 11/28/2002 06:55'! definition ^ modification! ! !MCModification methodsFor: 'accessing' stamp: 'ab 7/18/2003 16:44'! fromSource ^ obsoletion source! ! !MCModification methodsFor: 'accessing' stamp: 'ab 8/22/2003 02:27'! inverse ^ MCModification of: modification to: obsoletion! ! !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: 'StephaneDucasse 8/17/2012 16:30'! summarySuffix ^ modification summarySuffixOver: obsoletion ! ! !MCModification methodsFor: 'accessing' stamp: 'nk 2/23/2005 18:18'! targetClass ^ obsoletion actualClass! ! !MCModification methodsFor: 'accessing' stamp: 'ab 6/1/2003 13:10'! targetDefinition ^ modification! ! !MCModification methodsFor: 'accessing' stamp: 'ab 7/18/2003 16:44'! toSource ^ modification source! ! !MCModification methodsFor: 'as yet unclassified' 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: 'initializing' stamp: 'stephaneducasse 2/4/2006 20:47'! initializeWithBase: base target: target obsoletion := base. modification := target.! ! !MCModification methodsFor: 'testing' stamp: 'nk 2/25/2005 17:29'! isClassPatch ^obsoletion isClassDefinition! ! !MCModification methodsFor: 'testing' stamp: 'cwp 11/28/2002 07:23'! isModification ^ true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCModification class instanceVariableNames: ''! !MCModification class methodsFor: 'as yet unclassified' stamp: 'cwp 11/28/2002 07:19'! of: base to: target ^ self new initializeWithBase: base target: target! ! MCPackageLoader subclass: #MCMultiPackageLoader instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Loading'! !MCMultiPackageLoader commentStamp: '' prior: 0! 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! ! Exception subclass: #MCNoChangesException instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Versioning'! !MCNoChangesException methodsFor: 'as yet unclassified' stamp: 'jf 8/21/2003 19:49'! defaultAction self inform: 'No changes'! ! MCDefinition subclass: #MCOrganizationDefinition instanceVariableNames: 'categories' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Modeling'! !MCOrganizationDefinition commentStamp: '' prior: 0! A MCOrganizationDefinition represents a category change. ! !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 methodsFor: '*Polymorph-Tools-Diff' stamp: 'BenjaminVanRyseghem 9/28/2011 15:24'! shortSummaryPrefix ^ self definition description last! ! !MCOrganizationDefinition methodsFor: '*Ring-Monticello' stamp: 'VeronicaUquillas 5/12/2011 13:01'! asRingDefinition ^RGFactory current createOrganization categories: self categories; yourself ! ! !MCOrganizationDefinition methodsFor: 'accessing' stamp: 'ab 7/18/2003 21:47'! accept: aVisitor ^ aVisitor visitOrganizationDefinition: self! ! !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: 'accessing' stamp: 'StephaneDucasse 12/30/2012 09:52'! categories: anArray categories := anArray sort! ! !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: 'EstebanLorenzano 2/11/2013 14:30'! description ^ Array with: #organization with: self commonPrefix! ! !MCOrganizationDefinition methodsFor: 'accessing' stamp: 'ab 7/19/2003 18:01'! sortKey ^ ''! ! !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: 'accessing' stamp: 'ab 5/24/2003 13:55'! summary ^ categories asArray printString! ! !MCOrganizationDefinition methodsFor: 'equal/hash' 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: 'installing' stamp: 'avi 2/22/2004 13:46'! postloadOver: oldDefinition SystemOrganization categories: (self reorderCategories: SystemOrganization categories original: (oldDefinition ifNil: [#()] ifNotNil: [oldDefinition categories]))! ! !MCOrganizationDefinition methodsFor: 'testing' stamp: 'cwp 7/11/2003 01:33'! isOrganizationDefinition ^ true! ! !MCOrganizationDefinition methodsFor: 'unloading' stamp: 'EstebanLorenzano 2/11/2013 13:59'! unload categories do: [ :c | SystemOrganization removeCategory: c ]! ! !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: '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 class instanceVariableNames: ''! !MCOrganizationDefinition class methodsFor: 'instance creation' stamp: 'StephaneDucasse 12/30/2012 09:59'! categories: anArray ^ self instanceLike: (self new categories: anArray)! ! MCTestCase subclass: #MCOrganizationTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Monticello'! !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)! ! !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).! ! TestCase subclass: #MCPTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Kernel'! !MCPTest methodsFor: 'constants' stamp: 'dgd 2/14/2003 10:13'! defaultBounds "the default bounds for morphs" ^ 0 @ 0 corner: 50 @ 40 ! ! !MCPTest methodsFor: 'constants' stamp: 'dgd 2/14/2003 10:13'! defaultTop "the default top for morphs" ^ self defaultBounds top ! ! !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: '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! ! Object subclass: #MCPackage instanceVariableNames: 'name' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Base'! !MCPackage commentStamp: '' prior: 0! 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: '*Nautilus'! isDirty | modifiedPackages | modifiedPackages := MCWorkingCopy allManagers select: [ :each | each modified ]. ^ modifiedPackages anySatisfy: [:wc | wc package = self ]! ! !MCPackage methodsFor: '*RPackage-SystemIntegration' stamp: 'MarcusDenker 10/19/2012 09:47'! correspondingRPackage ^ RPackageOrganizer default packageNamed: self name asSymbol ifAbsent: [ nil ]! ! !MCPackage methodsFor: 'accessing' stamp: 'ab 7/7/2003 00:57'! name ^ name! ! !MCPackage methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! name: aString name := aString! ! !MCPackage methodsFor: 'accessing' 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: 'EstebanLorenzano 9/11/2012 17:01'! packageSet ^ RPackageSet named: name! ! !MCPackage methodsFor: 'accessing' stamp: 'GuillermoPolito 2/8/2013 13:02'! snapshot | packageInfo definitions categories | packageInfo := self packageSet. definitions := OrderedCollection new. categories := (packageInfo packages collect: #packageName) 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: 'comparing' stamp: 'ar 4/26/2005 21:57'! = other ^ other species = self species and: [other name sameAs: name]! ! !MCPackage methodsFor: 'comparing' stamp: 'ar 4/26/2005 21:57'! hash ^ name asLowercase hash! ! !MCPackage methodsFor: 'printing' stamp: 'nk 7/28/2003 13:30'! printOn: aStream super printOn: aStream. aStream nextPut: $(; nextPutAll: name; nextPut: $)! ! !MCPackage methodsFor: 'printing' stamp: 'ab 7/10/2003 01:13'! storeOn: aStream aStream nextPutAll: 'MCPackage'; space; nextPutAll: 'named: '; store: name.! ! !MCPackage methodsFor: 'working copies' stamp: 'bf 4/19/2005 16:26'! hasWorkingCopy ^ MCWorkingCopy registry includesKey: self! ! !MCPackage methodsFor: 'working copies' stamp: 'cwp 11/13/2003 13:32'! unload ^ self workingCopy unload! ! !MCPackage methodsFor: 'working copies' stamp: 'cwp 11/13/2003 13:33'! workingCopy ^ MCWorkingCopy forPackage: self.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCPackage class instanceVariableNames: ''! !MCPackage class methodsFor: 'as yet unclassified' stamp: 'ab 7/10/2003 01:17'! named: aString ^ self new name: aString! ! !MCPackage class methodsFor: 'renaming'! 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.' ]! ! Object subclass: #MCPackageCache instanceVariableNames: 'sorter fileNames' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Repositories'! !MCPackageCache commentStamp: 'LaurentLaffont 3/31/2011 21:06' prior: 0! I'm a kind of cache for versions and filenames of packages.! !MCPackageCache methodsFor: 'as yet unclassified' stamp: 'alain.plantec 5/28/2009 10:03'! initialize super initialize. sorter := MCVersionSorter new. fileNames := Dictionary new.! ! !MCPackageCache methodsFor: 'as yet unclassified' stamp: 'AdrianLienhard 1/21/2010 22:14'! recordVersionInfo: aVersionInfo forFileNamed: aString fileNames at: aVersionInfo put: aString. sorter addVersionInfo: aVersionInfo! ! !MCPackageCache methodsFor: 'as yet unclassified' stamp: 'avi 1/22/2004 18:21'! versionInfos ^ sorter sortedVersionInfos ! ! Object subclass: #MCPackageLoader instanceVariableNames: 'requirements unloadableDefinitions obsoletions additions removals errorDefinitions provisions methodAdditions' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Loading'! !MCPackageLoader commentStamp: '' prior: 0! 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: 'patch ops' stamp: 'ab 5/24/2003 16:13'! addDefinition: aDefinition additions add: aDefinition! ! !MCPackageLoader methodsFor: 'patch ops' stamp: 'avi 2/17/2004 13:14'! modifyDefinition: old to: new self addDefinition: new. obsoletions at: new put: old.! ! !MCPackageLoader methodsFor: 'patch ops' stamp: 'ab 5/24/2003 16:14'! removeDefinition: aDefinition removals add: aDefinition! ! !MCPackageLoader methodsFor: 'public' stamp: 'stephaneducasse 2/4/2006 20:47'! installSnapshot: aSnapshot | patch | patch := aSnapshot patchRelativeToBase: MCSnapshot empty. patch applyTo: self. ! ! !MCPackageLoader methodsFor: 'public' stamp: 'Igor.Stasenko 10/1/2010 20:32'! load self analyze. unloadableDefinitions isEmpty ifFalse: [self warnAboutDependencies]. self useNewChangeSetDuring: [self basicLoad]. MCMethodDefinition cachedDefinitions finalizeValues.! ! !MCPackageLoader methodsFor: 'public' stamp: 'nk 8/30/2004 08:39'! loadWithNameLike: baseName self analyze. unloadableDefinitions isEmpty ifFalse: [self warnAboutDependencies]. self useNewChangeSetNamedLike: baseName during: [self basicLoad]! ! !MCPackageLoader methodsFor: 'public' stamp: 'nk 2/23/2005 07:51'! loadWithName: baseName self analyze. unloadableDefinitions isEmpty ifFalse: [self warnAboutDependencies]. self useChangeSetNamed: baseName during: [self basicLoad]! ! !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: '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: '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: 'StephaneDucasse 9/13/2009 18:17'! basicLoad errorDefinitions := OrderedCollection new. [[ "FIXME. Do a separate pass on loading class definitions as the very first thing. This is a workaround for a problem with the so-called 'atomic' loading (you wish!!) which isn't atomic at all but mixes compilation of methods with reshapes of classes. Since the method is not installed until later, any class reshape in the middle *will* affect methods in subclasses that have been compiled before. There is probably a better way of dealing with this by ensuring that the sort order of the definition lists superclass definitions before methods for subclasses but I need this NOW, and adding an extra pass ensures that methods are compiled against their new class definitions." additions do: [:ea | self loadClassDefinition: ea] displayingProgress: 'Loading classes...'. additions do: [:ea | self tryToLoad: ea] displayingProgress: 'Compiling methods...'. removals do: [:ea | ea unload] displayingProgress: 'Cleaning up...'. self shouldWarnAboutErrors ifTrue: [self warnAboutErrors]. errorDefinitions do: [:ea | ea addMethodAdditionTo: methodAdditions] displayingProgress: 'Reloading...'. methodAdditions do: [:each | each installMethod]. methodAdditions do: [:each | each notifyObservers]. additions do: [:ea | ea postloadOver: (self obsoletionFor: ea)] displayingProgress: 'Initializing...'] on: InMidstOfFileinNotification do: [:n | n resume: true]] ensure: [self flushChangesFile]! ! !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: '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: '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: '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: 'StephaneDucasse 9/13/2009 18:17'! loadClassDefinition: aDefinition [aDefinition isClassDefinition ifTrue:[aDefinition load]] on: Error do: [errorDefinitions add: aDefinition].! ! !MCPackageLoader methodsFor: 'private' stamp: 'avi 2/17/2004 13:15'! obsoletionFor: aDefinition ^ obsoletions at: aDefinition ifAbsent: [nil]! ! !MCPackageLoader methodsFor: 'private' stamp: 'ab 5/25/2003 01:19'! orderDefinitionsForLoading: aCollection ^ (self sorterForItems: aCollection) orderedItems! ! !MCPackageLoader methodsFor: 'private' stamp: 'ab 5/24/2003 16:52'! orderedAdditions ^ additions! ! !MCPackageLoader methodsFor: 'private' stamp: 'NicoPaez 10/1/2010 10:33'! provisions ^ provisions ifNil: [provisions := Set withAll: Smalltalk globals keys]! ! !MCPackageLoader methodsFor: 'private' stamp: 'AlainPlantec 1/7/2010 22:20'! shouldWarnAboutErrors ^ errorDefinitions isEmpty not and: [false "should make this a setting ?"]! ! !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: 'StephaneDucasse 9/13/2009 18:16'! tryToLoad: aDefinition [aDefinition addMethodAdditionTo: methodAdditions] on: Error do: [errorDefinitions add: aDefinition].! ! !MCPackageLoader methodsFor: 'private' stamp: 'MarcusDenker 3/28/2011 18:13'! 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 value] ensure: [ChangeSet newChanges: oldChanges]. ! ! !MCPackageLoader methodsFor: 'private' stamp: 'nk 8/30/2004 08:38'! useNewChangeSetDuring: aBlock ^self useNewChangeSetNamedLike: 'MC' during: aBlock! ! !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: 'ab 5/25/2003 01:22'! warnAboutDependencies self notify: self dependencyWarning! ! !MCPackageLoader methodsFor: 'private' stamp: 'avi 1/24/2004 17:42'! warnAboutErrors self notify: self errorDefinitionWarning. ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCPackageLoader class instanceVariableNames: ''! !MCPackageLoader class methodsFor: 'as yet unclassified' stamp: 'ab 7/6/2003 23:30'! installSnapshot: aSnapshot self new installSnapshot: aSnapshot; load! ! !MCPackageLoader class methodsFor: 'as yet unclassified' stamp: 'bf 12/5/2004 12:00'! unloadPackage: aPackage self new unloadPackage: aPackage; loadWithNameLike: aPackage name, '-unload'! ! !MCPackageLoader class methodsFor: 'as yet unclassified' stamp: 'ab 7/7/2003 12:11'! updatePackage: aPackage withSnapshot: aSnapshot self new updatePackage: aPackage withSnapshot: aSnapshot; load! ! Model subclass: #MCPackageManager instanceVariableNames: 'package modified' classVariableNames: 'PrivateAnnouncer' poolDictionaries: '' category: 'Monticello-Versioning'! !MCPackageManager commentStamp: 'StephaneDucasse 4/29/2011 20:42' prior: 0! 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: 'accessing' stamp: 'cwp 11/13/2003 14:12'! modified ^ modified! ! !MCPackageManager methodsFor: 'accessing' stamp: 'GuillermoPolito 7/31/2012 11:46'! modified: aBoolean modified = aBoolean ifTrue: [ ^ self ]. modified := aBoolean. self changed: #modified. self class changed: (Array with: #modified with: self). modified ifFalse: [ Smalltalk logChange: '"' , self packageName , '"' ]. self announcer announce: (MCPackageModified package: self package) ! ! !MCPackageManager methodsFor: 'accessing' stamp: 'ab 7/7/2003 16:47'! package ^ package! ! !MCPackageManager methodsFor: 'accessing' stamp: 'EstebanLorenzano 9/14/2012 11:32'! packageInfo self deprecated: 'Use #packageSet' on: '14 September 2012' in: '2.0'. ^ package packageInfo! ! !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: '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: 'initialization' stamp: 'stephaneducasse 2/4/2006 20:47'! initializeWithPackage: aPackage package := aPackage. self initialize.! ! !MCPackageManager methodsFor: 'operations' stamp: 'EstebanLorenzano 10/17/2012 17:00'! unregister self class registry removeKey: package. self class changed: (Array with: #unregistered with: package). self announcer announce: (MCWorkingCopyDeleted workingCopy: self package: package)! ! !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 class instanceVariableNames: 'registry'! !MCPackageManager class methodsFor: '*rpackage-systemintegration' stamp: 'CamilleTeruel 7/29/2012 18:45'! unregisterForNotifications SystemAnnouncer uniqueInstance unsubscribe: self! ! !MCPackageManager class methodsFor: 'accessing' stamp: 'ab 3/31/2003 20:45'! allManagers ^ self registry values! ! !MCPackageManager class methodsFor: 'accessing' stamp: 'EstebanLorenzano 5/21/2012 17:34'! forPackage: aPackage ^ self registry at: aPackage ifAbsent: [|mgr| mgr := self new initializeWithPackage: aPackage. self registry at: aPackage put: mgr. self changed: (Array with: #registered with: aPackage). self announcer announce: (MCWorkingCopyCreated workingCopy: mgr package: aPackage). mgr]! ! !MCPackageManager class methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! registry ^ registry ifNil: [registry := Dictionary new]! ! !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: 'event registration' stamp: 'EstebanLorenzano 2/18/2013 17:42'! registerInterestOnSystemChangesOnAnnouncer: anAnnouncer anAnnouncer on: ClassAdded, ClassModifiedClassDefinition, ClassRenamed, ClassCommented send: #classModified: to: self. anAnnouncer on: ClassRepackaged send: #classMoved: to: self. anAnnouncer on: ClassRemoved send: #classRemoved: to: self. anAnnouncer on: MethodAdded, MethodModified send: #methodModified: to: self. anAnnouncer on: MethodRepackaged send: #methodMoved: to: self. anAnnouncer on: MethodRemoved send: #methodRemoved: to: self.! ! !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:51'! classModified: anEvent self managersForClass: anEvent classAffected do:[:mgr| mgr modified: true].! ! !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: 'system changes' stamp: 'EstebanLorenzano 2/18/2013 17:53'! 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 ] ]! ! !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: '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: '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: '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: '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: '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: '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 8/3/2012 14:15'! methodRemoved: anEvent self managersForClass: anEvent methodClass category: anEvent protocol do:[:mgr| mgr modified: true]. ! ! !MCPackageManager class methodsFor: 'private' stamp: 'EstebanLorenzano 8/3/2012 14:29'! announcer ^PrivateAnnouncer ifNil: [ SystemAnnouncer uniqueInstance ]! ! !MCPackageManager class methodsFor: 'private' stamp: 'EstebanLorenzano 5/21/2012 17:33'! announcer: anAnnouncer PrivateAnnouncer := anAnnouncer! ! Announcement subclass: #MCPackageModified instanceVariableNames: 'package' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Announcements'! !MCPackageModified commentStamp: '' prior: 0! An MCPackageModified is raised when a MCPackage is modified! !MCPackageModified methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/14/2011 13:49'! package ^ package! ! !MCPackageModified methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/14/2011 13:49'! package: anObject package := anObject! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCPackageModified class instanceVariableNames: ''! !MCPackageModified class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 4/14/2011 13:52'! package: aMCPackage ^ self new package: aMCPackage! ! MCTestCase subclass: #MCPackageTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Monticello'! !MCPackageTest methodsFor: 'running' stamp: 'GuillermoPolito 8/24/2012 14:36'! setUp "here we have to make sure that there is no packae named Monticellomock left, so that no old package interfer with the test." " MCWorkingCopy registry removeKey: (MCPackage new name: 'MonticelloMocks') ifAbsent:[]. PackageOrganizer default unregisterPackageNamed: 'MonticelloMocks'."! ! !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"! ! !MCPackageTest methodsFor: 'tests' stamp: 'lr 3/14/2010 21:13'! testUnload | mock | self mockPackage unload. self deny: (Smalltalk hasClassNamed: #MCMockClassA). self deny: (MCSnapshotTest includesSelector: #mockClassExtension). mock := Smalltalk globals at: #MCMock. self assert: (mock subclasses detect: [ :c | c name = #MCMockClassA ] ifNone: [ ]) isNil! ! Object subclass: #MCPatch instanceVariableNames: 'operations' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Patching'! !MCPatch commentStamp: 'StephaneDucasse 6/24/2011 14:11' prior: 0! I represent a set of patch operations which can be applied by sending message applyTo: to my instances. ! !MCPatch methodsFor: '*MonticelloGUI' stamp: 'BenjaminVanRyseghem 2/8/2012 17:10'! browse ^ (MCPatchBrowser forPatch: self) show! ! !MCPatch methodsFor: 'accessing' stamp: 'CamilloBruni 9/28/2011 17:27'! hasConflict ^ self operations anySatisfy: [ :change| change isConflict ]! ! !MCPatch methodsFor: 'accessing' stamp: 'ab 5/13/2003 12:18'! operations ^ operations! ! !MCPatch methodsFor: 'applying' stamp: 'ab 5/24/2003 16:12'! applyTo: anObject operations do: [:ea | ea applyTo: anObject]. ! ! !MCPatch methodsFor: 'intializing' stamp: 'stephaneducasse 2/4/2006 20:47'! 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: 'querying' stamp: 'cwp 6/9/2003 11:53'! isEmpty ^ operations isEmpty! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCPatch class instanceVariableNames: ''! !MCPatch class methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 15:49'! fromBase: baseSnapshot target: targetSnapshot ^ self new initializeWithBase: baseSnapshot target: targetSnapshot! ! !MCPatch class methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 15:50'! operations: aCollection ^ self basicNew initializeWithOperations: aCollection! ! MCCodeTool subclass: #MCPatchBrowser instanceVariableNames: 'selection' classVariableNames: '' poolDictionaries: '' category: 'MonticelloGUI'! !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: '*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: 'accessing' stamp: 'nk 11/10/2003 21:41'! annotations ^selection ifNil: [ super annotations ] ifNotNil: [ selection annotations ]! ! !MCPatchBrowser methodsFor: 'accessing' stamp: 'ab 7/16/2003 14:36'! items ^ items! ! !MCPatchBrowser methodsFor: 'accessing' stamp: 'ab 7/16/2003 14:39'! list ^ self items collect: [:ea | ea summary]! ! !MCPatchBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! patch: aPatch items := aPatch operations asSortedCollection! ! !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: 'testing' stamp: 'cwp 11/27/2002 09:30'! isModification ^ false! ! !MCPatchOperation methodsFor: 'testing' stamp: 'StephaneDucasse 6/24/2011 14:56'! isRemoteNewer ^ self localDefinition fullTimeStamp < self remoteDefinition fullTimeStamp! ! !MCPatchOperation methodsFor: 'testing' stamp: 'cwp 11/27/2002 09:30'! isRemoval ^ false! ! !MCPatchOperation methodsFor: 'testing' stamp: 'StephaneDucasse 6/24/2011 15:07'! isResolved ^ isConflict and: [ isApplicable notNil ]! ! !MCPatchOperation methodsFor: 'testing' stamp: 'StephaneDucasse 6/24/2011 14:57'! localChosen ^ isApplicable == false ! ! !MCPatchOperation methodsFor: 'testing' stamp: 'StephaneDucasse 6/24/2011 14:57'! localDefinition ^ self baseDefinition! ! !MCPatchOperation methodsFor: 'testing' stamp: 'IgorStasenko 6/24/2011 17:28'! remoteChosen ^ isApplicable ~~ false! ! MCTestCase subclass: #MCPatchTest instanceVariableNames: 'patch' classVariableNames: '' poolDictionaries: '' category: 'Tests-Monticello'! !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. ! ! Object subclass: #MCPatcher instanceVariableNames: 'definitions' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Patching'! !MCPatcher commentStamp: 'LaurentLaffont 3/31/2011 21:05' prior: 0! 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: 'as yet unclassified' stamp: 'ab 6/2/2003 00:46'! addDefinition: aDefinition definitions add: aDefinition! ! !MCPatcher methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! initializeWithSnapshot: aSnapshot definitions := MCDefinitionIndex definitions: aSnapshot definitions! ! !MCPatcher methodsFor: 'as yet unclassified' stamp: 'ab 6/1/2003 14:23'! modifyDefinition: baseDefinition to: targetDefinition self addDefinition: targetDefinition! ! !MCPatcher methodsFor: 'as yet unclassified' stamp: 'ab 7/6/2003 23:48'! patchedSnapshot ^ MCSnapshot fromDefinitions: definitions definitions! ! !MCPatcher methodsFor: 'as yet unclassified' stamp: 'ab 6/2/2003 00:46'! removeDefinition: aDefinition definitions remove: aDefinition! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCPatcher class instanceVariableNames: ''! !MCPatcher class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! apply: aPatch to: aSnapshot | loader | loader := self snapshot: aSnapshot. aPatch applyTo: loader. ^ loader patchedSnapshot! ! !MCPatcher class methodsFor: 'as yet unclassified' stamp: 'ab 6/1/2003 14:22'! snapshot: aSnapshot ^ self new initializeWithSnapshot: aSnapshot! ! MCVariableDefinition subclass: #MCPoolImportDefinition instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Modeling'! !MCPoolImportDefinition commentStamp: '' prior: 0! A MCPoolImportDefinition represents a pool definition.! !MCPoolImportDefinition methodsFor: 'testing' stamp: 'bf 8/29/2006 11:41'! isOrderDependend ^false! ! !MCPoolImportDefinition methodsFor: 'testing' stamp: 'cwp 7/7/2003 23:51'! isPoolImport ^ true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCPoolImportDefinition class instanceVariableNames: ''! !MCPoolImportDefinition class methodsFor: 'as yet unclassified' stamp: 'cwp 7/7/2003 22:59'! type ^ #pool! ! MCScriptDefinition subclass: #MCPostscriptDefinition instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Modeling'! !MCPostscriptDefinition methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:16'! postload self evaluate! ! !MCPostscriptDefinition methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:16'! sortKey ^ 'zzz' "force to the end so it gets loaded late"! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCPostscriptDefinition class instanceVariableNames: ''! !MCPostscriptDefinition class methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:04'! scriptSelector ^ #postscript! ! MCScriptDefinition subclass: #MCPreambleDefinition instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Modeling'! !MCPreambleDefinition methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:15'! load super load. self evaluate! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCPreambleDefinition class instanceVariableNames: ''! !MCPreambleDefinition class methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:04'! scriptSelector ^ #preamble! ! RWBinaryOrTextStream subclass: #MCPseudoFileStream instanceVariableNames: 'localName' classVariableNames: '' poolDictionaries: '' category: 'MonticelloConfigurations'! !MCPseudoFileStream commentStamp: '' prior: 0! A pseudo file stream which can be used for updates.! !MCPseudoFileStream methodsFor: 'accessing' stamp: 'ar 4/14/2005 19:54'! localName ^localName! ! !MCPseudoFileStream methodsFor: 'accessing' stamp: 'ar 4/14/2005 19:54'! localName: aString localName := aString! ! Object subclass: #MCReader instanceVariableNames: 'stream' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Storing'! !MCReader methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! stream: aStream stream := aStream! ! !MCReader methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 4/24/2012 15:49'! stream stream closed ifTrue: [ stream open ]. ^ stream ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCReader class instanceVariableNames: ''! !MCReader class methodsFor: 'instance creation' stamp: 'avi 1/21/2004 19:02'! on: aStream ^ self new 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: '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'! concreteSubclasses ^ self allSubclasses reject: [:c | c isAbstract]! ! !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]! ! MCPatchOperation subclass: #MCRemoval instanceVariableNames: 'definition' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Patching'! !MCRemoval commentStamp: '' prior: 0! A MCRemoval represents the removal of an entity of a given snapshot.! !MCRemoval methodsFor: 'accessing' stamp: 'ab 6/1/2003 13:10'! baseDefinition ^ definition! ! !MCRemoval methodsFor: 'accessing' stamp: 'StephaneDucasse 6/24/2011 14:53'! basicApplyTo: anObject anObject removeDefinition: definition! ! !MCRemoval methodsFor: 'accessing' stamp: 'cwp 11/27/2002 10:02'! definition ^ definition! ! !MCRemoval methodsFor: 'accessing' stamp: 'ab 7/18/2003 16:44'! fromSource ^ definition source! ! !MCRemoval methodsFor: 'accessing' stamp: 'ab 8/22/2003 02:26'! inverse ^ MCAddition of: definition! ! !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: 'ab 7/6/2003 00:05'! summarySuffix ^ ' (removed)'! ! !MCRemoval methodsFor: 'accessing' stamp: 'nk 2/25/2005 17:23'! targetClass ^ definition actualClass! ! !MCRemoval methodsFor: 'accessing' stamp: 'ab 6/1/2003 13:10'! targetDefinition ^ nil! ! !MCRemoval methodsFor: 'accessing' stamp: 'ab 7/18/2003 16:44'! toSource ^ ''! ! !MCRemoval methodsFor: 'initializing' stamp: 'stephaneducasse 2/4/2006 20:47'! intializeWithDefinition: aDefinition definition := aDefinition! ! !MCRemoval methodsFor: 'testing' stamp: 'nk 2/25/2005 17:28'! isClassPatch ^definition isClassDefinition! ! !MCRemoval methodsFor: 'testing' stamp: 'cwp 11/28/2002 07:24'! isRemoval ^ true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCRemoval class instanceVariableNames: ''! !MCRemoval class methodsFor: 'as yet unclassified' stamp: 'cwp 11/27/2002 10:03'! of: aDefinition ^ self new intializeWithDefinition: aDefinition! ! MCScriptDefinition subclass: #MCRemovalPostscriptDefinition instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Modeling'! !MCRemovalPostscriptDefinition methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:15'! unload super unload. self evaluate! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCRemovalPostscriptDefinition class instanceVariableNames: ''! !MCRemovalPostscriptDefinition class methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:04'! scriptSelector ^ #postscriptOfRemoval ! ! MCScriptDefinition subclass: #MCRemovalPreambleDefinition instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Modeling'! !MCRemovalPreambleDefinition methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:14'! sortKey ^ 'zzz' "force to the end so it gets unloaded early"! ! !MCRemovalPreambleDefinition methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:15'! unload super unload. self evaluate! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCRemovalPreambleDefinition class instanceVariableNames: ''! !MCRemovalPreambleDefinition class methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:04'! scriptSelector ^ #preambleOfRemoval! ! Object subclass: #MCRepository instanceVariableNames: 'creationTemplate storeDiffs' classVariableNames: 'Settings' poolDictionaries: '' category: 'Monticello-Repositories'! !MCRepository methodsFor: '*MonticelloGUI' stamp: 'lr 9/26/2003 20:03'! morphicOpen self morphicOpen: nil! ! !MCRepository methodsFor: '*MonticelloGUI' stamp: 'lr 9/26/2003 20:03'! morphicOpen: aWorkingCopy self subclassResponsibility ! ! !MCRepository methodsFor: '*MonticelloGUI' stamp: 'bf 4/14/2005 17:30'! openAndEditTemplateCopy ^ self class fillInTheBlankConfigure: (self asCreationTemplate ifNil: [^nil])! ! !MCRepository methodsFor: '*gofer-core-accessing' stamp: 'lr 12/11/2009 22:31'! goferPriority ^ 0! ! !MCRepository methodsFor: '*gofer-core-accessing' stamp: 'lr 12/9/2009 20:50'! goferReferences ^ #()! ! !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: 'DaleHenrichs 3/5/2010 14:37'! asRepositorySpecFor: aMetacelloMCProject self subclassResponsibility! ! !MCRepository methodsFor: 'as yet unclassified' stamp: 'avi 8/31/2004 01:08'! alwaysStoreDiffs ^ storeDiffs ifNil: [false]! ! !MCRepository methodsFor: 'as yet unclassified' stamp: 'bkv 2/18/2004 20:48'! asCreationTemplate ^ self creationTemplate! ! !MCRepository methodsFor: 'as yet unclassified' stamp: 'avi 8/26/2004 14:20'! basicStoreVersion: aVersion self subclassResponsibility! ! !MCRepository methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'bkv 2/18/2004 20:46'! creationTemplate ^ creationTemplate! ! !MCRepository methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'avi 10/9/2003 12:53'! description ^ self class name! ! !MCRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! doAlwaysStoreDiffs storeDiffs := true! ! !MCRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! doNotAlwaysStoreDiffs storeDiffs := false! ! !MCRepository methodsFor: 'as yet unclassified' stamp: 'ab 8/21/2003 12:36'! hash ^ self description hash! ! !MCRepository methodsFor: 'as yet unclassified' stamp: 'avi 8/26/2004 14:27'! notificationForVersion: aVersion ^ MCVersionNotification version: aVersion repository: self! ! !MCRepository methodsFor: 'as yet unclassified' stamp: 'avi 8/26/2004 14:23'! notifyList ^ #()! ! !MCRepository methodsFor: 'as yet unclassified' stamp: 'bf 3/10/2005 23:01'! possiblyNewerVersionsOfAnyOf: someVersions ^#()! ! !MCRepository methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 4/21/2012 21:12'! prepareVersionForStorage: aVersion ^ self alwaysStoreDiffs ifTrue: [ aVersion asDiffAgainst: (self closestAncestorVersionFor: aVersion info ifNone: [^ aVersion])] ifFalse: [ aVersion ]! ! !MCRepository methodsFor: 'as yet unclassified' stamp: 'mas 9/24/2003 04:21'! printOn: aStream super printOn: aStream. aStream nextPut: $(; nextPutAll: self description; nextPut: $).! ! !MCRepository methodsFor: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'CamilloBruni 4/22/2012 21:11'! storeVersion: aVersion self basicStoreVersion: (self prepareVersionForStorage: aVersion). self sendNotificationsForVersion: aVersion! ! !MCRepository methodsFor: 'as yet unclassified' stamp: 'ab 8/21/2003 12:36'! = other ^ other species = self species and: [other description = self description]! ! !MCRepository methodsFor: 'interface' stamp: 'ab 8/21/2003 12:40'! includesVersionNamed: aString self subclassResponsibility! ! !MCRepository methodsFor: 'interface' stamp: 'avi 10/9/2003 12:42'! versionWithInfo: aVersionInfo ^ self versionWithInfo: aVersionInfo ifAbsent: [nil]! ! !MCRepository methodsFor: 'interface' stamp: 'ab 8/16/2003 18:22'! versionWithInfo: aVersionInfo ifAbsent: aBlock self subclassResponsibility ! ! !MCRepository methodsFor: 'testing' stamp: 'nk 11/2/2003 10:55'! isValid ^true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCRepository class instanceVariableNames: ''! !MCRepository class methodsFor: '*MonticelloGUI' stamp: 'bkv 2/18/2004 21:05'! fillInTheBlankConfigure ^ self fillInTheBlankConfigure: self creationTemplate ! ! !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: 'as yet unclassified' stamp: 'ab 8/21/2003 00:30'! allConcreteSubclasses ^ self withAllSubclasses reject: [:ea | ea isAbstract]! ! !MCRepository class methodsFor: 'as yet unclassified' stamp: 'bkv 2/18/2004 20:59'! creationTemplate self subclassResponsibility.! ! !MCRepository class methodsFor: 'as yet unclassified' stamp: 'ab 8/21/2003 00:29'! description ^ nil! ! !MCRepository class methodsFor: 'as yet unclassified' stamp: 'bkv 2/18/2004 20:58'! fillInTheBlankRequest self subclassResponsibility.! ! !MCRepository class methodsFor: 'as yet unclassified' stamp: 'ab 8/21/2003 12:59'! isAbstract ^ self description isNil! ! !MCRepository class methodsFor: 'as yet unclassified' stamp: 'ab 7/24/2003 21:01'! morphicConfigure ^ self new! ! TestCase subclass: #MCRepositoryAuthorizationTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Monticello'! !MCRepositoryAuthorizationTest methodsFor: 'accessing' stamp: 'SeanDeNigris 8/27/2012 10:13'! exampleServerUrl ^ 'http://www.squeaksource.com'.! ! !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: '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: ''.! ! !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'! 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: '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 ].! ! Error subclass: #MCRepositoryError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Repositories'! !MCRepositoryError commentStamp: '' prior: 0! I am an MC-specific errror! Object subclass: #MCRepositoryGroup instanceVariableNames: 'repositories useCache' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Versioning'! !MCRepositoryGroup commentStamp: '' prior: 0! A singleton class, holds the list of repositories. Can look for a requested VersionInfo among its repositories.! !MCRepositoryGroup methodsFor: 'as yet unclassified' stamp: 'SeanDeNigris 7/17/2012 15:42'! addRepository: aRepository ((repositories includes: aRepository) or: [aRepository == MCCacheRepository uniqueInstance]) ifFalse: [repositories add: aRepository. self class default addRepository: aRepository]. self changed: (Array with: #added with: aRepository). ^ aRepository! ! !MCRepositoryGroup methodsFor: 'as yet unclassified' stamp: 'NorbertHartl 6/20/2008 10:11'! disableCache useCache := false! ! !MCRepositoryGroup methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 4/22/2012 21:07'! includesVersionNamed: aString " check for existing version name in parallel over all repositories " | resultSemaphore results | resultSemaphore := Semaphore new. results := Array new: self repositories size. self repositories doWithIndex: [:repository :index | " fork of test for each repository " [[ results at: index put: (repository includesVersionNamed: aString) ] ensure: [ resultSemaphore signal ]] fork ]. " wait for all requests to finish " self repositories size timesRepeat: [ resultSemaphore wait ]. " check if any repository included the given versionName already" ^ results anySatisfy: [:result| result = true ] ! ! !MCRepositoryGroup methodsFor: 'as yet unclassified' stamp: 'avi 11/7/2003 00:20'! includes: aRepository ^ self repositories includes: aRepository! ! !MCRepositoryGroup methodsFor: 'as yet unclassified' stamp: 'alain.plantec 5/28/2009 10:03'! initialize super initialize. repositories := OrderedCollection new! ! !MCRepositoryGroup methodsFor: 'as yet unclassified' stamp: 'sd 3/15/2008 17:33'! 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]). self changed: #repositories! ! !MCRepositoryGroup methodsFor: 'as yet unclassified' stamp: 'lr 5/9/2010 19:04'! removeRepository: aRepository repositories remove: aRepository ifAbsent: []. self changed: (Array with: #removed with: aRepository)! ! !MCRepositoryGroup methodsFor: 'as yet unclassified' stamp: 'SeanDeNigris 7/17/2012 15:42'! repositories ^ (self useCache ifTrue: [Array with: MCCacheRepository uniqueInstance] ifFalse: [Array new]) , repositories select: #isValid! ! !MCRepositoryGroup methodsFor: 'as yet unclassified' stamp: 'avi 11/7/2003 00:51'! repositoriesDo: aBlock self repositories do: [:ea | [aBlock value: ea] on: Error do: []]! ! !MCRepositoryGroup methodsFor: 'as yet unclassified' stamp: 'abc 6/20/2008 10:02'! useCache ^ useCache ifNil: [ useCache := true ]! ! !MCRepositoryGroup methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'marcus.denker 11/10/2008 10:04'! versionWithInfo: aVersionInfo ifNone: aBlock self repositoriesDo: [:ea | (ea versionWithInfo: aVersionInfo) ifNotNil: [:v | ^ v]]. ^aBlock value! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCRepositoryGroup class instanceVariableNames: 'default'! !MCRepositoryGroup class methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! default ^ default ifNil: [default := self new]! ! MCVersionInspector subclass: #MCRepositoryInspector instanceVariableNames: 'repository packages versions loaded selectedPackage selectedVersion' classVariableNames: '' poolDictionaries: '' category: 'MonticelloGUI'! !MCRepositoryInspector methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 20:20'! hasVersion ^ selectedVersion notNil! ! !MCRepositoryInspector methodsFor: 'as yet unclassified' stamp: 'avi 9/17/2005 17:11'! load self hasVersion ifTrue: [super load. self version workingCopy repositoryGroup addRepository: repository].! ! !MCRepositoryInspector methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! refresh packages := repository packages. self changed: #packageList. self packageSelection: self packageSelection. ! ! !MCRepositoryInspector methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! setRepository: aRepository workingCopy: aWorkingCopy repository := aRepository. aWorkingCopy isNil ifFalse: [ selectedPackage := aWorkingCopy package]. self refresh! ! !MCRepositoryInspector methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2004 20:20'! summary ^ selectedVersion ifNotNil: [selectedVersion summary] ifNil: ['']! ! !MCRepositoryInspector methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! version ^ version ifNil: [version := repository versionWithInfo: selectedVersion]! ! !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'! defaultExtent ^450@300! ! !MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 2/28/2004 18:51'! defaultLabel ^'Repository: ' , repository description! ! !MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 2/28/2004 20:09'! packageList ^ packages collect: [:ea | ea name]! ! !MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 2/28/2004 18:51'! packageListMenu: aMenu ^aMenu! ! !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'! packageSelection: aNumber selectedPackage := aNumber isZero ifFalse: [ packages at: aNumber ]. versions := repository versionsAvailableForPackage: selectedPackage. self changed: #packageSelection; changed: #versionList! ! !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: 'avi 2/29/2004 11:32'! versionList ^ self sortedVersions collect: [:ea | ea name]! ! !MCRepositoryInspector methodsFor: 'morphic ui' stamp: 'avi 2/28/2004 18:57'! versionListMenu: aMenu ^aMenu! ! !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'! 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'! 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 class instanceVariableNames: ''! !MCRepositoryInspector class methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 4/24/2012 14:51'! repository: aFileBasedRepository workingCopy: aWorkingCopy ^self new setRepository: aFileBasedRepository workingCopy: aWorkingCopy; yourself! ! MCTestCase subclass: #MCRepositoryTest instanceVariableNames: 'repository ancestors' classVariableNames: '' poolDictionaries: '' category: 'Tests-Monticello'! !MCRepositoryTest methodsFor: 'accessing' stamp: 'ab 7/7/2003 14:32'! snapshotAt: aVersionInfo ^ (repository versionWithInfo: aVersionInfo) snapshot! ! !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: '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: 'actions' stamp: 'ab 7/19/2003 16:20'! saveSnapshot2 ^ self saveSnapshot: self snapshot2 named: 'rev2'! ! !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 7/19/2003 23:59'! assertMissing: aVersionInfo self assert: (repository versionWithInfo: aVersionInfo) isNil! ! !MCRepositoryTest methodsFor: 'asserting' stamp: 'ab 8/16/2003 18:07'! assertVersionInfos: aCollection self assert: repository allVersionInfos asSet = aCollection asSet! ! !MCRepositoryTest methodsFor: 'building' stamp: 'ab 7/10/2003 01:03'! snapshot1 ^ (MCSnapshot fromDefinitions: (Array with: (MCOrganizationDefinition categories: #('y'))))! ! !MCRepositoryTest methodsFor: 'building' stamp: 'ab 7/10/2003 01:03'! snapshot2 ^ (MCSnapshot fromDefinitions: (Array with: (MCOrganizationDefinition categories: #('x'))))! ! !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: '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: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! testLoadMissingNode | node | node := MCVersionInfo new. self assertMissing: node! ! !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 instanceVariableNames: ''! !MCRepositoryTest class methodsFor: 'testing' stamp: 'ab 7/6/2003 12:45'! isAbstract ^ self = MCRepositoryTest! ! MCTool subclass: #MCSaveVersionDialog instanceVariableNames: 'name message' classVariableNames: 'PreviousMessages' poolDictionaries: '' category: 'MonticelloGUI'! !MCSaveVersionDialog commentStamp: 'ab 9/8/2009 08:24' prior: 0! 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:41'! logMessage ^ message ifNil: ['empty log message']! ! !MCSaveVersionDialog methodsFor: 'accessing' stamp: 'AlexandreBergel 8/1/2008 12:18'! logMessage: aString message := aString. self changed: #logMessage! ! !MCSaveVersionDialog methodsFor: 'accessing' stamp: 'ab 8/24/2003 20:37'! versionName ^ name! ! !MCSaveVersionDialog methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! versionName: aString name := aString. self changed: #versionName! ! !MCSaveVersionDialog methodsFor: 'log message history' stamp: 'ab 9/8/2009 08:26'! 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 methodsFor: 'log message history' stamp: 'ab 9/8/2009 08:25'! maxLogMessageHistory ^ 15! ! !MCSaveVersionDialog methodsFor: 'log message history' stamp: 'ab 9/8/2009 08:16'! previousMessages PreviousMessages ifNil: [ PreviousMessages := OrderedCollection new]. ^ 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: '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: 'morphic ui' stamp: 'ab 9/8/2009 08:58'! defaultLabel ^ 'Edit Version Name and Log Message:'! ! !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: 'CamilloBruni 2/4/2012 12:39'! setDefaultFocus (self findTextMorph: #logMessage) takeKeyboardFocus; selectAll; acceptAction: [ :contents| TextEditorDialogWindow autoAccept ifTrue: [ self accept ]].! ! !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 class instanceVariableNames: ''! !MCSaveVersionDialog class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'FernandoOlivero 4/12/2011 09:47'! taskbarIcon "Answer the icon for the receiver in a task bar." ^self theme smallSaveAsIcon! ! Object subclass: #MCScanner instanceVariableNames: 'stream' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Chunk Format'! !MCScanner commentStamp: 'LaurentLaffont 3/31/2011 21:08' prior: 0! 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: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! stream: aStream stream := aStream! ! !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 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: '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 class instanceVariableNames: ''! !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)! ! MCTestCase subclass: #MCScannerTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Monticello'! !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:19'! test1 self assertScans: #(a '23' (x))! ! !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:23'! test4 self assertScans: #(a '23' (x () ')''q' y12)).! ! !MCScannerTest methodsFor: 'tests' stamp: 'avi 1/22/2004 20:26'! test5 self assertScans: #((a) b)! ! !MCScannerTest methodsFor: 'tests' stamp: 'avi 1/22/2004 20:28'! test6 self should: [MCScanner scan: '(a b' readStream] raise: Error! ! MCDefinition subclass: #MCScriptDefinition instanceVariableNames: 'script packageName' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Modeling'! !MCScriptDefinition methodsFor: 'accessing' stamp: 'avi 2/28/2005 17:12'! description ^ Array with: packageName with: self scriptSelector! ! !MCScriptDefinition methodsFor: 'accessing' 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: 'bf 8/13/2009 00:09'! packageName ^ packageName! ! !MCScriptDefinition methodsFor: 'accessing' stamp: 'EstebanLorenzano 9/11/2012 17:01'! packageSet ^ RPackageSet named: packageName! ! !MCScriptDefinition methodsFor: 'accessing' stamp: 'avi 2/28/2005 16:54'! script ^ script! ! !MCScriptDefinition methodsFor: 'accessing' stamp: 'avi 2/28/2005 17:10'! scriptSelector ^ self class scriptSelector! ! !MCScriptDefinition methodsFor: 'accessing' stamp: 'bf 10/25/2005 19:05'! sortKey ^ '!!', self scriptSelector "force to the front so it gets loaded first"! ! !MCScriptDefinition methodsFor: 'accessing' stamp: 'avi 2/28/2005 17:04'! source ^ script! ! !MCScriptDefinition methodsFor: 'accessing' stamp: 'avi 2/28/2005 17:12'! summary ^ packageName, ' ', self scriptSelector! ! !MCScriptDefinition methodsFor: 'comparing' stamp: 'avi 2/28/2005 16:55'! = aDefinition ^ (super = aDefinition) and: [script = aDefinition script]! ! !MCScriptDefinition methodsFor: 'initializing' stamp: 'stephaneducasse 2/4/2006 20:47'! initializeWithScript: aString packageName: packageString script := aString. packageName := packageString! ! !MCScriptDefinition methodsFor: 'installing' stamp: 'jb 7/1/2011 10:52'! evaluate self class evaluatorClass evaluate: script! ! !MCScriptDefinition methodsFor: 'installing' stamp: 'avi 2/28/2005 17:11'! installScript self installScript: script! ! !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: 'installing' stamp: 'avi 2/28/2005 17:12'! load self installScript! ! !MCScriptDefinition methodsFor: 'installing' stamp: 'avi 2/28/2005 17:12'! unload self installScript: nil! ! !MCScriptDefinition methodsFor: 'testing' stamp: 'bf 8/12/2009 22:55'! isScriptDefinition ^true! ! !MCScriptDefinition methodsFor: 'visiting' stamp: 'bf 8/12/2009 21:41'! accept: aVisitor aVisitor visitScriptDefinition: self! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCScriptDefinition class instanceVariableNames: ''! !MCScriptDefinition class methodsFor: 'as yet unclassified' stamp: 'bf 4/4/2005 12:20'! from: aPackageInfo ^ self script: (aPackageInfo perform: self scriptSelector) contents asString packageName: aPackageInfo name! ! !MCScriptDefinition class methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 17:00'! scriptSelector self subclassResponsibility! ! !MCScriptDefinition class methodsFor: 'as yet unclassified' stamp: 'avi 2/28/2005 16:59'! script: aString packageName: packageString ^ self instanceLike: (self new initializeWithScript: aString packageName: packageString)! ! !MCScriptDefinition class methodsFor: 'as yet unclassified' stamp: 'bf 8/13/2009 00:24'! scriptSelector: selectorString script: aString packageName: packageString ^ (self subclassForScriptSelector: selectorString) script: aString packageName: packageString! ! !MCScriptDefinition class methodsFor: 'as yet unclassified' stamp: 'bf 8/13/2009 00:25'! subclassForScriptSelector: selectorString ^self allSubclasses detect: [:ea | ea scriptSelector = selectorString]! ! MCDoItParser subclass: #MCScriptParser instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Chunk Format'! !MCScriptParser commentStamp: '' prior: 0! A MCScriptParser identifies script and add MCScriptDefinition. ! !MCScriptParser methodsFor: 'actions' stamp: 'bf 8/13/2009 00:13'! addDefinitionsTo: aCollection | tokens definition | tokens := Scanner new scanTokens: source. definition := MCScriptDefinition scriptSelector: tokens second allButLast script: tokens third packageName: tokens first third. aCollection add: definition.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCScriptParser class instanceVariableNames: ''! !MCScriptParser class methodsFor: 'factory identification hook' stamp: 'bf 8/13/2009 00:07'! pattern ^'(PackageInfo named: *'! ! MCTestCase subclass: #MCSerializationTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Monticello'! !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.! ! !MCSerializationTest methodsFor: 'asserting' stamp: 'cwp 8/1/2003 14:57'! assertExtensionProvidedBy: aClass self shouldnt: [aClass readerClass extension] raise: Exception.! ! !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: '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: '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: 'avi 1/19/2004 15:14'! testMczSerialization self assertVersionsMatchWith: MCMczWriter. self assertExtensionProvidedBy: MCMczWriter. self assertVersionInfosMatchWith: MCMczWriter. self assertDependenciesMatchWith: MCMczWriter.! ! !MCSerializationTest methodsFor: 'testing' stamp: 'cwp 8/3/2003 18:43'! testStSerialization self assertSnapshotsMatchWith: MCStWriter.! ! Object subclass: #MCServerCredentials instanceVariableNames: 'username password' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Repositories'! !MCServerCredentials methodsFor: 'accessing' stamp: 'SeanDeNigris 8/26/2012 18:33'! password ^ password.! ! !MCServerCredentials methodsFor: 'accessing' stamp: 'SeanDeNigris 8/26/2012 18:33'! username ^ username.! ! !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 class instanceVariableNames: ''! !MCServerCredentials class methodsFor: 'instance creation' stamp: 'SeanDeNigris 8/26/2012 18:24'! user: nameString hasPassword: passwordString ^ self new username: nameString; password: passwordString; yourself.! ! Object subclass: #MCServerRegistry instanceVariableNames: 'registry' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Repositories'! !MCServerRegistry methodsFor: '*Tests-Monticello' stamp: 'SeanDeNigris 8/27/2012 10:02'! removeCredentialsFor: aString registry removeKey: aString.! ! !MCServerRegistry methodsFor: 'as yet unclassified' stamp: 'SeanDeNigris 8/26/2012 11:24'! on: repositoryUrl beUser: nameString withPassword: passwordString | credentials | credentials := MCServerCredentials user: nameString hasPassword: passwordString. registry at: repositoryUrl put: credentials.! ! !MCServerRegistry methodsFor: 'private' 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 class instanceVariableNames: 'uniqueInstance'! !MCServerRegistry class methodsFor: 'instance creation' stamp: 'SeanDeNigris 8/26/2012 11:11'! uniqueInstance ^ uniqueInstance ifNil: [ uniqueInstance := self new ].! ! Model subclass: #MCSliceInfo instanceVariableNames: 'issueNumber issueSummary includedPackages' classVariableNames: '' poolDictionaries: '' category: 'MonticelloGUI'! !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:47'! issueNumber ^ issueNumber 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 02:41'! issueSummary ^ issueSummary ifNil: ['']! ! !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: '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 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! ! Model subclass: #MCSliceMaker instanceVariableNames: 'info window okToDoSlice' classVariableNames: '' poolDictionaries: '' category: 'MonticelloGUI'! !MCSliceMaker commentStamp: 'AlainPlantec 9/27/2011 11:43' prior: 0! 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: 'accessing' stamp: 'AlainPlantec 10/25/2010 00:26'! info ^ info ! ! !MCSliceMaker methodsFor: 'accessing' stamp: 'CamilloBruni 10/17/2012 10:17'! issueIdString ^ self issueNumber asString ! ! !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: 'accessing' stamp: 'AlainPlantec 10/25/2010 02:15'! okToDoSlice ^ okToDoSlice ifNil: [false]! ! !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: 'actions' stamp: 'CamilloBruni 10/17/2012 10:14'! downloadIssueSummary |page pageStream summary| self flag: #TODO "replace by proper use of google API". ZnClient new systemPolicy; setAcceptEncodingGzip; accept: ZnMimeType textHtml; http; host: 'code.google.com'; path: '/p/pharo/issues/detail'; queryAt: 'id' put: self issueIdString; contentReader: [ :entity | page := entity ]; streaming: false; ifFail: [ :exception | self downloadIssueSummaryFailed. ^ self ]; get. pageStream := page readStream. (pageStream match: 'Issue ', self issueIdString,'') ifFalse: [self downloadIssueSummaryFailed]. (pageStream match: '') ifFalse: [self downloadIssueSummaryFailed]. summary := pageStream upTo: $<. self info issueSummary: summary! ! !MCSliceMaker methodsFor: 'actions' stamp: 'DamienCassou 4/27/2012 16:30'! downloadIssueSummaryFailed self info issueSummary: '------'! ! !MCSliceMaker methodsFor: 'initialize-release' stamp: 'AlainPlantec 10/11/2011 11:56'! initialize super initialize. info := MCSliceInfo new. info addDependent: self. ! ! !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: 'selecting' stamp: 'BenjaminVanRyseghem 9/17/2011 19:29'! update: aSymbol aSymbol = #okUnabled ifTrue: [ self changed: #okUnabled ]. super update: aSymbol! ! !MCSliceMaker methodsFor: 'user interface' stamp: 'AlainPlantec 10/25/2010 01:35'! cancel self noSlice. window delete! ! !MCSliceMaker methodsFor: 'user interface' stamp: 'AlainPlantec 10/11/2011 13:32'! initialExtent ^ 800@400! ! !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: '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: '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'! noSlice info := nil. ! ! !MCSliceMaker methodsFor: 'user interface' stamp: 'AlainPlantec 10/25/2010 02:16'! ok self okToDoSlice: true. window delete! ! !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: 'user interface' stamp: 'AlainPlantec 10/11/2011 11:58'! openFor: anotherWindow window := self window. anotherWindow openModal: window. ^ self resultInfo! ! !MCSliceMaker methodsFor: 'user interface' stamp: 'BenjaminVanRyseghem 9/17/2011 19:21'! rootItems ^ (MCWorkingCopy allManagers select: [ :each | each modified ] )! ! !MCSliceMaker methodsFor: 'user interface' stamp: 'StephaneDucasse 12/19/2012 16:46'! 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: #packageName; 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 class instanceVariableNames: ''! !MCSliceMaker class methodsFor: 'opening' stamp: 'AlainPlantec 10/25/2010 02:09'! openFor: anotherWindow ^ self new openFor: anotherWindow! ! MCHttpRepository subclass: #MCSmalltalkhubRepository instanceVariableNames: 'owner project' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Repositories'! !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:24'! locationWithTrailingSlash ^ self location! ! !MCSmalltalkhubRepository methodsFor: 'accessing' stamp: 'CamilloBruni 9/14/2012 17:21'! owner ^ owner! ! !MCSmalltalkhubRepository methodsFor: 'accessing' stamp: 'CamilloBruni 9/18/2012 18:36'! owner: aString owner := aString! ! !MCSmalltalkhubRepository methodsFor: 'accessing' stamp: 'CamilloBruni 9/14/2012 17:21'! project ^ project! ! !MCSmalltalkhubRepository methodsFor: 'accessing' stamp: 'CamilloBruni 9/18/2012 18:36'! project: aString project := aString! ! !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: '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: '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: 'interface' stamp: 'CamilloBruni 9/14/2012 17:25'! loadAllFileNames | client | (client := self httpClient) 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: 'interface' stamp: 'CamilloBruni 10/15/2012 13:36'! parseFileNamesFromStream: aNewLineDelimitedString ^ aNewLineDelimitedString ifNil: [ ^ OrderedCollection new ] ifNotNil: [ aNewLineDelimitedString subStrings: String crlf ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCSmalltalkhubRepository class instanceVariableNames: ''! !MCSmalltalkhubRepository class methodsFor: 'accessing' stamp: 'CamilloBruni 10/21/2012 13:25'! baseURL ^ 'http://smalltalkhub.com/mc/'! ! !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:15'! creationTemplate ^self creationTemplateOwner: '' project: '' user: '' password: '' ! ! !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: '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: '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! ! MCWriteOnlyRepository subclass: #MCSmtpRepository instanceVariableNames: 'email' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Repositories'! !MCSmtpRepository methodsFor: 'as yet unclassified' stamp: 'avi 8/26/2004 14:21'! basicStoreVersion: aVersion MailSender sendMessage: (self messageForVersion: aVersion)! ! !MCSmtpRepository methodsFor: 'as yet unclassified' stamp: 'avi 10/9/2003 13:11'! bodyForVersion: aVersion ^ String streamContents: [ :s | s nextPutAll: 'from version info:'; cr; cr. s nextPutAll: aVersion info summary]! ! !MCSmtpRepository methodsFor: 'as yet unclassified' stamp: 'avi 10/9/2003 12:56'! description ^ 'mailto://', email! ! !MCSmtpRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! emailAddress: aString email := aString ! ! !MCSmtpRepository methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! messageForVersion: aVersion | message data | message := MailMessage empty. message setField: 'from' toString: MailSender userName. message setField: 'to' toString: email. message setField: 'subject' toString: (self subjectForVersion: aVersion). message body: (MIMEDocument contentType: 'text/plain' content: (self bodyForVersion: aVersion)). "Prepare the gzipped data" data := RWBinaryOrTextStream on: String new. aVersion fileOutOn: data. message addAttachmentFrom: data reset withName: aVersion fileName. ^ message! ! !MCSmtpRepository methodsFor: 'as yet unclassified' stamp: 'avi 10/9/2003 13:14'! subjectForVersion: aVersion ^ '[Package] ', aVersion info name! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCSmtpRepository class instanceVariableNames: ''! !MCSmtpRepository class methodsFor: 'as yet unclassified' stamp: 'avi 10/9/2003 12:56'! description ^ 'SMTP'! ! !MCSmtpRepository class methodsFor: 'as yet unclassified' stamp: 'alain.plantec 2/6/2009 17:52'! morphicConfigure | address | address := UIManager default request: 'Email address:' translated. ^ address isEmpty ifFalse: [self new emailAddress: address]! ! Object subclass: #MCSnapshot instanceVariableNames: 'definitions' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Base'! !MCSnapshot commentStamp: '' prior: 0! 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: 'accessing' stamp: 'ab 7/10/2003 01:05'! hash ^ definitions asArray hash! ! !MCSnapshot methodsFor: 'accessing' 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: 'initializing' stamp: 'stephaneducasse 2/4/2006 20:47'! initializeWithDefinitions: aCollection definitions := aCollection.! ! !MCSnapshot methodsFor: 'loading' stamp: 'ab 7/6/2003 23:31'! install MCPackageLoader installSnapshot: self! ! !MCSnapshot methodsFor: 'loading' stamp: 'ab 7/7/2003 12:11'! updatePackage: aPackage MCPackageLoader updatePackage: aPackage withSnapshot: self! ! !MCSnapshot methodsFor: 'patching' stamp: 'ab 7/7/2003 00:37'! patchRelativeToBase: aSnapshot ^ MCPatch fromBase: aSnapshot target: self! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCSnapshot class instanceVariableNames: ''! !MCSnapshot class methodsFor: 'as yet unclassified' stamp: 'ab 7/6/2003 23:48'! empty ^ self fromDefinitions: #()! ! !MCSnapshot class methodsFor: 'as yet unclassified' stamp: 'ab 7/6/2003 23:48'! fromDefinitions: aCollection ^ self new initializeWithDefinitions: aCollection! ! MCCodeTool subclass: #MCSnapshotBrowser instanceVariableNames: 'categorySelection classSelection protocolSelection methodSelection switch' classVariableNames: '' poolDictionaries: '' category: 'MonticelloGUI'! !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: '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: 'accessing' stamp: 'bf 8/21/2012 21:38'! hasExtensions ^self extensionClassNames notEmpty! ! !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: '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: '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: 'ab 7/18/2003 15:48'! packageClasses ^ items select: [:ea | ea isClassDefinition]! ! !MCSnapshotBrowser methodsFor: 'accessing' stamp: 'ab 7/18/2003 15:48'! packageClassNames ^ self packageClasses collect: [:ea | ea className]! ! !MCSnapshotBrowser methodsFor: 'accessing' stamp: 'lr 3/14/2010 21:13'! selectedClass classSelection ifNil: [ ^ nil ]. ^ Smalltalk globals at: classSelection ifAbsent: [ nil ]! ! !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: 'accessing' stamp: 'nk 11/10/2003 21:29'! selectedMessageCategoryName ^protocolSelection! ! !MCSnapshotBrowser methodsFor: 'accessing' stamp: 'nk 10/11/2003 16:45'! selectedMessageName ^methodSelection ifNotNil: [^ methodSelection selector ]. ! ! !MCSnapshotBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! snapshot: aSnapshot items := aSnapshot definitions asSortedCollection. self categorySelection: 0.! ! !MCSnapshotBrowser methodsFor: 'listing' stamp: 'cwp 7/10/2003 18:33'! categoryList ^ self visibleCategories! ! !MCSnapshotBrowser methodsFor: 'listing' stamp: 'cwp 7/10/2003 20:20'! classList ^ self visibleClasses! ! !MCSnapshotBrowser methodsFor: 'listing' stamp: 'cwp 7/13/2003 02:11'! methodList ^ self visibleMethods collect: [:ea | ea selector]! ! !MCSnapshotBrowser methodsFor: 'listing' stamp: 'StephaneDucasse 12/28/2012 19:55'! packageOrganizations ^ items select: [:ea | ea isOrganizationDefinition]! ! !MCSnapshotBrowser methodsFor: 'listing' stamp: 'cwp 7/10/2003 19:07'! protocolList ^ self visibleProtocols! ! !MCSnapshotBrowser methodsFor: 'listing' stamp: 'bf 8/21/2012 21:42'! visibleCategories ^ ((self packageOrganizations gather: [:ea | ea categories]), (self packageClasses collect: [:ea | ea category]), (self hasExtensions ifTrue: [{self extensionsCategory}] ifFalse: [#()])) asSet asSortedCollection! ! !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: 'listing' stamp: 'cwp 7/10/2003 19:46'! visibleMethods ^ classSelection ifNil: [#()] ifNotNil: [self methodsForSelectedProtocol]! ! !MCSnapshotBrowser methodsFor: 'listing' stamp: 'stephaneducasse 2/4/2006 20:47'! visibleProtocols | methods protocols | self switchIsComment ifTrue: [^ Array new]. methods := self methodsForSelectedClass. protocols := (methods collect: [:ea | ea category]) asSet asSortedCollection. (protocols size > 1) ifTrue: [protocols add: '-- all --']. ^ protocols ! ! !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: '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: 'menus' stamp: 'cwp 7/10/2003 18:03'! inspectSelection ^ self methodSelection inspect! ! !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: '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: 'menus' stamp: 'nk 4/17/2004 09:45'! loadMethodSelection methodSelection ifNil: [ ^self ]. methodSelection load.! ! !MCSnapshotBrowser methodsFor: 'menus' stamp: 'nk 4/17/2004 09:46'! loadProtocolSelection protocolSelection ifNil: [ ^self ]. self methodsForSelectedProtocol do: [ :m | m load ].! ! !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: '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: '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: 'morphic ui' stamp: 'ab 7/18/2003 17:29'! defaultExtent ^ 650@400.! ! !MCSnapshotBrowser methodsFor: 'morphic ui' stamp: 'ab 7/19/2003 21:31'! defaultLabel ^ 'Snapshot Browser'! ! !MCSnapshotBrowser methodsFor: 'morphic ui' stamp: 'AlainPlantec 12/1/2009 21:46'! widgetSpecs MCCodeTool showAnnotationPane ifFalse: [ ^#( ((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)) ) ]. ^#( ((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: annotations) (0 0.4 1 0.4) (0 0 0 30)) ((textMorph: text) (0 0.4 1 1) (0 30 0 0)) )! ! !MCSnapshotBrowser methodsFor: 'selecting' stamp: 'cwp 7/10/2003 18:33'! categorySelection ^ categorySelection ifNil: [0] ifNotNil: [self visibleCategories indexOf: categorySelection]! ! !MCSnapshotBrowser methodsFor: 'selecting' stamp: 'stephaneducasse 2/4/2006 20:47'! categorySelection: aNumber categorySelection := aNumber = 0 ifFalse: [self visibleCategories at: aNumber]. self classSelection: 0. self changed: #categorySelection; changed: #annotations; changed: #classList. ! ! !MCSnapshotBrowser methodsFor: 'selecting' stamp: 'cwp 7/10/2003 18:28'! classSelection ^ classSelection ifNil: [0] ifNotNil: [self visibleClasses indexOf: classSelection]! ! !MCSnapshotBrowser methodsFor: 'selecting' stamp: 'stephaneducasse 2/4/2006 20:47'! classSelection: aNumber classSelection := aNumber = 0 ifFalse: [self visibleClasses at: aNumber]. self protocolSelection: 0. self changed: #classSelection; changed: #protocolList; changed: #annotations; changed: #methodList. ! ! !MCSnapshotBrowser methodsFor: 'selecting' stamp: 'cwp 7/10/2003 20:26'! methodSelection ^ methodSelection ifNil: [0] ifNotNil: [self visibleMethods indexOf: methodSelection]! ! !MCSnapshotBrowser methodsFor: 'selecting' stamp: 'stephaneducasse 2/4/2006 20:47'! methodSelection: aNumber methodSelection := aNumber = 0 ifFalse: [self visibleMethods at: aNumber]. self changed: #methodSelection; changed: #text; changed: #annotations! ! !MCSnapshotBrowser methodsFor: 'selecting' stamp: 'cwp 7/10/2003 19:35'! protocolSelection ^ protocolSelection ifNil: [0] ifNotNil: [self visibleProtocols indexOf: protocolSelection]! ! !MCSnapshotBrowser methodsFor: 'selecting' stamp: 'stephaneducasse 2/4/2006 20:47'! protocolSelection: anInteger protocolSelection := (anInteger = 0 ifFalse: [self visibleProtocols at: anInteger]). self methodSelection: 0. self changed: #protocolSelection; changed: #methodList; changed: #annotations! ! !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: 'switch' stamp: 'stephaneducasse 2/4/2006 20:47'! switchBeClass switch := #class. self signalSwitchChanged.! ! !MCSnapshotBrowser methodsFor: 'switch' stamp: 'stephaneducasse 2/4/2006 20:47'! switchBeComment switch := #comment. self signalSwitchChanged.! ! !MCSnapshotBrowser methodsFor: 'switch' stamp: 'stephaneducasse 2/4/2006 20:47'! switchBeInstance switch := #instance. self signalSwitchChanged.! ! !MCSnapshotBrowser methodsFor: 'switch' stamp: 'cwp 7/12/2003 18:05'! switchIsClass ^ switch = #class! ! !MCSnapshotBrowser methodsFor: 'switch' stamp: 'cwp 7/12/2003 18:04'! switchIsComment ^ switch = #comment.! ! !MCSnapshotBrowser methodsFor: 'switch' stamp: 'stephaneducasse 2/4/2006 20:47'! switchIsInstance switch ifNil: [switch := #instance]. ^ switch = #instance.! ! !MCSnapshotBrowser methodsFor: 'text' stamp: 'nk 7/24/2003 13:40'! annotations methodSelection ifNotNil: [^ methodSelection annotations ]. ^ ''! ! !MCSnapshotBrowser methodsFor: 'text' stamp: 'nk 7/24/2003 13:41'! annotations: stuff self changed: #annotations! ! !MCSnapshotBrowser methodsFor: 'text' stamp: 'ab 7/18/2003 15:48'! classCommentString ^ (items detect: [:ea | ea isClassDefinition and: [ea className = classSelection]] ifNone: [^ '']) comment.! ! !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 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: '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: '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: 'text' stamp: 'cwp 7/11/2003 00:30'! text: aTextOrString self changed: #text! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCSnapshotBrowser class instanceVariableNames: ''! !MCSnapshotBrowser class methodsFor: 'as yet unclassified' stamp: 'ab 7/19/2003 18:03'! forSnapshot: aSnapshot ^ self new snapshot: aSnapshot! ! MCTestCase subclass: #MCSnapshotBrowserTest instanceVariableNames: 'model morph' classVariableNames: '' poolDictionaries: '' category: 'Tests-Monticello'! !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: 'asserting' stamp: 'nice 1/5/2010 15:59'! assertAListMatches: strings | listMorphs | listMorphs := self listMorphs. listMorphs detect: [:m | | list | list := m getList. (list size = strings size) and: [list includesAllOf: strings]] ifNone: [self assert: false].! ! !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: 'asserting' stamp: 'cwp 7/13/2003 09:26'! assertButtonOn: aString self assert: (self findButtonWithLabel: aString) getModelState. ! ! !MCSnapshotBrowserTest methodsFor: 'asserting' stamp: 'oscar.nierstrasz 6/5/2010 14:55'! assertTextIs: aString self assert: self textMorph contents = aString.! ! !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: '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: 'asserting' stamp: 'cwp 7/13/2003 09:27'! denyButtonOn: aString self deny: (self findButtonWithLabel: aString) getModelState. ! ! !MCSnapshotBrowserTest methodsFor: 'morphic' stamp: 'cwp 7/28/2003 22:21'! annotationTextMorph ^ (self morphsOfClass: TextMorph) first! ! !MCSnapshotBrowserTest methodsFor: 'morphic' stamp: 'cwp 7/13/2003 09:12'! buttonMorphs ^ self morphsOfClass: PluggableButtonMorph! ! !MCSnapshotBrowserTest methodsFor: 'morphic' stamp: 'cwp 7/13/2003 09:19'! findButtonWithLabel: aString ^ self buttonMorphs detect: [:m | m label = aString]! ! !MCSnapshotBrowserTest methodsFor: 'morphic' stamp: 'cwp 7/13/2003 01:28'! findListContaining: aString ^ self listMorphs detect: [:m | m getList includes: aString]! ! !MCSnapshotBrowserTest methodsFor: 'morphic' stamp: 'cwp 7/13/2003 02:34'! listMorphs ^ self morphsOfClass: PluggableListMorph! ! !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: 'morphic' stamp: 'cwp 7/28/2003 22:21'! textMorph ^ (self morphsOfClass: TextMorph) last! ! !MCSnapshotBrowserTest methodsFor: 'running' stamp: 'stephaneducasse 2/4/2006 20:47'! setUp model := MCSnapshotBrowser forSnapshot: MCSnapshotResource current snapshot. morph := model buildWindow.! ! !MCSnapshotBrowserTest methodsFor: 'selecting' stamp: 'cwp 7/13/2003 13:04'! selectMockClassA self clickOnListItem: self mockCategoryName. self clickOnListItem: 'MCMockClassA'. ! ! !MCSnapshotBrowserTest methodsFor: 'simulating' stamp: 'cwp 7/13/2003 09:22'! clickOnButton: aString (self findButtonWithLabel: aString) performAction.! ! !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: 'AlainPlantec 1/16/2010 16:00'! testAnnotationPane | oldPref | oldPref := MCCodeTool showAnnotationPane. MCCodeTool showAnnotationPane: false. morph := model buildWindow. self assert: (self morphsOfClass: TextMorph) size = 1. MCCodeTool showAnnotationPane: true. morph := model buildWindow. self assert: (self morphsOfClass: TextMorph) size = 2. MCCodeTool showAnnotationPane: oldPref! ! !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: '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 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: '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: '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: 'testing' stamp: 'cwp 7/13/2003 09:00'! testMethodIsCleared self clickOnListItem: self mockCategoryName. self clickOnListItem: 'MCMockClassA'. self clickOnListItem: 'boolean'. self clickOnListItem: 'falsehood'. self clickOnListItem: '-- all --'. self denyAListHasSelection: 'falsehood'.! ! !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: '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: '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: '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: 'testing' stamp: 'cwp 7/13/2003 02:37'! testTextPane self shouldnt: [self textMorph] raise: Exception.! ! !MCSnapshotBrowserTest methodsFor: 'testing' stamp: 'cwp 7/13/2003 09:14'! testThreeButtons self assertButtonExists: 'instance'. self assertButtonExists: '?'. self assertButtonExists: 'class'.! ! !MCSnapshotBrowserTest methodsFor: 'private' stamp: 'cwp 7/14/2003 14:46'! allCategories ^ Array with: model extensionsCategory with: self mockCategoryName.! ! !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:58'! allProtocols ^ MCSnapshotResource current definitions select: [:def | def isMethodDefinition] thenCollect: [:def | def category] ! ! !MCSnapshotBrowserTest methodsFor: 'private' stamp: 'cwp 7/13/2003 02:23'! classABooleanMethods ^ #(falsehood moreTruth truth)! ! !MCSnapshotBrowserTest methodsFor: 'private' stamp: 'cwp 8/10/2003 02:10'! classAClassProtocols ^ self protocolsForClass: self mockClassA class.! ! !MCSnapshotBrowserTest methodsFor: 'private' stamp: 'cwp 8/10/2003 02:10'! classAComment ^ self mockClassA organization classComment.! ! !MCSnapshotBrowserTest methodsFor: 'private' stamp: 'oscar.nierstrasz 6/5/2010 14:58'! classADefinitionString ^ self mockClassA definition! ! !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: 'private' stamp: 'cwp 7/14/2003 14:59'! definedClasses ^ MCSnapshotResource current definitions select: [:def | def isClassDefinition] thenCollect: [:def | def className].! ! !MCSnapshotBrowserTest methodsFor: 'private' stamp: 'cwp 7/13/2003 02:53'! falsehoodMethodSource ^ 'falsehood ^ false'! ! !MCSnapshotBrowserTest methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:47'! protocolsForClass: aClass | protocols | protocols := aClass organization categories. protocols size > 1 ifTrue: [protocols := protocols copyWith: '-- all --']. ^ protocols.! ! MCReader subclass: #MCSnapshotReader instanceVariableNames: 'definitions' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Storing'! !MCSnapshotReader commentStamp: 'LaurentLaffont 2/23/2011 20:21' prior: 0! 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: 'as yet unclassified' stamp: 'avi 1/21/2004 23:09'! definitions definitions ifNil: [self loadDefinitions]. ^ definitions! ! !MCSnapshotReader methodsFor: 'as yet unclassified' stamp: 'avi 1/21/2004 23:10'! snapshot ^ MCSnapshot fromDefinitions: self definitions! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCSnapshotReader class instanceVariableNames: ''! !MCSnapshotReader class methodsFor: 'as yet unclassified' stamp: 'avi 1/21/2004 22:56'! snapshotFromStream: aStream ^ (self on: aStream) snapshot! ! TestResource subclass: #MCSnapshotResource instanceVariableNames: 'snapshot' classVariableNames: '' poolDictionaries: '' category: 'Tests-Monticello'! !MCSnapshotResource methodsFor: 'accessing' stamp: 'cwp 7/14/2003 14:50'! definitions ^ snapshot definitions! ! !MCSnapshotResource methodsFor: 'accessing' stamp: 'cwp 7/14/2003 14:51'! snapshot ^ snapshot! ! !MCSnapshotResource methodsFor: 'running' stamp: 'stephaneducasse 2/4/2006 20:47'! setUp snapshot := self class takeSnapshot.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCSnapshotResource class instanceVariableNames: ''! !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'! ! !MCSnapshotResource class methodsFor: 'accessing' stamp: 'cwp 7/14/2003 15:19'! takeSnapshot ^ self mockPackage snapshot! ! MCTestCase subclass: #MCSnapshotTest instanceVariableNames: 'snapshot' classVariableNames: '' poolDictionaries: '' category: 'Tests-Monticello'! !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: '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']]). ! ! !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! ! TestCase subclass: #MCSortingTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Monticello'! !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: '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: '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: '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 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 class instanceVariableNames: ''! !MCSortingTest class methodsFor: 'testing' stamp: 'JorgeRessia 3/16/2010 20:26'! isUnitTest ^false! ! MCHttpRepository subclass: #MCSqueaksourceRepository instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Repositories'! !MCSqueaksourceRepository methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 9/14/2012 17:25'! asCreationTemplate ^self class creationTemplateLocation: self location user: user password: password! ! !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: '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 class instanceVariableNames: ''! !MCSqueaksourceRepository class methodsFor: 'accessing' stamp: 'CamilloBruni 2/8/2012 18:13'! description ^ 'squeaksource.com'! ! !MCSqueaksourceRepository class methodsFor: 'creation template' stamp: 'CamilloBruni 10/21/2012 13:25'! baseURL ^ 'http://squeaksource.com/'! ! MCSnapshotReader subclass: #MCStReader instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Storing'! !MCStReader commentStamp: 'LaurentLaffont 3/31/2011 21:07' prior: 0! 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: 'as yet unclassified' stamp: 'marcus.denker 11/10/2008 10:04'! addDefinitionsFromDoit: aString (MCDoItParser forDoit: aString) ifNotNil: [:parser | parser addDefinitionsTo: definitions]! ! !MCStReader methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! categoryFromDoIt: aString | tokens | tokens := Scanner new scanTokens: aString. tokens size = 3 ifFalse: [self error: 'Unrecognized category definition']. ^ tokens at: 3! ! !MCStReader methodsFor: 'as yet unclassified' stamp: 'SvenVanCaekenberghe 1/8/2012 14:45'! classDefinitionFrom: aPseudoClass | tokens traitCompositionString lastIndex classTraitCompositionString | tokens := Scanner new scanTokens: aPseudoClass definition. 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: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! classInstVarNamesFor: aPseudoClass | tokens | self flag: #traits. aPseudoClass metaClass hasDefinition ifFalse: [^ #()]. tokens := Scanner new scanTokens: aPseudoClass metaClass definition. "tokens size = 4 ifFalse: [self error: 'Unrecognized metaclass definition']." ^ tokens last findTokens: ' '! ! !MCStReader methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! commentFor: aPseudoClass | comment | comment := aPseudoClass organization classComment. ^ comment asString = '' ifTrue: [comment] ifFalse: [comment string]! ! !MCStReader methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! commentStampFor: aPseudoClass | comment | comment := aPseudoClass organization classComment. ^ [comment stamp] on: MessageNotUnderstood do: [nil]! ! !MCStReader methodsFor: 'as yet unclassified' 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: 'as yet unclassified' 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 methodsFor: 'as yet unclassified' 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: '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 class instanceVariableNames: ''! !MCStReader class methodsFor: 'as yet unclassified' stamp: 'avi 1/20/2004 00:17'! extension ^ 'st'! ! MCTestCase subclass: #MCStReaderTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Monticello'! !MCStReaderTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! testCommentWithStyle | reader | reader := MCStReader on: self commentWithStyle readStream. reader definitions! ! !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: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! testMethodWithStyle | reader | reader := MCStReader on: self methodWithStyle readStream. self assert: reader definitions first isMethodDefinition.! ! !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: '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: '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!! !! '! ! MCWriter subclass: #MCStWriter instanceVariableNames: 'initializers' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Storing'! !MCStWriter commentStamp: 'LaurentLaffont 3/31/2011 21:07' prior: 0! 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: '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: '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 methodsFor: 'visiting' stamp: 'al 10/9/2005 19:40'! visitMetaclassDefinition: definition self writeMetaclassDefinition: definition! ! !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: 'visiting' stamp: 'cwp 8/2/2003 11:02'! visitOrganizationDefinition: defintion defintion categories do: [:cat | self writeCategory: cat]. ! ! !MCStWriter methodsFor: 'visiting' stamp: 'bf 8/12/2009 21:41'! visitScriptDefinition: definition self writeScriptDefinition: definition ! ! !MCStWriter methodsFor: 'visiting' stamp: 'al 10/9/2005 19:40'! visitTraitDefinition: definition self writeClassDefinition: definition. definition hasComment ifTrue: [self writeClassComment: definition].! ! !MCStWriter methodsFor: 'writing' stamp: 'cwp 8/2/2003 02:34'! chunkContents: aBlock stream cr; nextChunkPut: (String streamContents: aBlock); cr! ! !MCStWriter methodsFor: 'writing' stamp: 'cwp 8/2/2003 01:46'! writeCategory: categoryName stream nextChunkPut: 'SystemOrganization addCategory: ', categoryName printString; 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: 'writing' stamp: 'cwp 8/2/2003 02:16'! writeClassDefinition: definition self chunkContents: [:s | definition printDefinitionOn: stream]! ! !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: '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: '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: 'writing' stamp: 'cwp 8/2/2003 12:43'! writeMethodPostscript stream space; nextPut: $!!; cr! ! !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: 'cwp 8/4/2003 01:35'! writeMethodSource: definition stream nextChunkPut: definition source! ! !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: 'avi 2/17/2004 02:25'! writeSnapshot: aSnapshot self writeDefinitions: aSnapshot definitions! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCStWriter class instanceVariableNames: ''! !MCStWriter class methodsFor: 'as yet unclassified' stamp: 'avi 1/20/2004 00:16'! readerClass ^ MCStReader! ! MCTestCase subclass: #MCStWriterTest instanceVariableNames: 'stream writer' classVariableNames: '' poolDictionaries: '' category: 'Tests-Monticello'! !MCStWriterTest methodsFor: 'asserting' stamp: 'cwp 8/2/2003 12:13'! assertAllChunksAreWellFormed stream reset. stream untilEnd: [self assertChunkIsWellFormed: stream nextChunk] displayingProgress: 'Checking syntax...'! ! !MCStWriterTest methodsFor: 'asserting' stamp: 'al 7/21/2006 22:14'! assertChunkIsWellFormed: chunk self class parserClass new parse: chunk readStream class: UndefinedObject noPattern: true context: nil notifying: nil ifFail: [self assert: false]! ! !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: 'asserting' stamp: 'al 7/21/2006 22:14'! assertMethodChunkIsWellFormed: chunk self class parserClass new parse: chunk readStream class: UndefinedObject noPattern: false context: nil notifying: nil ifFail: [self assert: false]! ! !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: '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: '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!! !! '! ! !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: 'ab 8/8/2003 17:01'! expectedInitializerA ^ 'MCMockClassA initialize'! ! !MCStWriterTest methodsFor: 'testing' stamp: 'pavel.krivanek 10/14/2010 16:43'! expectedInitializerASubclass ^ 'MCMockASubclass initialize'! ! !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: 'stephaneducasse 2/4/2006 20:47'! setUp stream := RWBinaryOrTextStream on: String new. writer := MCStWriter on: stream. ! ! !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: 'cwp 9/14/2003 19:39'! testClassDefinitionB writer visitClassDefinition: (self mockClassB asClassDefinition). self assertContentsOf: stream match: self expectedClassDefinitionB. ! ! !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: '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: '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: '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: '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.! ! MCDirectoryRepository subclass: #MCSubDirectoryRepository instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Repositories'! !MCSubDirectoryRepository commentStamp: 'nk 6/11/2004 18:56' prior: 0! A MCDirectoryRepository that looks in subdirectories too.! !MCSubDirectoryRepository methodsFor: 'as yet unclassified' 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 methodsFor: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' 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: 'enumeration' stamp: 'EstebanLorenzano 8/17/2012 13:12'! allDirectories ^directory allDirectories ! ! !MCSubDirectoryRepository methodsFor: 'user interface' stamp: 'CamilloBruni 5/4/2012 19:04'! description ^ (directory / '*') fullName ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCSubDirectoryRepository class instanceVariableNames: ''! !MCSubDirectoryRepository class methodsFor: 'user interface' stamp: 'nk 6/11/2004 18:48'! description ^ 'directory with subdirectories'! ! MCTestCase subclass: #MCSubDirectoryRepositoryTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Monticello'! !MCSubDirectoryRepositoryTest commentStamp: '' prior: 0! 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'.! ! MCDoItParser subclass: #MCSystemCategoryParser instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Chunk Format'! !MCSystemCategoryParser commentStamp: '' prior: 0! A MCSystemCategoryParser extracts or set a category/protocol to the corresponding MCOrganizationDefinition.! !MCSystemCategoryParser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! category | tokens | tokens := Scanner new scanTokens: source. 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 instanceVariableNames: ''! !MCSystemCategoryParser class methodsFor: 'factory identification hook' stamp: 'avi 3/10/2004 12:41'! pattern ^ 'SystemOrganization*'! ! Object subclass: #MCSystemSettings instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Settings-Monticello'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCSystemSettings class instanceVariableNames: ''! !MCSystemSettings class methodsFor: 'settings' stamp: 'tbn 7/4/2012 15:42'! monticelloSettingsOn: aBuilder (aBuilder group: #monticello) label: 'Monticello' translated; description: 'All Monticello settings' translated; with: [ (aBuilder setting: #showAnnotationPane) label: 'Show annotation pane' translated; target: MCCodeTool; description: 'If checked then the annotation pane is shown in Monticello tools; it is dynamically updated with useful informations about the code which is currently browsed' translated. (aBuilder setting: #defaultDirectoryName) type: #FileDirectory; 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: #FileDirectory; target: MCCacheRepository; description: 'The path of the local repository cache' translated; label: 'Local cache directory'. ].! ! TestCase subclass: #MCTestCase instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Monticello'! !MCTestCase methodsFor: 'asserting' stamp: 'cwp 8/8/2003 14:58'! assertPackage: actual matches: expected self assert: actual = expected ! ! !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: '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: '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: 'compiling' stamp: 'cwp 8/10/2003 02:12'! change: aSelector toReturn: anObject self compileClass: self mockClassA source: aSelector, ' ^ ', anObject printString category: 'numeric'! ! !MCTestCase methodsFor: 'compiling' stamp: 'abc 2/16/2006 09:24'! compileClass: aClass source: source category: category aClass compileSilently: source classified: category! ! !MCTestCase methodsFor: 'compiling' stamp: 'cwp 8/2/2003 15:05'! restoreMocks self mockSnapshot updatePackage: self mockPackage! ! !MCTestCase methodsFor: 'mocks' stamp: 'cwp 8/10/2003 16:51'! commentForClass: name ^ 'This is a comment for ', name! ! !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 12:57'! mockCategoryName ^ 'MonticelloMocks'! ! !MCTestCase methodsFor: 'mocks' stamp: 'lr 3/14/2010 21:13'! mockClassA ^ Smalltalk globals at: #MCMockClassA! ! !MCTestCase methodsFor: 'mocks' stamp: 'lr 3/14/2010 21:13'! mockClassB ^ Smalltalk globals at: #MCMockClassB! ! !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: 'mocks' stamp: 'avi 1/19/2004 15:54'! mockDependencies ^ Array with: (MCVersionDependency package: self mockEmptyPackage info: (self mockVersionInfo: 'x'))! ! !MCTestCase methodsFor: 'mocks' stamp: 'avi 2/22/2004 14:08'! mockEmptyPackage ^ MCPackage named: (MCEmptyPackageInfo new packageName)! ! !MCTestCase methodsFor: 'mocks' stamp: 'GuillermoPolito 8/24/2012 13:48'! mockExtensionMethodCategory ^ '*MonticelloMocks'! ! !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: '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: 'cwp 11/13/2003 13:24'! mockOverrideMethodCategory ^ self mockExtensionMethodCategory, '-override'! ! !MCTestCase methodsFor: 'mocks' stamp: 'cwp 8/1/2003 20:27'! mockPackage ^ MCSnapshotResource mockPackage! ! !MCTestCase methodsFor: 'mocks' stamp: 'cwp 7/14/2003 15:07'! mockSnapshot ^ MCSnapshotResource current snapshot! ! !MCTestCase methodsFor: 'mocks' stamp: 'ab 1/15/2003 17:55'! mockToken: aSymbol ^ MCMockDefinition token: aSymbol! ! !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 2/12/2004 19:58'! mockVersionInfo ^ self treeFrom: #(d ((b ((a))) (c)))! ! !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: '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 7/30/2003 19:25'! mockVersionName ^ 'MonticelloTest-xxx.1'! ! !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: 'avi 1/19/2004 15:15'! mockVersionWithDependencies ^ MCVersion package: self mockPackage info: self mockVersionInfo snapshot: self mockSnapshot dependencies: self mockDependencies! ! !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: 'running' stamp: 'CamilloBruni 7/6/2012 16:21'! runCase MCCacheRepository disableCacheDuring: [ ^ super runCase ].! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCTestCase class instanceVariableNames: ''! !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! ! MCMerger subclass: #MCThreeWayMerger instanceVariableNames: 'index operations provisions redundantAdds' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Merging'! !MCThreeWayMerger commentStamp: '' prior: 0! 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: 'stephaneducasse 2/4/2006 20:47'! operations ^ operations ifNil: [operations := OrderedCollection new]! ! !MCThreeWayMerger methodsFor: 'accessing' stamp: 'avi 10/6/2004 15:19'! provisions ^ provisions! ! !MCThreeWayMerger methodsFor: 'initialize-release' 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: '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: 'ab 6/2/2003 01:30'! addOperation: anOperation self operations add: anOperation! ! !MCThreeWayMerger methodsFor: 'operations' stamp: 'avi 2/13/2004 01:52'! applyPatch: aPatch aPatch applyTo: self! ! !MCThreeWayMerger methodsFor: 'operations' stamp: 'avi 2/13/2004 01:49'! baseSnapshot ^ (MCSnapshot fromDefinitions: index definitions)! ! !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: '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 methodsFor: 'operations' stamp: 'stephaneducasse 2/4/2006 20:47'! redundantAdds ^ redundantAdds ifNil: [redundantAdds := Set new]! ! !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: '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: 'avi 9/19/2005 02:40'! removeOperation: anOperation operations remove: anOperation! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCThreeWayMerger class instanceVariableNames: ''! !MCThreeWayMerger class methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'ab 6/2/2003 01:09'! base: aSnapshot target: targetSnapshot ancestor: ancestorSnapshot ^ self base: aSnapshot patch: (targetSnapshot patchRelativeToBase: ancestorSnapshot)! ! Object subclass: #MCTool instanceVariableNames: 'morph label modal modalValue' classVariableNames: '' poolDictionaries: '' category: 'MonticelloGUI'! !MCTool methodsFor: '*Shout-Styling' stamp: 'AlainPlantec 8/27/2011 15:59'! shoutAboutToStyle: aPluggableShoutMorphOrView ^ false! ! !MCTool methodsFor: 'accessing' stamp: 'gvc 5/11/2006 11:13'! minimumExtent "Answer the minumum extent for the tool." ^100@100! ! !MCTool methodsFor: 'as yet unclassified ' 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: 'as yet unclassified ' 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: 'stephaneducasse 2/4/2006 20:47'! answer: anObject modalValue := anObject. self close.! ! !MCTool methodsFor: 'morphic ui' stamp: 'nk 2/16/2004 16:50'! arrowKey: aCharacter from: aPluggableListMorph "backstop"! ! !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: 'bf 5/27/2005 19:19'! buttonEnabled ^ true! ! !MCTool methodsFor: 'morphic ui' stamp: 'ab 7/18/2003 18:34'! buttonRow ^ self buttonRow: self buttonSpecs! ! !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: 'bf 5/27/2005 19:22'! buttonSelected ^ false! ! !MCTool methodsFor: 'morphic ui' stamp: 'ab 7/17/2003 15:23'! buttonSpecs ^ #()! ! !MCTool methodsFor: 'morphic ui' stamp: 'lr 7/28/2011 16:24'! buttonState ^ false! ! !MCTool methodsFor: 'morphic ui' stamp: 'ab 7/18/2003 17:42'! close self window delete! ! !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: 'ab 7/17/2003 15:10'! defaultExtent ^ 500@500! ! !MCTool methodsFor: 'morphic ui' stamp: 'ab 7/17/2003 15:11'! defaultLabel ^ self class name! ! !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: '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: '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: 'ab 7/18/2003 17:23'! getMenu: aMenu ^aMenu! ! !MCTool methodsFor: 'morphic ui' stamp: 'StephaneDucasse 2/20/2010 21:58'! initialExtent ^ 580@200! ! !MCTool methodsFor: 'morphic ui' stamp: 'ab 7/18/2003 17:36'! label ^ label ifNil: [self defaultLabel]! ! !MCTool methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'! label: aString label := aString! ! !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 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: '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/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: '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: '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: '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: 'lr 10/5/2003 09:09'! performButtonAction: anActionSelector enabled: anEnabledSelector (self perform: anEnabledSelector) ifTrue: [ self perform: anActionSelector ]! ! !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: 'CamilloBruni 2/4/2012 12:27'! setDefaultFocus "set the default focus on the morph elements. specializ this in subclasses"! ! !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: 'morphic ui' stamp: 'nk 6/12/2004 14:11'! step ! ! !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: 'FernandoOlivero 4/12/2011 09:52'! theme "Answer the ui theme that provides controls." ^UITheme current! ! !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: '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: 'morphic ui' stamp: 'ab 7/17/2003 15:40'! widgetSpecs ^ #()! ! !MCTool methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'! window ^ morph ifNil: [morph := self buildWindow]! ! !MCTool methodsFor: 'utils' stamp: 'StephaneDucasse 6/2/2012 20:34'! allManagers ^ MCWorkingCopy allManagers ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCTool class instanceVariableNames: ''! !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: 'FernandoOlivero 4/12/2011 09:52'! theme "Answer the ui theme that provides controls." ^UITheme current! ! MCClassDefinition subclass: #MCTraitDefinition instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Modeling'! !MCTraitDefinition commentStamp: '' prior: 0! A MCTraitDefinition represents a trait.! !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: '*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 methodsFor: '*Ring-Monticello' stamp: 'VeronicaUquillas 8/4/2011 12:10'! classTraitCompositionString ^self traitComposition ifNil: [ '{}' ] ifNotNil: [ :source| | tokens tcs | tcs := ''. tokens := Scanner new scanTokens: source. 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 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: 'comparing' stamp: 'al 6/5/2006 14:13'! 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 := Scanner new scanTokens: self traitComposition. traitNames := tokens select: [:each | each first isUppercase]. ^traitNames asArray! ! !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: 'installing' stamp: 'marcus.denker 11/10/2008 10:04'! load self createClass ifNotNil: [:trait | self hasComment ifTrue: [trait classComment: comment stamp: commentStamp]]! ! !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: 'testing' stamp: 'al 10/9/2005 20:28'! hasClassInstanceVariables ^ false ! ! !MCTraitDefinition methodsFor: 'visiting' stamp: 'al 10/9/2005 20:28'! accept: aVisitor ^ aVisitor visitTraitDefinition: self ! ! !MCTraitDefinition methodsFor: 'visiting' stamp: 'jb 7/1/2011 10:52'! createClass ^Trait named: name uses: (self class evaluatorClass evaluate: self traitCompositionString) category: category ! ! !MCTraitDefinition methodsFor: 'visiting' 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 class instanceVariableNames: ''! !MCTraitDefinition class methodsFor: 'as yet unclassified' 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) ! ! MCDoItParser subclass: #MCTraitParser instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Chunk Format'! !MCTraitParser commentStamp: '' prior: 0! A MCTraitParser extracts an MCTraitDefinition from the source.! !MCTraitParser methodsFor: 'actions' stamp: 'SvenVanCaekenberghe 1/8/2012 14:45'! addDefinitionsTo: aCollection | tokens definition traitCompositionString | tokens := Scanner new scanTokens: source. 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 instanceVariableNames: ''! !MCTraitParser class methodsFor: 'factory identification hook' stamp: 'al 10/9/2005 21:09'! pattern ^ 'Trait named:*'! ! Object subclass: #MCVariableDefinition instanceVariableNames: 'name' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Modeling'! !MCVariableDefinition commentStamp: '' prior: 0! A MCVariableDefinition represents a variable.! !MCVariableDefinition methodsFor: 'accessing' stamp: 'cwp 11/25/2002 05:57'! name ^ name! ! !MCVariableDefinition methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! name: aString name := aString! ! !MCVariableDefinition methodsFor: 'as yet unclassified' stamp: 'nk 7/24/2003 14:56'! printOn: aStream super printOn: aStream. aStream nextPut: $(; nextPutAll: self name; nextPut: $)! ! !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:31'! isClassInstanceVariable ^ false! ! !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: 'testing' stamp: 'cwp 7/7/2003 23:31'! isInstanceVariable ^ false! ! !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:51'! isPoolImport ^ false! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCVariableDefinition class instanceVariableNames: ''! !MCVariableDefinition class methodsFor: 'as yet unclassified' stamp: 'cwp 7/7/2003 23:18'! name: aString ^ self new name: aString ! ! Object subclass: #MCVersion instanceVariableNames: 'package info snapshot dependencies completeSnapshot completePackageSnapshot' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Versioning'! !MCVersion methodsFor: '*MonticelloGUI' stamp: 'BenjaminVanRyseghem 2/8/2012 17:10'! browse ^ (MCSnapshotBrowser forSnapshot: self completeSnapshot) showLabelled: 'Snapshot of ', self fileName! ! !MCVersion methodsFor: '*MonticelloGUI' stamp: 'ab 7/12/2003 00:19'! open (MCVersionInspector new version: self) show! ! !MCVersion methodsFor: 'accessing' stamp: 'CamilloBruni 9/30/2011 16:18'! changes ^ self completeSnapshot patchRelativeToBase: self completePackageSnapshot! ! !MCVersion methodsFor: 'accessing' stamp: 'CamilloBruni 9/30/2011 16:18'! completePackageSnapshot ^ completePackageSnapshot ifNil: [ completePackageSnapshot := self loadCompletePackageSnapshot]! ! !MCVersion methodsFor: 'accessing' stamp: 'CamilloBruni 9/30/2011 16:08'! completeSnapshot ^ completeSnapshot ifNil: [ completeSnapshot := self loadCompleteSnapshot ]! ! !MCVersion methodsFor: 'accessing' stamp: 'avi 1/22/2004 00:24'! dependencies ^ dependencies ifNil: [#()]! ! !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:28'! info ^ info! ! !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: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: 'accessing' stamp: 'ab 7/7/2003 14:19'! package ^ package! ! !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: '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: 'accessing' stamp: 'avi 2/12/2004 19:38'! workingCopy ^ package workingCopy! ! !MCVersion methodsFor: 'accessing' stamp: 'avi 1/22/2004 12:44'! writerClass ^ MCMczWriter ! ! !MCVersion methodsFor: 'actions' stamp: 'SeanDeNigris 7/17/2012 15:40'! addToCache MCCacheRepository uniqueInstance storeVersion: self! ! !MCVersion methodsFor: 'actions' stamp: 'avi 2/12/2004 19:37'! adopt self workingCopy adopt: self! ! !MCVersion methodsFor: 'actions' stamp: 'avi 1/22/2004 12:44'! fileOutOn: aStream self writerClass fileOut: self on: aStream! ! !MCVersion methodsFor: 'actions' stamp: 'avi 1/24/2004 20:13'! load MCVersionLoader loadVersion: self! ! !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: '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: 'enumerating' stamp: 'cwp 11/7/2004 11:58'! allDependenciesDo: aBlock self allDependenciesDo: aBlock ifUnresolved: [:ignored | true]! ! !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: '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 methodsFor: 'enumerating' stamp: 'cwp 11/7/2004 14:24'! withAllDependenciesDo: aBlock self allDependenciesDo: aBlock ifUnresolved: [:ignored]. aBlock value: self! ! !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: '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: '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: 'printing' stamp: 'nk 3/8/2004 23:54'! printOn: aStream super printOn: aStream. aStream nextPut: $(. aStream nextPutAll: self info name. aStream nextPut: $).! ! !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: 'testing' stamp: 'bf 3/22/2005 23:00'! isCacheable ^true! ! !MCVersion methodsFor: 'testing' stamp: 'avi 2/13/2004 23:24'! isDiffy ^ false! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCVersion class instanceVariableNames: ''! !MCVersion class methodsFor: 'instance creation' stamp: 'ab 7/7/2003 16:13'! package: aPackage ^ self package: aPackage info: MCVersionInfo new! ! !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: '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! ! Announcement subclass: #MCVersionCreated instanceVariableNames: 'name nameString version' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Announcements'! !MCVersionCreated commentStamp: '' prior: 0! An MCVersionCreated is raised when a MCVersion is created ! !MCVersionCreated methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/14/2011 13:56'! name: anObject name := anObject! ! !MCVersionCreated methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/14/2011 13:56'! nameString ^ nameString! ! !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'! version: anObject version := anObject! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCVersionCreated class instanceVariableNames: ''! !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! ! !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! ! Object subclass: #MCVersionDependency instanceVariableNames: 'package versionInfo' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Versioning'! !MCVersionDependency methodsFor: 'accessing' stamp: 'avi 1/19/2004 15:40'! package ^ package! ! !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: 'comparing' stamp: 'avi 1/19/2004 16:06'! hash ^ versionInfo hash! ! !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: 'resolving' stamp: 'nk 6/13/2004 19:21'! resolve ^ self repositoryGroup versionWithInfo: versionInfo ifNone: [ MCRepositoryGroup default versionWithInfo: versionInfo ifNone: []]! ! !MCVersionDependency methodsFor: 'testing' stamp: 'bf 4/19/2005 16:29'! isCurrent ^ package hasWorkingCopy and: [self isFulfilled and: [package workingCopy modified not]]! ! !MCVersionDependency methodsFor: 'testing' stamp: 'bf 4/19/2005 16:29'! isFulfilled ^package hasWorkingCopy and: [self isFulfilledBy: package workingCopy ancestry]! ! !MCVersionDependency methodsFor: 'testing' stamp: 'bf 4/19/2005 16:29'! isFulfilledByAncestors ^ package hasWorkingCopy and: [self isFulfilledByAncestorsOf: package workingCopy ancestry]! ! !MCVersionDependency methodsFor: 'testing' stamp: 'nk 7/13/2004 08:45'! isFulfilledByAncestorsOf: anAncestry ^ anAncestry hasAncestor: versionInfo! ! !MCVersionDependency methodsFor: 'testing' stamp: 'avi 3/4/2004 00:34'! isFulfilledBy: anAncestry ^ anAncestry ancestors includes: versionInfo! ! !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 class instanceVariableNames: ''! !MCVersionDependency class methodsFor: 'as yet unclassified' stamp: 'avi 1/19/2004 13:13'! package: aPackage info: aVersionInfo ^ self basicNew initializeWithPackage: aPackage info: aVersionInfo! ! MCTool subclass: #MCVersionHistoryBrowser instanceVariableNames: 'ancestry index repositoryGroup package infos' classVariableNames: '' poolDictionaries: '' category: 'MonticelloGUI'! !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: '*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: 'stephaneducasse 2/4/2006 20:47'! ancestry: anAncestry ancestry := anAncestry! ! !MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'avi 2/13/2004 01:10'! baseSnapshot ^ self snapshotForInfo: ancestry! ! !MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'ab 8/22/2003 01:41'! index "Answer the value of index" ^ index! ! !MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! index: anObject "Set the value of index" index := anObject! ! !MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! infos ^ infos ifNil: [infos := ancestry withBreadthFirstAncestors]! ! !MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'avi 9/17/2005 16:10'! list ^ self infos collect: [:ea | ea name]! ! !MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! package: aMCPackage package := aMCPackage! ! !MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'ab 8/7/2003 21:27'! repositoryGroup ^ MCRepositoryGroup default! ! !MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'avi 9/17/2005 16:09'! selectedInfo ^ self infos at: self selection ifAbsent: [nil]! ! !MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'ab 8/22/2003 01:39'! selectedSnapshot ^ self snapshotForInfo: self selectedInfo! ! !MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'ab 7/11/2003 23:24'! selection ^ index ifNil: [0]! ! !MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! selection: aNumber index := aNumber. self changed: #selection; changed: #summary! ! !MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'ab 8/22/2003 01:38'! snapshotForInfo: aVersionInfo ^ (self repositoryGroup versionWithInfo: aVersionInfo) snapshot! ! !MCVersionHistoryBrowser methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! summary | selInfo | selInfo := self selectedInfo. ^ selInfo ifNil: [''] ifNotNil: [selInfo summary]! ! !MCVersionHistoryBrowser methodsFor: 'morphic ui' stamp: 'ab 7/17/2003 15:41'! defaultExtent ^ 440@169. ! ! !MCVersionHistoryBrowser methodsFor: 'morphic ui' stamp: 'avi 2/13/2004 01:09'! defaultLabel ^ ancestry name, ' History'! ! !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: '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)) )! ! MCAncestry subclass: #MCVersionInfo instanceVariableNames: 'id name message date time author' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Versioning'! !MCVersionInfo commentStamp: '' prior: 0! Adds to the record of ancestry, other identifying details.! !MCVersionInfo methodsFor: 'accessing' stamp: 'ab 7/12/2003 00:04'! message ^ message ifNil: ['']! ! !MCVersionInfo methodsFor: 'accessing' stamp: 'ab 7/11/2003 23:33'! name ^ name ifNil: ['']! ! !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 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: '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: 'avi 1/22/2004 16:45'! timeStamp ^ TimeStamp date: date time: time! ! !MCVersionInfo methodsFor: 'accessing' stamp: 'avi 9/17/2003 11:24'! timeString ^ date asString, ', ', time asString! ! !MCVersionInfo methodsFor: 'comparing' stamp: 'ab 7/5/2003 14:09'! hash ^ id hash! ! !MCVersionInfo methodsFor: 'comparing' stamp: 'ab 7/5/2003 14:23'! = other ^ other species = self species and: [other hasID: id]! ! !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: '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: 'pillaging' stamp: 'cwp 8/1/2003 00:26'! author ^ author! ! !MCVersionInfo methodsFor: 'pillaging' stamp: 'cwp 8/1/2003 00:26'! date ^ date! ! !MCVersionInfo methodsFor: 'pillaging' stamp: 'cwp 8/1/2003 00:24'! id ^ id ! ! !MCVersionInfo methodsFor: 'pillaging' stamp: 'cwp 8/1/2003 00:26'! time ^ time! ! !MCVersionInfo methodsFor: 'printing' stamp: 'ab 7/5/2003 18:00'! printOn: aStream super printOn: aStream. aStream nextPut: $(; nextPutAll: self name; nextPut: $) ! ! !MCVersionInfo methodsFor: 'private' stamp: 'ab 7/5/2003 14:10'! hasID: aUUID ^ id = aUUID! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCVersionInfo class instanceVariableNames: ''! !MCVersionInfo class methodsFor: 'as yet unclassified' 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: 'as yet unclassified' 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! ! MCWriter subclass: #MCVersionInfoWriter instanceVariableNames: 'written' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Storing'! !MCVersionInfoWriter commentStamp: '' prior: 0! 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: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! written ^ written ifNil: [written := Set new]! ! !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! ! !MCVersionInfoWriter methodsFor: 'serialization' stamp: 'avi 1/22/2004 21:10'! wrote: aVersionInfo self written add: aVersionInfo! ! !MCVersionInfoWriter methodsFor: 'testing' stamp: 'avi 1/22/2004 21:10'! isWritten: aVersionInfo ^ self written includes: aVersionInfo! ! MCTool subclass: #MCVersionInspector instanceVariableNames: 'version' classVariableNames: '' poolDictionaries: '' category: 'MonticelloGUI'! !MCVersionInspector commentStamp: '' prior: 0! 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: '*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: 'avi 9/17/2005 17:16'! summary ^self hasVersion ifTrue: [ self versionSummary ] ifFalse: [ String new ]! ! !MCVersionInspector methodsFor: 'accessing' stamp: 'avi 2/28/2004 20:19'! version ^ version! ! !MCVersionInspector methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! version: aVersion version := aVersion! ! !MCVersionInspector methodsFor: 'accessing' stamp: 'avi 9/17/2005 17:16'! versionInfo ^ self version info! ! !MCVersionInspector methodsFor: 'accessing' stamp: 'avi 9/17/2005 17:16'! versionSummary ^ self version summary! ! !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: '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: '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: 'avi 9/17/2005 17:14'! history (MCVersionHistoryBrowser new ancestry: self versionInfo) show! ! !MCVersionInspector methodsFor: 'actions' stamp: 'bf 3/14/2005 15:32'! load Cursor wait showWhile: [self version load]! ! !MCVersionInspector methodsFor: 'actions' stamp: 'avi 2/28/2004 20:19'! merge self version merge! ! !MCVersionInspector methodsFor: 'actions' stamp: 'marcus.denker 11/10/2008 10:04'! save self pickRepository ifNotNil: [:ea | ea storeVersion: self version]! ! !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: 'avi 8/31/2003 00:45'! defaultExtent ^ 400@200! ! !MCVersionInspector methodsFor: 'morphic ui' stamp: 'avi 2/28/2004 20:18'! defaultLabel ^ 'Version: ', self version info name! ! !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: '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: '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: 'testing' stamp: 'lr 9/26/2003 20:15'! hasVersion ^version notNil! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCVersionInspector class instanceVariableNames: ''! !MCVersionInspector class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'FernandoOlivero 4/12/2011 09:48'! taskbarIcon "Answer the icon for the receiver in a task bar." ^ self theme smallSaveIcon! ! Object subclass: #MCVersionLoader instanceVariableNames: 'versions' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Loading'! !MCVersionLoader commentStamp: '' prior: 0! A MCVersionLoader is responsible for loading a given version. ! !MCVersionLoader methodsFor: '*gofer-core-accessing' stamp: 'StephaneDucasse 12/30/2012 20:30'! goferHasVersions self deprecated: 'Use hasVersions ' on: '30 December 2012' in: #Pharo2.0. ^ self hasVersions! ! !MCVersionLoader methodsFor: '*gofer-core-accessing' stamp: 'StephaneDucasse 12/30/2012 20:30'! goferVersions self deprecated: 'Use versions ' on: '30 December 2012' in: #Pharo2.0. ^ self versions! ! !MCVersionLoader methodsFor: 'accessing' stamp: 'dkh 9/9/2009 14:51'! versions ^versions! ! !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: 'checking' stamp: 'cwp 11/7/2004 17:00'! checkIfDepIsOlder: aDependency ^ aDependency isOlder not or: [self confirm: 'load older dependency ', aDependency versionInfo name , '?']! ! !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:02'! depAgeIsOk: aDependency ^ aDependency isOlder not or: [self confirm: 'load older dependency ', aDependency versionInfo name , '?']! ! !MCVersionLoader methodsFor: 'checking' stamp: 'CamilloBruni 8/4/2011 12:46'! localModifications ^ versions select: [:ea | ea package workingCopy modified]. ! ! !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: 'initialization' stamp: 'alain.plantec 5/28/2009 10:04'! initialize super initialize. versions := OrderedCollection new! ! !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: 'loading' stamp: 'cwp 11/7/2004 17:04'! addVersion: aVersion aVersion dependencies do: [ :ea | self addDependency: ea]. versions add: aVersion. ! ! !MCVersionLoader methodsFor: 'loading' stamp: 'bf 3/16/2006 19:03'! load self loadWithNameLike: versions first info 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: 'loading' stamp: 'abc 8/8/2011 13:01'! mergeVersions |merger| merger := MCVersionMerger new. merger addVersions: self localModifications. merger merge.! ! !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 class instanceVariableNames: ''! !MCVersionLoader class methodsFor: 'public api' stamp: 'avi 1/24/2004 20:06'! loadVersion: aVersion self new addVersion: aVersion; load! ! Object subclass: #MCVersionMerger instanceVariableNames: 'records merger' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Versioning'! !MCVersionMerger methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'CamilloBruni 8/4/2011 13:49'! addVersions: aCollection aCollection do: [ :version| self addVersion: version].! ! !MCVersionMerger methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 9/30/2011 16:52'! gatherChanges records do: [:ea | merger addBaseSnapshot: ea packageSnapshot]. records do: [:ea | merger applyPatch: ea mergePatch].! ! !MCVersionMerger methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 8/4/2011 14:03'! initialize super initialize. records := OrderedCollection new. merger := MCThreeWayMerger new.! ! !MCVersionMerger methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 1/16/2012 15:49'! merge self gatherChanges. self resolveConflicts ifTrue: [merger load. records do: [:ea | ea updateWorkingCopy]. ^ true]. ^ false! ! !MCVersionMerger methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 9/30/2011 16:51'! mergeWithNameLike: baseName self gatherChanges. self resolveConflicts ifTrue: [merger loadWithNameLike: baseName. records do: [:ea | ea updateWorkingCopy]].! ! !MCVersionMerger methodsFor: 'as yet unclassified' 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 class instanceVariableNames: ''! !MCVersionMerger class methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 9/30/2011 16:53'! mergeVersion: aVersion self new addVersion: aVersion; mergeWithNameLike: aVersion info name! ! Notification subclass: #MCVersionNameAndMessageRequest instanceVariableNames: 'suggestion suggestedLogComment' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Versioning'! !MCVersionNameAndMessageRequest methodsFor: '*MonticelloGUI' stamp: 'AndrewBlack 9/4/2009 14:11'! defaultAction ^ MCSaveVersionDialog new versionName: suggestion; logMessage: suggestedLogComment; showModally! ! !MCVersionNameAndMessageRequest methodsFor: 'as yet unclassified' stamp: 'AndrewBlack 9/4/2009 14:16'! suggestedLogComment ^ suggestedLogComment! ! !MCVersionNameAndMessageRequest methodsFor: 'as yet unclassified' stamp: 'AndrewBlack 9/4/2009 14:16'! suggestedLogComment: aLogMessage suggestedLogComment := aLogMessage! ! !MCVersionNameAndMessageRequest methodsFor: 'as yet unclassified' stamp: 'ab 7/10/2003 01:07'! suggestedName ^ suggestion! ! !MCVersionNameAndMessageRequest methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! suggestedName: aString suggestion := aString! ! Object subclass: #MCVersionNotification instanceVariableNames: 'version ancestor repository changes' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Repositories'! !MCVersionNotification methodsFor: 'as yet unclassified' stamp: 'avi 8/26/2004 15:13'! fromAddress ^ 'monticello@beta4.com'! ! !MCVersionNotification methodsFor: 'as yet unclassified' 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: 'as yet unclassified' 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 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: 'stephaneducasse 2/4/2006 20:47'! notify: aString | message | message := self messageTo: aString. SMTPClient deliverMailFrom: message from to: (Array with: message to) text: message text usingServer: MailSender smtpServer! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCVersionNotification class instanceVariableNames: ''! !MCVersionNotification class methodsFor: 'as yet unclassified' stamp: 'avi 8/26/2004 14:27'! version: aVersion repository: aRepository ^ self basicNew initializeWithVersion: aVersion repository: aRepository! ! MCReader subclass: #MCVersionReader instanceVariableNames: 'package info definitions dependencies' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Storing'! !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: 'accessing' stamp: 'avi 1/19/2004 14:50'! dependencies dependencies ifNil: [self loadDependencies]. ^ dependencies! ! !MCVersionReader methodsFor: 'accessing' stamp: 'ab 8/20/2003 19:53'! info info ifNil: [self loadVersionInfo]. ^ info! ! !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:54'! snapshot ^ MCSnapshot fromDefinitions: self definitions! ! !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: 'loading' stamp: 'avi 1/19/2004 14:50'! loadDependencies self subclassResponsibility ! ! !MCVersionReader methodsFor: 'loading' stamp: 'ab 8/20/2003 19:54'! loadPackage self subclassResponsibility ! ! !MCVersionReader methodsFor: 'loading' stamp: 'ab 8/20/2003 19:54'! loadVersionInfo self subclassResponsibility! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCVersionReader class instanceVariableNames: ''! !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: '*monticello-file services' stamp: 'nk 2/25/2005 11:17'! mergeVersionStream: stream (self versionFromStream: stream) merge! ! !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: '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 ]! ! !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: '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: '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: '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: 'cwp 8/1/2003 14:46'! mergeVersionFile: fileName (self versionFromFile: fileName) merge! ! !MCVersionReader class methodsFor: 'System-FileRegistry' stamp: 'cwp 8/1/2003 14:46'! openVersionFile: fileName (self versionFromFile: fileName) open! ! !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: 'System-FileRegistry' stamp: 'pavel.krivanek 10/24/2010 19:38'! unload FileServices unregisterFileReader: self ! ! !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: 'reading' stamp: 'cwp 7/31/2003 23:03'! versionFromFile: fileName ^ self file: fileName streamDo: [:stream | self versionFromStream: stream]! ! !MCVersionReader class methodsFor: 'reading' stamp: 'avi 1/21/2004 22:58'! versionFromStream: aStream ^ (self on: aStream) version! ! !MCVersionReader class methodsFor: 'reading' stamp: 'avi 1/21/2004 22:59'! versionInfoFromStream: aStream ^ (self on: aStream) info! ! Object subclass: #MCVersionSorter instanceVariableNames: 'layers depthIndex depths stepparents roots' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Versioning'! !MCVersionSorter methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'avi 8/31/2003 21:30'! addAllVersionInfos: aCollection aCollection do: [:ea | self addVersionInfo: ea]! ! !MCVersionSorter methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'avi 9/11/2004 10:49'! addVersionInfo: aVersionInfo roots add: aVersionInfo. self registerStepChildrenOf: aVersionInfo seen: Set new! ! !MCVersionSorter methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! allAncestorsOf: aVersionInfo | all | all := Set new. self addAllAncestorsOf: aVersionInfo to: all. ^ all! ! !MCVersionSorter methodsFor: 'as yet unclassified' stamp: 'alain.plantec 5/28/2009 10:04'! initialize super initialize. stepparents := Dictionary new. roots := OrderedCollection new.! ! !MCVersionSorter methodsFor: 'as yet unclassified' stamp: 'avi 9/11/2004 14:37'! knownAncestorsOf: aVersionInfo ^ aVersionInfo ancestors, (self stepParentsOf: aVersionInfo) asArray! ! !MCVersionSorter methodsFor: 'as yet unclassified' stamp: 'ab 8/17/2003 15:53'! layers ^ layers! ! !MCVersionSorter methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! popLayer depthIndex := depthIndex - 1! ! !MCVersionSorter methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! pushLayer depthIndex := depthIndex + 1. depthIndex > layers size ifTrue: [layers add: OrderedCollection new]. ! ! !MCVersionSorter methodsFor: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'avi 9/11/2004 10:40'! stepParentsOf: aVersionInfo ^ (stepparents at: aVersionInfo ifAbsentPut: [Set new])! ! MCTestCase subclass: #MCVersionTest instanceVariableNames: 'version visited' classVariableNames: '' poolDictionaries: '' category: 'Tests-Monticello'! !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: '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: 'building' stamp: 'cwp 11/7/2004 12:29'! dependencyFromTree: sexpr ^ MCMockDependency fromTree: sexpr! ! !MCVersionTest methodsFor: 'building' stamp: 'cwp 11/7/2004 12:40'! versionFromTree: sexpr ^ (self dependencyFromTree: sexpr) resolve! ! !MCVersionTest methodsFor: 'running' stamp: 'stephaneducasse 2/4/2006 20:47'! setUp visited := OrderedCollection new.! ! !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:50'! testAllMissing self assert: #allDependenciesDo: orders: #(a ((b (d e)) (c missing))) as: #(d e b)! ! !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: '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:22'! testWithAll self assert: #withAllDependenciesDo: orders: #(a ((b (d e)) c)) as: #(d e b c a)! ! !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)! ! !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)! ! MCAncestry subclass: #MCWorkingAncestry instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Versioning'! !MCWorkingAncestry commentStamp: '' prior: 0! 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: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! addAncestor: aNode ancestors := (self ancestors reject: [:each | aNode hasAncestor: each]) copyWith: aNode! ! !MCWorkingAncestry methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! addStepChild: aVersionInfo stepChildren := stepChildren copyWith: aVersionInfo! ! !MCWorkingAncestry methodsFor: 'as yet unclassified' 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! ! !MCWorkingAncestry methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2004 01:14'! name ^ ''! ! !MCWorkingAncestry methodsFor: 'as yet unclassified' stamp: 'avi 2/13/2004 01:14'! summary ^ 'Ancestors: ', self ancestorString! ! MCPackageManager subclass: #MCWorkingCopy instanceVariableNames: 'versionInfo ancestry counter repositoryGroup requiredPackages' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Versioning'! !MCWorkingCopy commentStamp: 'StephaneDucasse 4/29/2011 20:44' prior: 0! 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: '*metacello-mc' stamp: 'dkh 4/17/2011 13:10'! 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: 'accessing' stamp: 'avi 2/13/2004 01:07'! ancestors ^ ancestry ancestors! ! !MCWorkingCopy methodsFor: 'accessing' stamp: 'avi 2/13/2004 01:13'! ancestry ^ ancestry! ! !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: '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: 'avi 2/13/2004 20:01'! currentVersionInfo ^ (self needsSaving or: [ancestry ancestors isEmpty]) ifTrue: [self newVersion info] ifFalse: [ancestry ancestors first]! ! !MCWorkingCopy methodsFor: 'accessing' stamp: 'AndrewBlack 9/4/2009 14:00'! currentVersionInfoWithMessage: aMessageString ^ (self needsSaving or: [ancestry ancestors isEmpty]) ifTrue: [(self newVersionWithMessage: aMessageString) info] ifFalse: [ancestry ancestors first]! ! !MCWorkingCopy methodsFor: 'accessing' stamp: 'bp 11/21/2010 18:33'! description ^ self packageNameWithStar, ' (', (ancestry ancestorStringWithout: self packageName), ')'! ! !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: 'avi 2/13/2004 20:02'! needsSaving ^ self modified or: [self requiredPackages anySatisfy: [:ea | ea workingCopy needsSaving]]! ! !MCWorkingCopy methodsFor: 'accessing' stamp: 'stephane.ducasse 2/6/2009 18:31'! removeRequiredPackage: aPackage requiredPackages remove: aPackage ifAbsent: [] ! ! !MCWorkingCopy methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! requiredPackages ^ requiredPackages ifNil: [requiredPackages := OrderedCollection new]! ! !MCWorkingCopy methodsFor: 'accessing' stamp: 'avi 1/20/2004 16:04'! requirePackage: aPackage (self requiredPackages includes: aPackage) ifFalse: [requiredPackages add: aPackage]! ! !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: 'accessing' stamp: 'CamilloBruni 9/30/2011 16:25'! snapshot ^ self package snapshot! ! !MCWorkingCopy methodsFor: 'accessing' stamp: 'SeanDeNigris 7/17/2012 15:50'! theCachedRepository ^ MCCacheRepository uniqueInstance.! ! !MCWorkingCopy methodsFor: 'accessing' stamp: 'stephaneducasse 2/4/2006 20:47'! versionInfo: aVersionInfo ancestry := MCWorkingAncestry new addAncestor: aVersionInfo! ! !MCWorkingCopy methodsFor: 'operations' stamp: 'avi 2/13/2004 01:07'! adopt: aVersion ancestry addAncestor: aVersion info. self changed.! ! !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: 'CamilloBruni 1/19/2012 18:35'! changesRelativeToRepository: aRepository ^ self completeSnapshot patchRelativeToBase: (self closestAncestorSnapshotIn: aRepository).! ! !MCWorkingCopy methodsFor: 'operations' stamp: 'stephaneducasse 2/4/2006 20:47'! clearRequiredPackages requiredPackages := nil! ! !MCWorkingCopy methodsFor: 'operations' stamp: 'CamilloBruni 3/2/2012 15:07'! collectDependenciesWithMessage: messageString ^ self requiredPackages collect: [:aPackage | MCVersionDependency package: aPackage info: (aPackage workingCopy currentVersionInfoWithMessage: messageString)] ! ! !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: '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 methodsFor: 'operations' stamp: 'StephaneDucasse 4/27/2010 11:52'! 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: 'operations' stamp: 'StephaneDucasse 12/19/2012 14:21'! newVersion ^ (self requestVersionNameAndMessageWithSuggestion: self uniqueVersionName) ifNotNil: [:pair | self newVersionWithName: pair first trimBoth message: pair last]. ! ! !MCWorkingCopy methodsFor: 'operations' stamp: 'AndrewBlack 9/4/2009 14:09'! newVersionWithMessage: aMessageString ^ self newVersionWithName: self uniqueVersionName message: aMessageString. "^ (self requestVersionNameAndMessageWithSuggestion: self uniqueVersionName) ifNotNil: [:pair | self newVersionWithName: pair first message: aMessageString]. "! ! !MCWorkingCopy methodsFor: 'operations' stamp: 'CamilloBruni 3/2/2012 13:42'! newVersionWithName: nameString message: messageString | info deps | info := ancestry infoWithName: nameString message: messageString. ancestry := MCWorkingAncestry new addAncestor: info. self modified: true; modified: false. deps := self collectDependenciesWithMessage: messageString. ^ MCVersion package: package info: info snapshot: package snapshot dependencies: deps! ! !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: 'EstebanLorenzano 10/17/2012 17:00'! unload MCPackageLoader unloadPackage: self package. package packageSet unregister. self unregister.! ! !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: 'repositories' stamp: 'stephaneducasse 2/4/2006 20:47'! repositoryGroup ^ repositoryGroup ifNil: [repositoryGroup := MCRepositoryGroup new]! ! !MCWorkingCopy methodsFor: 'repositories' stamp: 'stephaneducasse 2/4/2006 20:47'! repositoryGroup: aRepositoryGroup repositoryGroup := aRepositoryGroup! ! !MCWorkingCopy methodsFor: 'private' stamp: 'StephaneDucasse 1/16/2010 10:51'! 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" ^ aVersionInfo ifNil: [MCSnapshot empty] ifNotNil: [(self repositoryGroup versionWithInfo: aVersionInfo) ifNil: [MCSnapshot empty] ifNotNil: [:aVersion | aVersion snapshot]] ! ! !MCWorkingCopy methodsFor: 'private' stamp: 'stephaneducasse 2/4/2006 20:47'! initialize super initialize. ancestry := MCWorkingAncestry new! ! !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: 'private' stamp: 'bf 9/8/2005 10:58'! possiblyNewerVersions ^Array streamContents: [:strm | self repositoryGroup repositories do: [:repo | strm nextPutAll: (self possiblyNewerVersionsIn: repo)]]! ! !MCWorkingCopy methodsFor: 'private' stamp: 'bf 9/8/2005 10:58'! possiblyNewerVersionsIn: aRepository ^aRepository possiblyNewerVersionsOfAnyOf: self ancestors! ! !MCWorkingCopy methodsFor: 'private' stamp: 'ab 8/24/2003 20:38'! requestVersionNameAndMessageWithSuggestion: aString ^ (MCVersionNameAndMessageRequest new suggestedName: aString) signal! ! !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: 'private' stamp: 'avi 2/4/2004 14:11'! versionSeparator ^ $_! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCWorkingCopy class instanceVariableNames: ''! !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: 'initialize' stamp: 'CamilleTeruel 7/30/2012 14:09'! initialize "self initialize" registry ifNotNil: [ registry rehash ]. self registerForNotifications.! ! !MCWorkingCopy class methodsFor: 'querying' stamp: 'sd 1/24/2013 10:52'! hasPackageNamed: aName " self hasPackageNamed: 'ConfigurationOfFuel' " ^ MCWorkingCopy allManagers detect: [ :each | each packageName = aName ] ifNone: [ nil ].! ! !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: 'private' stamp: 'avi 2/17/2004 01:23'! ancestorsFromArray: anArray cache: aDictionary ^ anArray ifNotNil: [anArray collect: [:dict | self infoFromDictionary: dict cache: aDictionary]]! ! !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)]! ! MCTool subclass: #MCWorkingCopyBrowser instanceVariableNames: 'workingCopy workingCopyWrapper repository defaults order repositoryPattern workingCopyPattern' classVariableNames: 'Order' poolDictionaries: '' category: 'MonticelloGUI'! !MCWorkingCopyBrowser methodsFor: '*Polymorph-Tools-Diff' stamp: 'SeanDeNigris 6/21/2012 09:07'! 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 isNil ifTrue: [^ self]. 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})]]! ! !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 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: 'actions' stamp: 'BenjaminVanRyseghem 10/18/2012 16:16'! addRepository self newRepository ifNotNil: [:repos | self addRepository: repos. workingCopy ifNil: [ repos morphicOpen: nil ]]. ! ! !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: '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 8/3/2011 14:50'! addRepository: aRepository self repository: aRepository. self repositoryGroup addRepository: aRepository. self repositoryListChanged; changed: #repositorySelection. self changedButtons.! ! !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: '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: 'actions' stamp: 'CamilloBruni 8/3/2011 14:51'! addSlice (MCSliceMaker openFor: self window) ifNotNil: [:sliceInfo | workingCopy := sliceInfo makeSlice. workingCopy ifNotNil: [ workingCopyWrapper := MCDependentsWrapper with: workingCopy model: self. self addRepository: MCHttpRepository inboxRepository. self repositorySelection: 0.]]. self workingCopyListChanged; changed: #workingCopySelection; repositoryListChanged. self changedButtons. ! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'CamilloBruni 8/3/2011 14:51'! addWorkingCopy |name| name := UIManager default request: 'Name of package:' translated. name isEmptyOrNil ifFalse: [PackageInfo registerPackageName: 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: '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 10/10/2012 15:29'! basicSaveVersionIn: aRepository | newVersion waitForVersion | waitForVersion := Semaphore new. WorldState addDeferredUIMessage: [ newVersion := workingCopy newVersion. waitForVersion signal ]. self flag: 'TODO: only wait when not called from UI thread due. Will lock the UI otherwise'. waitForVersion wait. newVersion ifNil: [ ^ self ]. Cursor wait showWhile: [ [ aRepository storeVersion: newVersion. aRepository storeDependencies: newVersion ] ensure: [ (MCVersionInspector new version: newVersion) show ]]! ! !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: 'actions' stamp: 'avi 9/14/2004 14:57'! canBackport ^ self hasWorkingCopy and: [workingCopy needsSaving not]! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'StephaneDucasse 2/11/2012 10:52'! checkForNewerVersions | newer | newer := workingCopy possiblyNewerVersionsIn: self repository. ^ newer isEmpty or: [ self confirm: 'CAUTION!! These versions in the repository may be newer:', String cr, (newer asString truncateWithElipsisTo: 300), String cr, 'Do you really want to save this version?'].! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'marcus.denker 11/10/2008 10:04'! clearRequiredPackages workingCopy ifNotNil: [:wc | wc clearRequiredPackages. self workingCopyListChanged]! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'ar 2/14/2004 02:46'! deleteWorkingCopy workingCopy unregister. self workingCopySelection: 0. self workingCopyListChanged.! ! !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'! editRepository | newRepo | newRepo := self repository openAndEditTemplateCopy. newRepo ifNotNil: [ newRepo class = self repository class ifTrue: [self repository copyFrom: newRepo] ifFalse: [self inform: 'Must not change repository type!!']]. self repositoryListChanged! ! !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: 'actions' stamp: 'avi 9/11/2004 15:32'! inspectWorkingCopy workingCopy ifNotNil: [workingCopy inspect]! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'CamilloBruni 8/3/2011 14:51'! loadRepositories FileStream fileIn: 'MCRepositories.st'. self repositoryListChanged. self changedButtons. ! ! !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: 'actions' stamp: 'CamilloBruni 10/10/2012 14:37'! openRepository self repository ifNotNil: [:repos | repos morphicOpen: workingCopy ]! ! !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: '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: '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: 'stephaneducasse 2/4/2006 20:47'! repository workingCopy ifNotNil: [repository := self defaults at: workingCopy ifAbsent: []]. ^ repository! ! !MCWorkingCopyBrowser methodsFor: 'actions' stamp: 'stephaneducasse 2/4/2006 20:47'! repository: aRepository repository := aRepository. workingCopy ifNotNil: [self defaults at: workingCopy put: aRepository]! ! !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: '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: 'actions' stamp: 'CamilloBruni 10/10/2012 15:29'! 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: '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: '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: '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: '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:41'! historyMenuSpec ^ #(#('Browse package' #browseWorkingCopy) #('View changes' #viewChanges) #('View history' #viewHistory)) ! ! !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: '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: 'menu spec' stamp: 'StephaneDucasse 5/19/2011 14:44'! revertPackageMenuSpec ^ #(#('Revert package...' #revertPackage) #('Recompile package' #recompilePackage) #('Backport package...' #backportChanges) #('Inspect package' #inspectWorkingCopy)) ! ! !MCWorkingCopyBrowser methodsFor: 'menu spec' stamp: 'StephaneDucasse 5/19/2011 14:51'! unloadPackageMenuSpec ^ #(#('Unload package' #unloadPackage) #('Delete working copy' #deleteWorkingCopy))! ! !MCWorkingCopyBrowser methodsFor: 'menu spec' stamp: 'CamilloBruni 3/13/2012 18:42'! 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. 1. 0.}. {0. 30. 0. searchBarOffset.}}. {{#listMorph:. #repository}. {0.5. 0. 1. 1}. {0. searchBarOffset+3. 0. 0.}}. }.! ! !MCWorkingCopyBrowser methodsFor: 'metacello' stamp: 'DaleHenrichs 11/5/2010 13:32'! 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'. ! ! !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: 'metacello' stamp: 'AlexandreBergel 10/27/2010 22:48'! browseConfiguration self configurationClass browse! ! !MCWorkingCopyBrowser methodsFor: 'metacello' stamp: 'AlexandreBergel 10/27/2010 12:24'! configurationClass ^ Smalltalk globals at: workingCopy package name asSymbol ! ! !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: '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: '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: '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: 'metacello' stamp: 'AlexandreBergel 11/11/2010 16:55'! hasAnyBaseline ^ self baseLines notEmpty! ! !MCWorkingCopyBrowser methodsFor: 'metacello' stamp: 'AlexandreBergel 10/27/2010 23:18'! lastBaseLine ^ self baseLines last! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ab 8/7/2003 21:22'! canSave ^ self hasWorkingCopy and: [self hasRepository]! ! !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: 'PatrickBarroca 6/5/2010 17:36'! defaultExtent ^ 620@200! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ab 7/19/2003 23:38'! defaultLabel ^ 'Monticello Browser'! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'stephaneducasse 2/4/2006 20:47'! defaults ^ defaults ifNil: [defaults := Dictionary new]! ! !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: '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: '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: 'morphic ui' stamp: 'ab 7/22/2003 02:21'! hasRepository ^ self repository notNil! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ab 7/22/2003 00:46'! hasWorkingCopy ^ workingCopy notNil! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'StephaneDucasse 5/15/2012 17:02'! initialize super initialize. order := self class order. self registerToAnnouncer. ! ! !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: '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: '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: '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: 'nk 3/9/2004 14:39'! pickWorkingCopy ^self pickWorkingCopySatisfying: [ :c | true ]! ! !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: 'EstebanLorenzano 8/3/2012 14:11'! 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: 'morphic ui' stamp: 'DanielUber 6/9/2012 09:47'! repositories |repositories| repositories := self repositoryGroup repositories. "filter the repository list if there is a search string" repositoryPattern ifNotNil: [ repositories := repositories select: [ :each| repositoryPattern search: each description]]. ^ repositories! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ab 8/7/2003 21:32'! repositoryGroup ^ workingCopy ifNil: [MCRepositoryGroup default] ifNotNil: [workingCopy repositoryGroup]! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'DanielUber 6/9/2012 09:39'! repositoryList |repositories| repositories := self repositories. ^ repositories collect: [:ea | ea description]! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'CamilloBruni 8/3/2011 14:49'! repositoryListChanged self changed: #repositoryList.! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'StephaneDucasse 5/19/2011 14:53'! 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: 'morphic ui' stamp: 'CamilloBruni 8/3/2011 14:34'! repositoryMaxSearchSize ^self class repositoryMaxSearchSize! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'CamilloBruni 1/16/2012 21:51'! repositorySearchAccept: aString aString isEmptyOrNil ifTrue: [ repositoryPattern := nil ] ifFalse: [ repositoryPattern := [ aString asRegexIgnoringCase ] on: RegexSyntaxError do: [ aString ]]. self repositoryListChanged.! ! !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: 'morphic ui' stamp: 'CamilloBruni 8/3/2011 14:40'! repositorySearchMaxSize ^self class repositorySearchMaxSize! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ab 7/22/2003 02:22'! repositorySelection ^ self repositories indexOf: self repository! ! !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: 'avi 8/31/2004 01:14'! toggleDiffs self repository alwaysStoreDiffs ifTrue: [self repository doNotAlwaysStoreDiffs] ifFalse: [self repository doAlwaysStoreDiffs]! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'StephaneDucasse 6/2/2012 20:35'! unsortedWorkingCopies ^ self allManagers ! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'StephaneDucasse 5/15/2012 17:03'! update: anAnnouncement self workingCopyListChanged.! ! !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: 'avi 1/19/2004 16:41'! workingCopyList ^ self workingCopies collect: [:ea | (workingCopy notNil and: [workingCopy requiredPackages includes: ea package]) ifTrue: [Text string: ea description emphasis: (Array with: TextEmphasis bold)] ifFalse: [ea description]]! ! !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: '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: '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: 'morphic ui' stamp: 'CamilloBruni 1/16/2012 21:33'! workingCopySearchAccept: aString aString isEmptyOrNil ifTrue: [ workingCopyPattern := nil ] ifFalse: [ workingCopyPattern := [ aString asRegexIgnoringCase ] on: RegexSyntaxError do: [ aString ] ]. self workingCopyListChanged.! ! !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: '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: 'morphic ui' stamp: 'CamilloBruni 8/3/2011 14:43'! workingCopySearchMaxSize ^self class workingCopySearchMaxSize! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ab 7/19/2003 22:05'! workingCopySelection ^ self workingCopies indexOf: workingCopy! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'ar 2/14/2004 02:38'! workingCopySelectionWrapper ^workingCopyWrapper! ! !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: '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: 'CamilloBruni 1/16/2012 21:40'! workingCopyTree |workingCopies| workingCopies := self workingCopies. "filter the working copy list if there is a serach string" workingCopyPattern ifNotNil: [ workingCopies := workingCopies select: [ :each| workingCopyPattern search: each package name]]. ^ workingCopies collect: [:each| MCDependentsWrapper with: each model: self].! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'lr 3/23/2010 09:58'! workingCopyTreeChildren: aWrapper ^ aWrapper contents! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'lr 3/23/2010 09:57'! workingCopyTreeHasChildren: aWrapper ^ aWrapper hasContents! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'lr 3/23/2010 09:57'! workingCopyTreeLabel: aWrapper ^ aWrapper asString! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'lr 10/14/2008 14:24'! workingCopyTreeMenu: aMenu ^ self workingCopyListMenu: aMenu! ! !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: 'morphic ui' stamp: 'CamilloBruni 8/3/2011 14:51'! workingCopy: wc workingCopy := wc. self changed: #workingCopySelection; repositoryListChanged. self changedButtons. ! ! !MCWorkingCopyBrowser methodsFor: 'morphic ui' stamp: 'c 8/10/2010 22:58'! workingCopyTreePath workingCopy ifNil: [^ OrderedCollection new]. ^ OrderedCollection with: workingCopyWrapper.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCWorkingCopyBrowser class instanceVariableNames: 'repositorySearchMaxSize workingCopySearchMaxSize workingCopySearchList repositorySearchList'! !MCWorkingCopyBrowser class methodsFor: '*famfam-icons-extensions' stamp: 'EstebanLorenzano 4/26/2012 13:28'! taskbarIcon "Answer the icon for the receiver in a task bar." ^ self theme iconNamed: #versionControlIcon! ! !MCWorkingCopyBrowser class methodsFor: 'as yet unclassified' stamp: 'sd 6/5/2011 19:08'! open self new show! ! !MCWorkingCopyBrowser class methodsFor: 'as yet unclassified' stamp: 'lr 10/14/2008 14:21'! order ^ Order ifNil: [ Order := 1 ]! ! !MCWorkingCopyBrowser class methodsFor: 'as yet unclassified' stamp: 'lr 10/14/2008 14:21'! order: anInteger Order := anInteger! ! !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: 'CamilloBruni 8/3/2011 14:40'! repositorySearchMaxSize ^ repositorySearchMaxSize ifNil: [repositorySearchMaxSize := 15] ! ! !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: 'tools registry' stamp: 'IgorStasenko 2/19/2011 04:06'! registerToolsOn: registry registry register: self as: #monticelloBrowser! ! Announcement subclass: #MCWorkingCopyCreated instanceVariableNames: 'package workingCopy' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Announcements'! !MCWorkingCopyCreated commentStamp: '' prior: 0! A MCWorkingCopyCreated is a announcement raised when a new MCWorkingCopy is created! !MCWorkingCopyCreated methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/25/2012 19:55'! package ^ package! ! !MCWorkingCopyCreated methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/25/2012 19:55'! package: anObject package := anObject! ! !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 class instanceVariableNames: ''! !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! ! Announcement subclass: #MCWorkingCopyDeleted instanceVariableNames: 'package workingCopy' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Announcements'! !MCWorkingCopyDeleted commentStamp: '' prior: 0! A MCWorkingCopyDeleted class is an announcement raised when a MCWorkingCopy is removed! !MCWorkingCopyDeleted methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/25/2012 20:24'! package ^ package! ! !MCWorkingCopyDeleted methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/25/2012 20:24'! package: anObject package := anObject! ! !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 class instanceVariableNames: ''! !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! ! MCTestCase subclass: #MCWorkingCopyTest instanceVariableNames: 'workingCopy repositoryGroup versions versions2 savedName' classVariableNames: '' poolDictionaries: '' category: 'Tests-Monticello'! !MCWorkingCopyTest methodsFor: 'accessing' stamp: 'ab 7/7/2003 18:02'! description ^ self class name! ! !MCWorkingCopyTest methodsFor: 'actions' stamp: 'avi 2/13/2004 14:30'! basicMerge: aVersion aVersion merge! ! !MCWorkingCopyTest methodsFor: 'actions' stamp: 'avi 1/24/2004 20:13'! load: aVersion aVersion load! ! !MCWorkingCopyTest methodsFor: 'actions' stamp: 'jf 8/21/2003 20:22'! merge: aVersion [[self basicMerge: aVersion] on: MCMergeResolutionRequest do: [:n | n resume: true]] on: MCNoChangesException do: [:n | ]! ! !MCWorkingCopyTest methodsFor: 'actions' stamp: 'stephaneducasse 2/4/2006 20:47'! snapshot | version | [version := workingCopy newVersion] on: MCVersionNameAndMessageRequest do: [:n | n resume: (Array with: n suggestedName with: '')]. versions at: version info put: version. ^ version! ! !MCWorkingCopyTest methodsFor: 'asserting' stamp: 'stephaneducasse 2/4/2006 20:47'! assertNameWhenSavingTo: aRepository is: aString | name | name := nil. [aRepository storeVersion: workingCopy newVersion] on: MCVersionNameAndMessageRequest do: [:n | name := n suggestedName. n resume: (Array with: name with: '')]. self assert: name = aString! ! !MCWorkingCopyTest methodsFor: 'asserting' stamp: 'MiguelCoba 7/25/2009 02:01'! assertNumberWhenSavingTo: aRepository is: aNumber | name | name := nil. [aRepository storeVersion: workingCopy newVersion] on: MCVersionNameAndMessageRequest do: [:n | name := n suggestedName. n resume: (Array with: name with: '')]. self assert: name = (self packageName, '-', Author fullName, '.', aNumber asString)! ! !MCWorkingCopyTest methodsFor: 'running' stamp: 'GuillermoPolito 8/24/2012 14:03'! clearPackageCache | dir | dir := MCCacheRepository uniqueInstance directory. " (dir filesMatching: 'MonticelloMocks*') do: [:ea | ea ensureDeleted ]." (dir filesMatching: 'MonticelloTest*') do: [:ea | ea ensureDeleted]. (dir filesMatching: 'rev*') do: [:ea | ea ensureDeleted]. (dir filesMatching: 'foo-*') do: [:ea | ea ensureDeleted]. (dir filesMatching: 'foo2-*') do: [:ea | ea ensureDeleted].! ! !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: 'running' stamp: 'MiguelCoba 7/25/2009 02:03'! tearDown workingCopy unregister. self restoreMocks. self clearPackageCache. Author fullName: savedName.! ! !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: '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: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! 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 shouldnt: [self merge: motherA2] raise: Error. self shouldnt: [self merge: motherB2] raise: Error. 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'! 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) ! ! !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: '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'! testRedundantMerge | base | base := self snapshot. self merge: base. self shouldnt: [self merge: base] raise: Error.! ! !MCWorkingCopyTest methodsFor: 'tests' stamp: 'stephaneducasse 2/4/2006 20:47'! 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 shouldnt: [self merge: mother2] raise: Error. self assert: inst one = 7. self assert: inst two = 3.! ! !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: '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: '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'! 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: 'private' stamp: 'cwp 8/2/2003 15:03'! packageName ^ self mockPackage name! ! MCVersionHistoryBrowser subclass: #MCWorkingHistoryBrowser instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MonticelloGUI'! !MCWorkingHistoryBrowser methodsFor: 'as yet unclassified' stamp: 'ab 8/22/2003 01:37'! baseSnapshot ^ package snapshot! ! MCRepository subclass: #MCWriteOnlyRepository instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Repositories'! !MCWriteOnlyRepository methodsFor: '*MonticelloGUI' stamp: 'avi 10/9/2003 12:53'! morphicOpen: aWorkingCopy self inform: 'This repository is write-only'! ! !MCWriteOnlyRepository methodsFor: 'as yet unclassified' stamp: 'avi 10/9/2003 12:52'! includesVersionNamed: aString ^ false! ! !MCWriteOnlyRepository methodsFor: 'as yet unclassified' stamp: 'avi 10/9/2003 12:52'! versionWithInfo: aVersionInfo ifAbsent: aBlock ^ aBlock value! ! Object subclass: #MCWriter instanceVariableNames: 'stream' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Storing'! !MCWriter methodsFor: 'as yet unclassified' stamp: 'cwp 8/1/2003 01:14'! stream ^ stream! ! !MCWriter methodsFor: 'as yet unclassified' stamp: 'stephaneducasse 2/4/2006 20:47'! stream: aStream stream := aStream! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MCWriter class instanceVariableNames: ''! !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! ! HashFunction subclass: #MD5 instanceVariableNames: 'state' classVariableNames: '' poolDictionaries: '' category: 'System-Hashing-MD5'! !MD5 commentStamp: 'ul 3/3/2008 23:40' prior: 0! 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: '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: '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: 'ul 3/3/2008 21:34'! finalValue ^state! ! !MD5 methodsFor: 'private-buffers' stamp: 'ul 3/3/2008 22:28'! primProcessBuffer: aByteArray withState: s self primitiveFailed! ! !MD5 methodsFor: 'private-buffers' stamp: 'ul 3/3/2008 19:17'! processBuffer: aByteArray self primProcessBuffer: aByteArray withState: state. ! ! !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 class instanceVariableNames: ''! !MD5 class methodsFor: 'accessing' stamp: 'ul 3/3/2008 23:37'! blockSize ^ 64! ! !MD5 class methodsFor: 'accessing' stamp: 'ul 3/3/2008 23:37'! hashSize ^ 16! ! !MD5 class methodsFor: 'as yet unclassified' stamp: 'ul 3/3/2008 22:46'! isPluginAvailable ^false! ! !MD5 class methodsFor: 'as yet unclassified' stamp: 'ul 3/3/2008 23:01'! new self isPluginAvailable ifTrue: [ ^self basicNew ] ifFalse: [ ^MD5NonPrimitive basicNew ]! ! MD5 subclass: #MD5NonPrimitive instanceVariableNames: '' classVariableNames: 'ABCDTable IndexTable ShiftTable SinTable' poolDictionaries: '' category: 'System-Hashing-MD5'! !MD5NonPrimitive commentStamp: '' prior: 0! 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: '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-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-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:47'! fX: x Y: y Z: z " compute 'xy or (not x)z'" ^ x copy bitAnd: y; bitOr: (x copy bitInvert; bitAnd: z) ! ! !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'! 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'! 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-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 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'! 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-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: '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 class instanceVariableNames: ''! !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 ) }! ! Object subclass: #MFClassA instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Manifest-Resources-Tests'! !MFClassA commentStamp: 'SimonAllier 1/17/2012 10:44' prior: 0! 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.! ! Object subclass: #MFClassB instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Manifest-Resources-Tests'! !MFClassB methodsFor: 'as yet unclassified' stamp: 'SimonAllier 5/29/2012 15:49'! method2 |foo|! ! !MFClassB methodsFor: 'as yet unclassified' stamp: 'SimonAllier 5/29/2012 15:49'! method3 |foo| self halt.! ! Object subclass: #MIMEDocument instanceVariableNames: 'type contents contentStream uri' classVariableNames: '' poolDictionaries: '' category: 'Network-MIME'! !MIMEDocument commentStamp: '' prior: 0! a MIME object, along with its type and the URL it was found at (if any)! !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: '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/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/26/2005 11:13'! discardContents contents := nil. self discardContentStream! ! !MIMEDocument methodsFor: 'accessing' stamp: 'mir 3/4/2002 17:19'! mainType ^self mimeType main! ! !MIMEDocument methodsFor: 'accessing' stamp: 'mir 3/4/2002 17:19'! mimeType ^type! ! !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: 'accessing' stamp: 'mir 3/4/2002 17:19'! subType ^self mimeType sub! ! !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/27/2005 10:55'! uri "Answer the URL the receiver was downloaded from. It may legitimately be nil." ^uri! ! !MIMEDocument methodsFor: 'accessing' stamp: 'mir 3/27/2005 10:53'! uri: aURI uri := aURI! ! !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: 'compatibility' stamp: 'mir 3/22/2005 22:55'! content ^self contents! ! !MIMEDocument methodsFor: 'compatibility' stamp: 'mir 3/4/2002 17:46'! contentType ^self mimeType asString! ! !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: 'testing' stamp: 'sbw 1/21/2001 11:13'! isGif ^ self mainType = 'image' and: [self subType = 'gif']! ! !MIMEDocument methodsFor: 'testing' stamp: 'sbw 1/21/2001 11:15'! isJpeg ^ self mainType = 'image' and: [self subType = 'jpeg' | (self subType = 'jpg')]! ! !MIMEDocument methodsFor: 'testing' stamp: 'ls 4/30/2000 18:07'! isMultipart ^self mainType = 'multipart'! ! !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: 'testing' stamp: 'st 9/18/2004 23:37'! isPng ^ self mainType = 'image' and: [self subType = 'png']! ! !MIMEDocument methodsFor: 'testing' stamp: 'st 9/18/2004 23:38'! isPnm ^ self mainType = 'image' and: [self subType = 'pnm']! ! !MIMEDocument methodsFor: 'private' stamp: 'mir 3/27/2005 10:53'! contentStream: aStream mimeType: aMimeType uri: aUri type := aMimeType. contentStream := aStream. uri := aUri! ! !MIMEDocument methodsFor: 'private' stamp: 'mir 3/27/2005 10:50'! contentStreamOnURI ^self uri contentStream! ! !MIMEDocument methodsFor: 'private' stamp: 'mir 3/27/2005 10:53'! contents: contentStringOrBytes mimeType: aMimeType uri: aURI type := aMimeType. contents := contentStringOrBytes. uri := aURI! ! !MIMEDocument methodsFor: 'private' stamp: 'mir 3/26/2005 11:12'! discardContentStream contentStream ifNotNil: [contentStream close]. contentStream := nil! ! !MIMEDocument methodsFor: 'private' stamp: 'mir 3/24/2005 17:37'! getContentFromStream | streamContents | streamContents := self contentStream contents. self discardContentStream. ^streamContents! ! !MIMEDocument methodsFor: 'private' stamp: 'mir 11/8/2005 13:39'! privateContent: aString contents := aString! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MIMEDocument class instanceVariableNames: ''! !MIMEDocument class methodsFor: 'accessing' stamp: 'michael.rueger 2/25/2009 12:35'! defaultMIMEType ^MIMEType fromMIMEString: 'application/octet-stream'! ! !MIMEDocument class methodsFor: 'compatibility' stamp: 'MarcusDenker 11/30/2010 11:09'! contentType: aMIMEType content: content "create a MIMEDocument with the given content-type and content" "MIMEDocument contentType: 'text/plain' content: 'This is a test'" | ans idx | ans := self new. ans privateContent: content. "parse the content-type" (aMIMEType isNil or: [ idx := aMIMEType asString indexOf: $/. idx = 0]) ifTrue: [ ans type: (MIMEType main: 'application' sub: 'octet-stream')] ifFalse: [ ans type: (MIMEType main: (aMIMEType asString copyFrom: 1 to: idx-1) sub: (aMIMEType asString copyFrom: idx+1 to: aMIMEType asString size))]. ^ans! ! !MIMEDocument class methodsFor: 'compatibility' stamp: 'Noury 6/15/2009 22:54'! contentType: type content: content url: url ^self contents: content mimeType: (MIMEType fromMIMEString: type asString) uri: url! ! !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'! guessContentTypeFromExtension: ext "guesses a content type from the extension" ^(self guessTypeFromExtension: ext) 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: 'compatibility' stamp: 'MarcusDenker 10/21/2011 14:58'! guessTypeFromName: url "guesses a content type from the url" ^ MIMEType forFileNameReturnSingleMimeTypeOrNil: url asString! ! !MIMEDocument class methodsFor: 'compatibility' stamp: 'michael.rueger 2/25/2009 12:29'! resetMIMEdatabase "no-op for catching Kom override"! ! !MIMEDocument class methodsFor: 'content-types' stamp: 'bolot 5/16/1999 12:25'! contentTypeFormData ^'application/x-www-form-urlencoded'! ! !MIMEDocument class methodsFor: 'content-types' stamp: 'bolot 5/16/1999 13:05'! contentTypeHtml ^'text/html'! ! !MIMEDocument class methodsFor: 'content-types' stamp: 'bolot 5/16/1999 12:25'! contentTypeMultipart ^'multipart/form-data'! ! !MIMEDocument class methodsFor: 'content-types' stamp: 'bolot 5/16/1999 13:05'! contentTypePlainText ^'text/plain'! ! !MIMEDocument class methodsFor: 'content-types' stamp: 'bolot 5/16/1999 13:05'! contentTypeXml ^'text/xml'! ! !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/4/2002 18:26'! contentStream: aStream ^self contentStream: aStream mimeType: MIMEType defaultStream! ! !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: '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! ! !MIMEDocument class methodsFor: 'instance creation' stamp: 'mir 3/4/2002 18:23'! contents: aString ^self contents: aString mimeType: MIMEType defaultStream! ! !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: '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! ! Object subclass: #MIMEHeaderValue instanceVariableNames: 'mainValue parameters' classVariableNames: '' poolDictionaries: '' category: 'Network-Mail'! !MIMEHeaderValue commentStamp: '' prior: 0! 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: 'accessing' stamp: 'dvf 4/27/2000 18:55'! mainValue ^mainValue! ! !MIMEHeaderValue methodsFor: 'accessing' stamp: 'dvf 4/27/2000 18:13'! mainValue: anObject mainValue := 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:18'! parameters ^parameters! ! !MIMEHeaderValue methodsFor: 'accessing' stamp: 'dvf 4/27/2000 18:11'! parameters: anObject parameters := anObject! ! !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: 'printing' stamp: 'ls 2/10/2001 12:37'! printOn: aStream super printOn: aStream. aStream nextPutAll: ': '. aStream nextPutAll: self asHeaderValue! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MIMEHeaderValue class instanceVariableNames: ''! !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] ! ! !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. ! ! MIMEDocument subclass: #MIMELocalFileDocument instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Network-MIME'! !MIMELocalFileDocument commentStamp: '' prior: 0! For local files, we do not read the entire contents unless we absolutely have to.! !MIMELocalFileDocument methodsFor: 'accessing' stamp: 'michael.rueger 1/8/2009 19:19'! content ^contents ifNil:[contents := contentStream contentsOfEntireFile].! ! !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 class instanceVariableNames: ''! !MIMELocalFileDocument class methodsFor: 'instance creation' stamp: 'ar 4/24/2001 16:31'! contentType: aString contentStream: aStream ^(self contentType: aString content: nil) contentStream: aStream! ! Object subclass: #MIMEType instanceVariableNames: 'main sub parameters' classVariableNames: 'DefaultSuffixes StandardMIMEMappings' poolDictionaries: '' category: 'FileSystem-Core-MIME'! !MIMEType commentStamp: 'LaurentLaffont 6/8/2011 22:18' prior: 0! 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: '*zinc-resource-meta-core' stamp: 'SvenVanCaekenberghe 1/4/2011 19:54'! asZnMimeType ^ ZnMimeType main: self main sub: self ! ! !MIMEType methodsFor: 'accessing' stamp: 'mir 3/4/2002 15:21'! main ^main! ! !MIMEType methodsFor: 'accessing' stamp: 'mir 3/4/2002 15:21'! main: mainType main := mainType! ! !MIMEType methodsFor: 'accessing' stamp: 'mir 2/16/2006 23:33'! parameters: params parameters := params! ! !MIMEType methodsFor: 'accessing' stamp: 'mir 3/4/2002 15:21'! sub ^sub! ! !MIMEType methodsFor: 'accessing' stamp: 'mir 3/4/2002 15:21'! sub: subType sub := subType! ! !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: '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: 'converting' stamp: 'mir 3/4/2002 18:21'! asMIMEType ^self! ! !MIMEType methodsFor: 'printing' stamp: 'mir 3/4/2002 16:14'! printOn: stream stream nextPutAll: main; nextPut: $/ ; nextPutAll: sub! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MIMEType class instanceVariableNames: ''! !MIMEType class methodsFor: 'accessing' stamp: 'michael.rueger 2/24/2009 18:42'! defaultSuffixes "MIMEType defaultSuffixes" ^DefaultSuffixes! ! !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: 'mir 3/4/2002 16:15'! mimeMappings ^StandardMIMEMappings! ! !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: 'accessing' stamp: 'JMM 12/2/2007 14:31'! suffixForMimeType: mimeType ^self defaultSuffixes at: mimeType printString ifAbsent: [mimeType sub]! ! !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: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: 'class initialization' stamp: 'michael.rueger 2/24/2009 18:43'! initializeStandardMIMETypes "MIMEType initializeStandardMIMETypes" StandardMIMEMappings := Dictionary new. self standardMIMETypes keysAndValuesDo:[:extension :mimeStrings | StandardMIMEMappings at: extension asString asLowercase put: (mimeStrings collect: [:mimeString | MIMEType fromMIMEString: mimeString]). ].! ! !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: '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/6/2002 13:07'! contentTypeURLEncoded ^self main: 'application' sub: 'x-www-form-urlencoded'! ! !MIMEType class methodsFor: 'instance creation' stamp: 'mir 3/4/2002 17:06'! defaultHTML ^self main: 'text' sub: 'html'! ! !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 15:23'! defaultText ^self main: 'text' sub: 'plain'! ! !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: 'instance creation' stamp: 'JMM 12/1/2007 17:03'! forFileNameReturnMimeTypesOrDefault: fileName | mimeTypes | mimeTypes := self forFileNameReturnMimeTypesOrNil: fileName. mimeTypes ifNil: [^Array with: (MIMEType defaultStream)]. ^mimeTypes! ! !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: 'instance creation' stamp: 'JMM 12/1/2007 23:02'! forFileNameReturnSingleMimeTypeOrDefault: fileName | types | types := self forFileNameReturnMimeTypesOrDefault: fileName. ^types first! ! !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: '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: 'mir 3/4/2002 15:22'! main: mainType sub: subType ^self new main: mainType; sub: subType! ! !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! ! Object subclass: #MOPTestClassA uses: Trait3 instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Traits-MOP'! !MOPTestClassA methodsFor: 'local'! c ^ 'Trait3>>c'! ! !MOPTestClassA methodsFor: 'local'! c3 ^ 'Trait3>>c3'! ! !MOPTestClassA methodsFor: 'trait2 - c'! c2 ^ 'Trait2>>c2'! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MOPTestClassA class uses: Trait3 classTrait instanceVariableNames: ''! Object subclass: #MOPTestClassB uses: Trait1 + Trait2 - {#c} instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Traits-MOP'! !MOPTestClassB methodsFor: 'trait1 - c'! c ^ 'Trait1>>c'! ! !MOPTestClassB methodsFor: 'trait1 - c'! c1 ^ 'Trait1>>c1'! ! !MOPTestClassB methodsFor: 'trait2 - c'! c2 ^ 'Trait2>>c2'! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MOPTestClassB class uses: Trait1 classTrait + Trait2 classTrait instanceVariableNames: ''! Object subclass: #MOPTestClassC uses: Trait2 instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Traits-MOP'! !MOPTestClassC methodsFor: 'local' stamp: 'stephane.ducasse 10/7/2008 16:57'! c ^ 'C>>c'! ! !MOPTestClassC methodsFor: 'trait2 - c'! c2 ^ 'Trait2>>c2'! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MOPTestClassC class uses: Trait2 classTrait instanceVariableNames: ''! Object subclass: #MOPTestClassD uses: Trait2 @ {#c3->#c2} instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Traits-MOP'! !MOPTestClassD methodsFor: 'trait2 - c'! c ^ 'Trait2>>c'! ! !MOPTestClassD methodsFor: 'trait2 - c'! c2 ^ 'Trait2>>c2'! ! !MOPTestClassD methodsFor: 'trait2 - c'! c3 ^ 'Trait2>>c2'! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MOPTestClassD class uses: Trait2 classTrait instanceVariableNames: ''! TestCase subclass: #MOPTraitTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Traits-MOP'! !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. ! ! !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'! 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.! ! ExternalClipboard subclass: #MacOSClipboard instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Clipboard'! !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' ! ! PlatformResolver subclass: #MacOSResolver instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Core-Implementation'! !MacOSResolver commentStamp: 'cwp 11/18/2009 11:57' prior: 0! I am an expert on Mac OS X filesystem conventions. I resolve origins according to these conventions.! !MacOSResolver methodsFor: 'origins' stamp: 'cwp 10/27/2009 21:45'! desktop ^ self home / 'Desktop'! ! !MacOSResolver methodsFor: 'origins' stamp: 'cwp 10/27/2009 21:50'! documents ^ self home / 'Documents'! ! !MacOSResolver methodsFor: 'origins' stamp: 'StephaneDucasse 7/5/2011 16:38'! home ^ (self resolveString: self class primitiveGetUntrustedUserDirectory) parent parent parent parent parent! ! !MacOSResolver methodsFor: 'origins' stamp: 'CamilloBruni 5/24/2012 12:11'! library ^ self home / 'Library' ! ! !MacOSResolver methodsFor: 'origins' stamp: 'CamilloBruni 5/24/2012 12:46'! preferences ^ self library / 'Preferences'! ! !MacOSResolver methodsFor: 'resolving' stamp: 'CamilloBruni 5/24/2012 14:51'! supportedOrigins ^ super supportedOrigins , #( library )! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MacOSResolver class instanceVariableNames: ''! !MacOSResolver class methodsFor: 'accessing' stamp: 'cwp 10/27/2009 10:59'! platformName ^ 'Mac OS'! ! OSPlatform subclass: #MacOSXPlatform instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Platforms'! !MacOSXPlatform methodsFor: '*System-Clipboard' stamp: 'michael.rueger 3/2/2009 10:56'! clipboardClass ^MacOSClipboard! ! !MacOSXPlatform methodsFor: 'accessing' stamp: 'michael.rueger 2/25/2009 18:18'! platformFamily ^#MacOSX! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MacOSXPlatform class instanceVariableNames: ''! !MacOSXPlatform class methodsFor: 'private' stamp: 'MarcusDenker 7/13/2012 14:30'! isActivePlatform ^OSPlatform isMacOS and: [OSPlatform version asNumber >= 1000]! ! ByteTextConverter subclass: #MacRomanTextConverter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Multilingual-TextConversion'! !MacRomanTextConverter commentStamp: '' prior: 0! Text converter for Mac Roman. An encoding used for the languages originated from Western Europe area.! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MacRomanTextConverter class instanceVariableNames: ''! !MacRomanTextConverter class methodsFor: 'accessing' stamp: 'yo 8/4/2003 12:33'! encodingNames ^ #('mac-roman' ) copy ! ! !MacRomanTextConverter class methodsFor: 'accessing' stamp: 'michael.rueger 2/2/2009 19:31'! languageEnvironment ^Latin1Environment! ! !MacRomanTextConverter class methodsFor: 'as yet unclassified'! initialize self initializeTables! ! !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 )! ! UnixStore subclass: #MacStore instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Disk'! !MacStore commentStamp: '' prior: 0! 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 instanceVariableNames: ''! !MacStore class methodsFor: 'current' stamp: 'CamilloBruni 5/10/2012 15:43'! isActiveClass ^ Smalltalk os isMacOS! ! Object subclass: #Magnitude instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Numbers'! !Magnitude commentStamp: 'sd 9/4/2005 10:14' prior: 0! 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'! max: aMagnitude "Answer the receiver or the argument, whichever has the greater magnitude." self > aMagnitude ifTrue: [^self] ifFalse: [^aMagnitude]! ! !Magnitude methodsFor: 'comparing'! min: aMagnitude "Answer the receiver or the argument, whichever has the lesser magnitude." self < aMagnitude ifTrue: [^self] ifFalse: [^aMagnitude]! ! !Magnitude methodsFor: 'comparing'! min: aMin max: aMax ^ (self min: aMin) max: aMax! ! !Magnitude methodsFor: 'hash'! hash "Hash must be redefined whenever = is redefined." ^self subclassResponsibility! ! !Magnitude methodsFor: 'testing'! < aMagnitude "Answer whether the receiver is less than the argument." ^self subclassResponsibility! ! !Magnitude methodsFor: 'testing'! <= aMagnitude "Answer whether the receiver is less than or equal to the argument." ^(self > aMagnitude) not! ! !Magnitude methodsFor: 'testing'! = 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'! > 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: 'testing'! 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 class instanceVariableNames: ''! !Magnitude class methodsFor: '*Nautilus' stamp: 'BenjaminVanRyseghem 1/2/2013 12:07'! nautilusIcon ^ self nautilusIconClass iconNamed: #magnitude! ! Object subclass: #MailAddressParser instanceVariableNames: 'tokens addresses curAddrTokens' classVariableNames: '' poolDictionaries: '' category: 'Network-RFC822'! !MailAddressParser commentStamp: '' prior: 0! 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: '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: '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: '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 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 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: '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: '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: 'private-initialization' stamp: 'ls 9/13/1998 01:25'! initialize: tokenList tokens := tokenList asOrderedCollection copy. addresses := OrderedCollection new.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MailAddressParser class instanceVariableNames: ''! !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! ! TestCase subclass: #MailAddressParserTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetworkTests-RFC822'! !MailAddressParserTest commentStamp: '' prior: 0! 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).! ! Object subclass: #MailAddressToken instanceVariableNames: 'type text' classVariableNames: '' poolDictionaries: '' category: 'Network-RFC822'! !MailAddressToken commentStamp: '' prior: 0! a single token from an RFC822 mail address. Used internally in MailAddressParser! !MailAddressToken methodsFor: 'access' stamp: 'ls 9/12/1998 20:42'! text ^text! ! !MailAddressToken methodsFor: 'access' stamp: 'ls 9/12/1998 20:42'! type ^type! ! !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: 'private' stamp: 'ls 9/12/1998 20:24'! type: type0 text: text0 type := type0. text := text0.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MailAddressToken class instanceVariableNames: ''! !MailAddressToken class methodsFor: 'instance creation' stamp: 'ls 9/12/1998 20:31'! type: type text: text ^self new type: type text: text! ! Stream subclass: #MailAddressTokenizer instanceVariableNames: 'cachedToken text pos' classVariableNames: 'CSNonAtom CSNonSeparators CSParens CSSpecials' poolDictionaries: '' category: 'Network-RFC822'! !MailAddressTokenizer commentStamp: '' prior: 0! Divides an address into tokens, as specified in RFC 822. Used by MailAddressParser.! !MailAddressTokenizer methodsFor: 'initialization' stamp: 'ls 9/12/1998 20:13'! initialize: aString text := aString. pos := 1.! ! !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: 'stream protocol' stamp: 'ls 9/12/1998 20:53'! peek cachedToken ifNil: [ cachedToken := self nextToken. ]. ^cachedToken ! ! !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: 'tokenizing' stamp: 'ls 9/12/1998 20:52'! nextChar self atEndOfChars ifTrue: [ ^nil ]. pos := pos + 1. ^text at: (pos-1)! ! !MailAddressTokenizer methodsFor: 'tokenizing' stamp: 'mas 2/8/2001 11:36'! 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. paren = $( ifTrue: [ nestLevel := nestLevel + 1 ] ifFalse: [ nestLevel := nestLevel - 1 ]]. ^ MailAddressToken type: #Comment text: (text copyFrom: start to: 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: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: 'ls 9/12/1998 20:14'! skipSeparators pos := text indexOfAnyOf: CSNonSeparators startingAt: pos ifAbsent: [ text size + 1 ].! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MailAddressTokenizer class instanceVariableNames: ''! !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: 'ls 9/12/1998 20:54'! forString: aString ^super 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! ! Model subclass: #MailComposition instanceVariableNames: 'messageText textEditor morphicWindow' classVariableNames: '' poolDictionaries: '' category: 'Network-Mail'! !MailComposition commentStamp: '' prior: 0! a message being composed. When finished, it will be submitted via a Celeste.! !MailComposition methodsFor: 'access' stamp: 'yo 7/26/2004 22:06'! messageText "return the current text" ^messageText. ! ! !MailComposition methodsFor: 'access' stamp: 'yo 7/26/2004 22:47'! messageText: aText "change the current text" messageText := aText. self changed: #messageText. ^true! ! !MailComposition methodsFor: 'access' stamp: 'dvf 5/11/2002 00:24'! smtpServer ^MailSender smtpServer! ! !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: '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: '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 methodsFor: 'interface' stamp: 'alain.plantec 5/30/2008 13:43'! open "open an interface" self openInMorphic ! ! !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: 'interface' stamp: 'dvf 5/11/2002 01:23'! sendMailMessage: aMailMessage self messageText: aMailMessage text! ! !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: '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 class instanceVariableNames: ''! !MailComposition class methodsFor: 'instance creation' stamp: 'dvf 5/11/2002 00:40'! initialize super initialize. MailSender register: self.! ! !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: 'instance creation' stamp: 'dvf 5/11/2002 00:40'! unload MailSender unregister: self ! ! Object subclass: #MailMessage instanceVariableNames: 'text body fields parts' classVariableNames: '' poolDictionaries: '' category: 'Network-Mail'! !MailMessage commentStamp: '' prior: 0! 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: 'accessing' stamp: 'ls 1/3/1999 15:48'! body "return just the body of the message" ^body! ! !MailMessage methodsFor: 'accessing' stamp: 'ls 1/3/1999 15:52'! bodyText "return the text of the body of the message" ^body content! ! !MailMessage methodsFor: 'accessing' stamp: 'ls 3/18/2001 16:34'! cc ^self fieldsNamed: 'cc' separatedBy: ', '! ! !MailMessage methodsFor: 'accessing' stamp: 'ls 2/10/2001 12:19'! date "Answer a date string for this message." ^(Date fromSeconds: self time + (Date newDay: 1 year: 1980) asSeconds) printFormat: #(2 1 3 47 1 2)! ! !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: 'accessing' stamp: 'mdr 3/21/2001 15:28'! from ^(self fieldNamed: 'from' ifAbsent: [ ^'' ]) mainValue! ! !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: 'accessing' stamp: 'SvenVanCaekenberghe 1/8/2012 15:17'! recipientList ^ (self to findTokens: $,) collect: [ :e | e trimLeft ]! ! !MailMessage methodsFor: 'accessing' stamp: 'ls 3/18/2001 16:24'! subject ^(self fieldNamed: 'subject' ifAbsent: [ ^'' ]) mainValue! ! !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: '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: 'accessing' stamp: 'ls 3/18/2001 16:35'! to ^self fieldsNamed: 'to' separatedBy: ', '! ! !MailMessage methodsFor: 'fields' stamp: 'bf 3/10/2000 15:22'! canonicalFields "Break long header fields and escape those containing high-ascii characters according to RFC2047" self rewriteFields: [ :fName :fValue | (fName size + fValue size < 72 and: [fValue allSatisfy: [:c | c asciiValue <= 128]]) ifFalse: [RFC2047MimeConverter mimeEncode: fName, ': ', fValue]] append: []. ! ! !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: '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: '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: 'fields' stamp: 'ls 3/18/2001 16:30'! removeFieldNamed: name "remove all fields with the specified name" fields removeKey: name ifAbsent: []! ! !MailMessage methodsFor: 'fields' stamp: 'StephaneDucasse 10/20/2011 15:44'! rewriteFields: aBlock append: appendBlock "Rewrite header fields. The body is not modified. Each field's key and value is reported to aBlock. The block's return value is the replacement for the entire header line. Nil means don't change the line, empty means delete it. After all fields are processed, evaluate appendBlock and append the result to the header." | old new appendString | Halt halt: 'this method is out of date. it needs to update body, at the very least. do we really need this now that we have setField:to: and setField:toString: ?!!'. old := text readStream. new := (String new: text size) writeStream. self fieldsFrom: old do: [ :fName :fValue | | result | result := aBlock value: fName value: fValue. result ifNil: [ new nextPutAll: fName , ': ' , fValue; cr ] ifNotNil: [ result isEmpty ifFalse: [ new nextPutAll: result. result last = Character cr ifFalse: [ new cr ] ] ] ]. appendString := appendBlock value. appendString isEmptyOrNil ifFalse: [ new nextPutAll: appendString. appendString last = Character cr ifFalse: [ new cr ] ]. new cr. "End of header" text := new contents , old upToEnd! ! !MailMessage methodsFor: 'initialization' stamp: 'ls 2/10/2001 12:48'! body: newBody "change the body" body := newBody. text := nil.! ! !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: '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: '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: '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:54'! addAlternativePart: newPart self makeMultipart: 'alternative' with: newPart. ! ! !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: '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: 'multipart' stamp: 'TonyFleig 11/28/2010 12:55'! addMixedPart: newPart self makeMultipart: 'mixed' with: newPart. ! ! !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: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: '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: 'multipart' stamp: 'mdr 3/22/2001 09:06'! attachmentSeparator ^(self fieldNamed: 'content-type' ifAbsent: [^nil]) parameters at: 'boundary' ifAbsent: [^nil]! ! !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: '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: '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: 'multipart' stamp: 'ls 4/30/2000 18:22'! parts parts ifNil: [self parseParts]. ^ parts! ! !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: '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 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: 'parsing' stamp: 'PeterHugossonMiller 9/3/2009 10:03'! 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 isNil ifTrue: "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 newDay: day month: month year: year! ! !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: '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: '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: 'parsing' stamp: 'damiencassou 5/30/2008 15:52'! 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 newDay: 1 year: 1980) 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: '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: '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: '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: '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'! format "Replace the text of this message with a formatted version." "NOTE: This operation discards extra header fields." text := self formattedText.! ! !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: 'printing/formatting' 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: '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: '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: '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: '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: 'sending' stamp: 'SeanDeNigris 12/2/2011 12:02'! sendOn: serverString SMTPClient deliver: self usingServer: serverString.! ! !MailMessage methodsFor: 'testing' stamp: 'kfr 11/5/2004 17:32'! containsViewableImage ^self body isJpeg | self body isGif | self body isPng! ! !MailMessage methodsFor: 'testing' stamp: 'HenrikSperreJohansen 6/28/2010 12:21'! selfTest "For testing only: Check that this instance is well formed and makes sense" self formattedText. [MailAddressParser addressesIn: self from] ifError: [ :err | Transcript show: 'Error parsing From: (', self from, ') ', err]. [MailAddressParser addressesIn: self to] ifError: [ :err | Transcript show: 'Error parsing To: (', self to, ') ', err]. [MailAddressParser addressesIn: self cc] ifError: [ :err | Transcript show: 'Error parsing CC: (', self cc, ') ', err]. ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MailMessage class instanceVariableNames: ''! !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:22'! from: aString "Initialize a new instance from the given string." ^ self new from: aString! ! !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: '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: 'utilities' stamp: 'JB 2/12/2010 15:27'! dateTimeSuffix "Answer a string which indicates the date and time, intended for use in building fileout filenames, etc." ^self monthDayTime24StringFrom: Time primSecondsClock! ! !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)! ! TestCase subclass: #MailMessageTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetworkTests-Mail'! !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'.! ! !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: '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: '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!! ').! ! AppRegistry subclass: #MailSender instanceVariableNames: '' classVariableNames: 'SmtpServer UserName' poolDictionaries: '' category: 'System-Applications'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MailSender class instanceVariableNames: ''! !MailSender class methodsFor: 'accessing' stamp: 'dvf 5/11/2002 01:29'! 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: 'accessing' stamp: 'dvf 5/11/2002 00:49'! 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: 'communication' stamp: 'ads 5/11/2003 21:11'! sendMessage: aMailMessage self default ifNotNil: [self default sendMailMessage: aMailMessage]! ! !MailSender class methodsFor: 'settings' stamp: 'rbb 3/1/2005 10:59'! 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: 'settings' stamp: 'md 9/29/2010 17:54'! setSmtpServer: aString SmtpServer := aString! ! !MailSender class methodsFor: 'settings' stamp: 'rbb 3/1/2005 11:00'! 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]! ! !MailSender class methodsFor: 'testing' stamp: 'dvf 5/11/2002 01:31'! isSmtpServerSet ^ SmtpServer notNil and: [SmtpServer notEmpty] ! ! GenericUrl subclass: #MailtoUrl instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Network-Url'! !MailtoUrl commentStamp: '' prior: 0! 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 00:47'! activate "Activate a Celeste window for the receiver" MailSender sendMessage: (MailMessage from: self composeText)! ! !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 class instanceVariableNames: ''! !MailtoUrl class methodsFor: 'constants' stamp: 'SeanDeNigris 1/29/2011 19:33'! schemeName ^ 'mailto'! ! Object subclass: #ManifestFuel instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Fuel'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ManifestFuel class instanceVariableNames: ''! !ManifestFuel class methodsFor: 'meta data' stamp: 'MartinDias 2/25/2013 14:13'! rejectClasses ^ #()! ! !ManifestFuel class methodsFor: 'meta data' stamp: 'MartinDias 2/25/2013 14:13'! rejectRules ^ #()! ! !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') )! ! !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') )! ! Object subclass: #ManifestManifestCore instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Manifest-Core'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ManifestManifestCore class instanceVariableNames: ''! !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'! rejectRules ^ #('MethodHasNoTimeStampRule')! ! !ManifestManifestCore class methodsFor: 'meta data' stamp: 'SimonAllier 2/1/2013 15:29'! ruleBadMessageRuleV1FalsePositive ^ #(#(#(#RGMethodDefinition #(#BuilderManifest #hasTruePositiveOf:version: #false)) #'2013-02-01T15:29:51.978000008+01:00') #(#(#RGMethodDefinition #(#BuilderManifest #hasFalsePositiveOf:version: #false)) #'2013-02-01T15:29:51.978000006+01:00') #(#(#RGMethodDefinition #(#BuilderManifest #rejectRules #false)) #'2013-02-01T15:29:51.978000007+01:00') #(#(#RGMethodDefinition #(#BuilderManifest #hasToDoOf:version: #false)) #'2013-02-01T15:29:51.978000005+01:00') )! ! !ManifestManifestCore class methodsFor: 'meta data' stamp: 'SimonAllier 2/6/2013 15:08'! ruleCodeCruftLeftInMethodsRuleV1TODO ^ #(#(#(#RGMethodDefinition #(#BuilderManifest #hash #false)) #'2013-02-06T15:08:33.234+01:00') )! ! !ManifestManifestCore class methodsFor: 'meta data' stamp: 'SimonAllier 2/1/2013 15:29'! ruleConsistencyCheckRuleV1FalsePositive ^ #(#(#(#RGMethodDefinition #(#BuilderManifest #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 2/8/2013 16:35'! ruleContainsRuleV1FalsePositive ^ #(#(#(#RGMethodDefinition #(#BuilderManifest #commentOfFalsePositive:onRule:version: #false)) #'2013-02-01T15:29:52.876+01:00') #(#(#RGMethodDefinition #(#BuilderManifest #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: '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: 'SimonAllier 2/1/2013 15:29'! ruleImplementedNotSentRuleV1FalsePositive ^ #(#(#(#RGMethodDefinition #(#BuilderManifest #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 #(#BuilderManifest #removeManifestOf: #false)) #'2013-02-01T15:29:52.678000012+01:00') #(#(#RGMethodDefinition #(#BuilderManifest #dateOfToDo:onRule:version: #false)) #'2013-02-01T15:29:52.678000013+01:00') #(#(#RGMethodDefinition #(#BuilderManifest #dateOfTruePositive:onRule:version: #false)) #'2013-02-01T15:29:52.67800001+01:00') #(#(#RGMethodDefinition #(#BuilderManifest #removeAllManifest #false)) #'2013-02-01T15:29:52.678000006+01:00') #(#(#RGMethodDefinition #(#'RBLintRule class' #uniqueIdentifierNumber #true)) #'2013-02-01T15:29:52.678000008+01:00') #(#(#RGMethodDefinition #(#BuilderManifest #installTruePositiveOf:version: #false)) #'2013-02-01T15:29:52.678000009+01:00') )! ! Object subclass: #ManifestManifestCriticBrowser instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Manifest-CriticBrowser'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ManifestManifestCriticBrowser class instanceVariableNames: ''! !ManifestManifestCriticBrowser class methodsFor: 'meta data' stamp: 'SimonAllier 2/1/2013 15:29'! rejectClasses ^ #()! ! !ManifestManifestCriticBrowser class methodsFor: 'meta data' stamp: 'SimonAllier 2/1/2013 15:29'! rejectRules ^ #('MethodHasNoTimeStampRule')! ! !ManifestManifestCriticBrowser class methodsFor: 'meta data' stamp: 'SimonAllier 2/1/2013 15:29'! ruleBadMessageRuleV1FalsePositive ^ #(#(#(#RGMethodDefinition #(#SingleRuleCriticBrowser #perform:orSendTo: #false)) #'2013-02-01T15:29:51.915000005+01:00') )! ! !ManifestManifestCriticBrowser class methodsFor: 'meta data' stamp: 'SimonAllier 2/6/2013 15:08'! ruleCodeCruftLeftInMethodsRuleV1TODO ^ #(#(#(#RGMethodDefinition #(#SingleRuleCriticBrowser #addCriticWithCommentToFalsePositive #false)) #'2013-02-06T15:08:32.572+01:00') #(#(#RGMethodDefinition #(#SingleRuleCriticBrowser #addCriticWithCommentToToDo #false)) #'2013-02-06T15:08:32.572000001+01:00') )! ! !ManifestManifestCriticBrowser class methodsFor: 'meta data' stamp: 'SimonAllier 2/1/2013 15:29'! ruleCollectionMessagesToExternalObjectRuleV1FalsePositive ^ #(#(#(#RGMethodDefinition #(#CriticsCache #addFalsePositiveRule:forPackage: #false)) #'2013-02-01T15:29:52.973000011+01:00') #(#(#RGMethodDefinition #(#CriticsCache #addToDo:forRule: #false)) #'2013-02-01T15:29:52.973000012+01:00') #(#(#RGMethodDefinition #(#CriticsCache #addFalsePositive:forRule: #false)) #'2013-02-01T15:29:52.973000013+01:00') #(#(#RGMethodDefinition #(#CriticsCache #addCritic:forRule: #false)) #'2013-02-01T15:29:52.973000014+01:00') )! ! !ManifestManifestCriticBrowser class methodsFor: 'meta data' stamp: 'SimonAllier 2/1/2013 15:29'! ruleEquivalentSuperclassMethodsRuleV1FalsePositive ^ #(#(#(#RGMethodDefinition #(#SingleRuleCriticBrowser #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: '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: 'SimonAllier 2/1/2013 15:29'! ruleMissingYourselfRuleV1FalsePositive ^ #(#(#(#RGMethodDefinition #(#SelectRuleBrowser #nextAction #false)) #'2013-02-01T15:29:52.055000006+01:00') )! ! !ManifestManifestCriticBrowser class methodsFor: 'meta data' stamp: 'SimonAllier 2/1/2013 15:29'! ruleOnlyReadOrWrittenTemporaryRuleV1FalsePositive ^ #(#(#(#RGMethodDefinition #(#CriticsCache #logFalsePositiveInManifest #false)) #'2013-02-01T15:29:52.762000008+01:00') #(#(#RGMethodDefinition #(#CriticsCache #logToDosInManifest #false)) #'2013-02-01T15:29:52.762000009+01:00') )! ! !ManifestManifestCriticBrowser class methodsFor: 'meta data' stamp: 'SimonAllier 2/1/2013 15:29'! ruleOnlyReadOrWrittenVariableRuleV1FalsePositive ^ #(#(#(#RGClassDefinition #(#CriticBrowser)) #'2013-02-01T15:29:52.299+01:00') #(#(#RGClassDefinition #(#SelectBrowser)) #'2013-02-01T15:29:52.299000001+01:00') #(#(#RGClassDefinition #(#SingleRuleCriticBrowser)) #'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: 'SimonAllier 2/1/2013 15:29'! ruleReturnsIfTrueRuleV1FalsePositive ^ #(#(#(#RGMethodDefinition #(#SingleRuleCriticBrowser #iconFor: #false)) #'2013-02-01T15:29:51.740000004+01:00') )! ! !ManifestManifestCriticBrowser class methodsFor: 'meta data' stamp: 'SimonAllier 2/1/2013 15:29'! ruleSentNotImplementedRuleV1FalsePositive ^ #(#(#(#RGMethodDefinition #(#SelectBrowser #setAddAllButtonModel #false)) #'2013-02-01T15:29:52.182000008+01:00') #(#(#RGMethodDefinition #(#SelectBrowser #setRemoveButtonModel #false)) #'2013-02-01T15:29:52.182000007+01:00') #(#(#RGMethodDefinition #(#CriticBrowser #methodAdded: #false)) #'2013-02-01T15:29:52.182000006+01:00') #(#(#RGMethodDefinition #(#SelectBrowser #setAddButtonModel #false)) #'2013-02-01T15:29:52.182000004+01:00') #(#(#RGMethodDefinition #(#SelectBrowser #items: #false)) #'2013-02-01T15:29:52.182000003+01:00') #(#(#RGMethodDefinition #(#SelectBrowser #setRemoveAllButtonModel #false)) #'2013-02-01T15:29:52.182000005+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: 'SimonAllier 2/1/2013 15:29'! ruleTemporaryVariableCapitalizationRuleV1FalsePositive ^ #(#(#(#RGMethodDefinition #(#CriticBrowser #applyRules #false)) #'2013-02-01T15:29:53.129000006+01:00') #(#(#RGMethodDefinition #(#CriticBrowser #reapplyRule: #false)) #'2013-02-01T15:29:53.129000007+01:00') )! ! Object subclass: #ManifestManifestTests instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Manifest-Tests'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ManifestManifestTests class instanceVariableNames: ''! !ManifestManifestTests class methodsFor: 'meta data'! rejectClasses ^ #()! ! !ManifestManifestTests class methodsFor: 'meta data'! rejectRules ^ #()! ! SimpleTestResourceTestCase subclass: #ManyTestResourceTestCase instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Tests-Core'! !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 instanceVariableNames: ''! !ManyTestResourceTestCase class methodsFor: 'accessing' stamp: 'nfr 1/3/2010 18:13'! resources ^super resources , (Array with: SimpleTestResourceA with: SimpleTestResourceB)! ! !ManyTestResourceTestCase class methodsFor: 'testing' stamp: ' 17/7/10 17:28'! shouldInheritSelectors ^true! ! SimpleBorder subclass: #MarginBorder instanceVariableNames: 'margin' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Borders'! !MarginBorder commentStamp: 'gvc 5/18/2007 12:46' prior: 0! Border with customisable inner margin.! !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: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: 'accessing' 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: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! ! Collection subclass: #Matrix instanceVariableNames: 'nrows ncols contents' classVariableNames: '' poolDictionaries: '' category: 'Collections-Unordered'! !Matrix commentStamp: '' prior: 0! I represent a two-dimensional array, rather like Array2D. There are three main differences between me and Array2D: (1) Array2D inherits from ArrayedCollection, but isn't one. A lot of things that should work do not work in consequence of this. (2) Array2D uses "at: column at: row" index order, which means that nothing you write using it is likely to work either. I use the almost universal "at: row at: column" order, so it is much easier to adapt code from other languages without going doolally. (3) Array2D lets you specify the class of the underlying collection, I don't. 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). Array2D uses column major order. You can specify the class of 'contents' when you create a new Array2D, but Matrix always gives you an Array. There is a reason for this. In strongly typed languages like Haskell and Clean, 'unboxed arrays' save you both space AND time. But in Squeak, while WordArray and FloatArray and so on do save space, it costs time to use them. A LOT of time. I've measured aFloatArray sum running nearly twice as slow as anArray sum. The reason is that whenever you fetch an element from an Array, that's all that happens, but when you fetch an element from aFloatArray, a whole new Float gets allocated to hold the value. This takes time and churns memory. So the paradox is that if you want fast numerical stuff, DON'T use unboxed arrays!! Another reason for always insisting on an Array is that letting it be something else would make things like #, and #,, rather more complicated. Always using Array is the simplest thing that could possibly work, and it works rather well. I was trying to patch Array2D to make more things work, but just couldn't get my head around the subscript order. That's why I made Matrix. 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. Still to come: oodles of stuff. Gaussian elimination maybe, other stuff probably not. ! !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: '*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: '*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: 'accessing' stamp: 'raok 10/21/2002 22:37'! anyOne ^contents anyOne! ! !Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:37'! at: row at: column ^contents at: (self indexForRow: row andColumn: column)! ! !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: '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: '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' stamp: 'raok 10/21/2002 22:42'! atAllPut: value contents atAllPut: value! ! !Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:43'! atRandom ^contents atRandom ! ! !Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:43'! atRandom: aGenerator ^contents atRandom: aGenerator! ! !Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:44'! columnCount ^ncols! ! !Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:48'! identityIndexOf: anElement ^self identityIndexOf: anElement ifAbsent: [0@0] ! ! !Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:48'! identityIndexOf: anElement ifAbsent: anExceptionBlock ^self rowAndColumnForIndex: (contents identityIndexOf: anElement ifAbsent: [^anExceptionBlock value]) ! ! !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: 'accessing' stamp: 'raok 10/21/2002 22:49'! replaceAll: oldObject with: newObject contents replaceAll: oldObject with: newObject! ! !Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:44'! rowCount ^nrows! ! !Matrix methodsFor: 'accessing' stamp: 'raok 10/21/2002 22:49'! size ^contents size! ! !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: '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: '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: '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 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: '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: '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: '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: '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 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: '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 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: 'adding' stamp: 'raok 10/21/2002 22:53'! add: newObject self shouldNotImplement! ! !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: '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: 'converting' stamp: 'raok 10/21/2002 22:57'! asArray ^contents shallowCopy! ! !Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:57'! asBag ^contents asBag! ! !Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:58'! asByteArray ^contents asByteArray! ! !Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:58'! asCharacterSet ^contents asCharacterSet! ! !Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 23:00'! asFloatArray ^contents asFloatArray! ! !Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:58'! asIdentitySet ^contents asIdentitySet! ! !Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 23:00'! asIntegerArray ^contents asIntegerArray! ! !Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:58'! asOrderedCollection ^contents asOrderedCollection! ! !Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:58'! asSet ^contents asSet! ! !Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:59'! asSortedCollection ^contents asSortedCollection! ! !Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 22:59'! asSortedCollection: aBlock ^contents asSortedCollection: aBlock! ! !Matrix methodsFor: 'converting' stamp: 'raok 10/21/2002 23:00'! asWordArray ^contents asWordArray! ! !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: '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: '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: 'copying' stamp: 'nice 10/5/2009 09:09'! postCopy super postCopy. contents := contents copy! ! !Matrix methodsFor: 'copying' stamp: 'raok 10/21/2002 23:27'! shuffled ^self class rows: nrows columns: ncols contents: (contents shuffled)! ! !Matrix methodsFor: 'copying' stamp: 'raok 10/21/2002 23:27'! shuffledBy: aRandom ^self class rows: nrows columns: ncols contents: (contents shuffledBy: aRandom)! ! !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: '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: '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: '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: '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: '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: 'enumerating' stamp: 'raok 10/21/2002 23:42'! reject: aBlock self shouldNotImplement! ! !Matrix methodsFor: 'enumerating' stamp: 'raok 10/21/2002 23:42'! select: aBlock self shouldNotImplement! ! !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: '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: '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: '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: '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: '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: '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: 'removing' stamp: 'klub 9/14/2009 16:34'! removeAll self shouldNotImplement! ! !Matrix methodsFor: 'testing' stamp: 'raok 10/21/2002 23:24'! identityIncludes: anObject ^contents identityIncludes: anObject! ! !Matrix methodsFor: 'testing' stamp: 'raok 10/21/2002 23:23'! includes: anObject ^contents includes: anObject! ! !Matrix methodsFor: 'testing' stamp: 'CamilloBruni 9/8/2011 14:23'! includesAll: aCollection ^contents includesAll: aCollection! ! !Matrix methodsFor: 'testing' stamp: 'CamilloBruni 9/8/2011 14:24'! includesAllOf: aCollection self flag: 'use includesAll: instead'. ^ self includesAll: aCollection! ! !Matrix methodsFor: 'testing' stamp: 'CamilloBruni 9/8/2011 14:23'! includesAny: aCollection ^contents includesAny: aCollection! ! !Matrix methodsFor: 'testing' stamp: 'CamilloBruni 9/8/2011 14:24'! includesAnyOf: aCollection self flag: 'use includesAny: instead'. ^ self includesAny: aCollection! ! !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: 'testing' stamp: 'raok 10/21/2002 23:25'! occurrencesOf: anObject ^contents occurrencesOf: anObject! ! !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: '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: 'private' stamp: 'raok 10/21/2002 22:47'! rowAndColumnForIndex: index |t| t := index - 1. ^(t // ncols + 1)@(t \\ ncols + 1)! ! !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 class instanceVariableNames: ''! !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 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: '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 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 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 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 11/28/2002 14:08'! ones: n ^self new: n element: 1 ! ! !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 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 11/28/2002 14:10'! rows: rows columns: columns element: element ^self rows: rows columns: columns contents: ((Array new: rows*columns) atAllPut: element; yourself)! ! !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 11/28/2002 14:09'! zeros: n ^self new: n element: 0! ! !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! ! TestCase subclass: #MatrixTest instanceVariableNames: 'matrix1 matrix2 matrix3' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Unordered'! !MatrixTest methodsFor: '*Collections-arithmetic-testing' 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.! ! !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]) ! ! DisplayTransform variableWordSubclass: #MatrixTransform2x3 instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Transformations'! !MatrixTransform2x3 commentStamp: '' prior: 0! 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: 'accessing' stamp: 'ar 2/2/2001 15:47'! at: index ^Float fromIEEE32Bit: (self basicAt: index)! ! !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: '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: 'accessing' stamp: 'ar 11/2/1998 23:19'! offset ^self a13 @ self a23! ! !MatrixTransform2x3 methodsFor: 'accessing' stamp: 'ar 11/2/1998 23:05'! offset: aPoint self a13: aPoint x asFloat. self a23: aPoint y asFloat.! ! !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: '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: '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: '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: 'converting' stamp: 'ar 11/2/1998 15:34'! asMatrixTransform2x3 ^self! ! !MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:56'! a11 ^self at: 1! ! !MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:57'! a11: value self at: 1 put: value! ! !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'! a12: value self at: 2 put: value! ! !MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:56'! a13 ^self at: 3! ! !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'! a21 ^self at: 4! ! !MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:57'! a21: value self at: 4 put: value! ! !MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:56'! a22 ^self at: 5! ! !MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:57'! a22: value self at: 5 put: value! ! !MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:56'! a23 ^self at: 6! ! !MatrixTransform2x3 methodsFor: 'element access' stamp: 'ar 11/2/1998 22:57'! a23: value self at: 6 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: 'objects from disk' stamp: 'nk 3/17/2004 16:06'! byteSize ^self basicSize * self bytesPerBasicElement! ! !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: '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: 'objects from disk' stamp: 'ar 8/6/2001 17:52'! writeOn: aStream aStream nextWordsPutAll: self.! ! !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: '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: 'testing' stamp: 'ar 11/2/1998 23:15'! isMatrixTransform2x3 "Return true if the receiver is 2x3 matrix transformation" ^true! ! !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: '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: '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: '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: '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: '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: '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 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 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: '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: '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: '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: '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 class instanceVariableNames: ''! !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: '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/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/2/1998 02:49'! withAngle: angle ^self new setAngle: angle! ! !MatrixTransform2x3 class methodsFor: 'instance creation' stamp: 'ar 11/3/1998 02:52'! withOffset: aPoint ^self identity setOffset: aPoint! ! !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/2/1998 02:49'! withScale: aPoint ^self new setScale: aPoint! ! Morph subclass: #MatrixTransformMorph uses: TAbleToRotate instanceVariableNames: 'transform' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Balloon'! !MatrixTransformMorph commentStamp: '' prior: 0! 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: 'accessing' stamp: 'ar 11/15/1998 21:51'! transform: aMatrixTransform transform := aMatrixTransform. self computeBounds.! ! !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: 'drawing' stamp: 'ar 11/15/1998 22:20'! drawOn: aCanvas! ! !MatrixTransformMorph methodsFor: 'drawing' stamp: 'ar 5/29/1999 09:01'! drawSubmorphsOn: aCanvas aCanvas asBalloonCanvas transformBy: self transform during:[:myCanvas| super drawSubmorphsOn: myCanvas].! ! !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: '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: 'flexing' stamp: 'ar 11/16/1998 01:19'! changeRotationCenter: evt with: rotHandle | pos | pos := evt cursorPoint. rotHandle referencePosition: pos. self referencePosition: pos.! ! !MatrixTransformMorph methodsFor: 'flexing' stamp: 'ar 11/15/1998 21:55'! hasNoScaleOrRotation ^true! ! !MatrixTransformMorph methodsFor: 'flexing' stamp: 'fbs 11/26/2004 10:59'! innerAngle ^ (self transform a11 @ self transform a21) degrees! ! !MatrixTransformMorph methodsFor: 'flexing' stamp: 'ar 11/15/1998 21:56'! lastRotationDegrees ^(self valueOfProperty: #lastRotationDegrees) ifNil:[0.0].! ! !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: 'flexing' stamp: 'ar 11/15/1998 21:56'! removeFlexShell "Do nothing"! ! !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: '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: 'flexing' stamp: 'ar 9/11/2000 21:16'! transform ^ transform ifNil: [MatrixTransform2x3 identity]! ! !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: '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: 'geometry' stamp: 'ar 11/15/1998 21:52'! extent: extent self handleBoundsChange:[super extent: extent]! ! !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: 'geometry' stamp: 'ar 10/6/2000 15:37'! transformedBy: aTransform self transform: (self transform composedWithGlobal: aTransform).! ! !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: '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: 'geometry etoy' stamp: 'ar 6/12/2001 05:07'! rotationCenter: aPoint super rotationCenter: (self transform globalPointToLocal: bounds origin + (bounds extent * aPoint))! ! !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: '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: '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: 'initialization' stamp: 'dgd 2/14/2003 20:38'! initialize "initialize the state of the receiver" super initialize. "" transform := MatrixTransform2x3 identity! ! !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: '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: 'menus' stamp: 'jcg 11/1/2001 13:03'! setRotationCenterFrom: aPoint super setRotationCenterFrom: (self transformFromWorld localPointToGlobal: aPoint) ! ! !MatrixTransformMorph methodsFor: 'rotate scale and flex' stamp: 'ar 11/15/1998 21:55'! addFlexShell "No flex shell necessary" self lastRotationDegrees: 0.0.! ! !MatrixTransformMorph methodsFor: 't-rotating'! forwardDirection "Return the receiver's forward direction (in eToy terms)" ^self valueOfProperty: #forwardDirection ifAbsent:[0.0]! ! !MatrixTransformMorph methodsFor: 't-rotating'! forwardDirection: newDirection "Set the receiver's forward direction (in eToy terms)" self setProperty: #forwardDirection toValue: newDirection.! ! !MatrixTransformMorph methodsFor: 't-rotating'! 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: 't-rotating'! rotationDegrees "Default implementation." ^ 0.0 ! ! !MatrixTransformMorph methodsFor: 'updating' stamp: 'ar 11/12/2000 18:51'! changed ^self invalidRect: (self fullBounds insetBy: -1)! ! !MatrixTransformMorph methodsFor: 'private' stamp: 'ar 6/12/2001 06:38'! privateFullMoveBy: delta self privateMoveBy: delta. transform offset: transform offset + delta.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MatrixTransformMorph class uses: TAbleToRotate classTrait instanceVariableNames: ''! InstanceVariableNode subclass: #MaybeContextInstanceVariableNode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-ParseNodes'! !MaybeContextInstanceVariableNode commentStamp: '' prior: 0! 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 6/19/2008 09:36'! emitCodeForStorePop: stack encoder: encoder encoder genStorePopInstVarLong: index. stack pop: 1! ! !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 5/14/2008 18:07'! sizeCodeForStorePop: encoder ^encoder sizeStorePopInstVarLong: index! ! !MaybeContextInstanceVariableNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 17:53'! sizeCodeForValue: encoder ^encoder sizePushInstVarLong: index! ! Object subclass: #MczInstaller instanceVariableNames: 'stream zip' classVariableNames: 'Versions' poolDictionaries: '' category: 'System-Installers'! !MczInstaller methodsFor: 'accessing' stamp: 'cwp 8/13/2003 01:58'! extractPackageName ^ (self parseMember: 'package') at: #name. ! ! !MczInstaller methodsFor: 'accessing' stamp: 'cwp 8/13/2003 02:17'! extractVersionInfo ^ self extractInfoFrom: (self parseMember: 'version')! ! !MczInstaller methodsFor: 'accessing' stamp: 'cwp 8/7/2003 19:18'! recordVersionInfo Versions at: self extractPackageName put: self extractVersionInfo! ! !MczInstaller methodsFor: 'accessing' stamp: 'cwp 8/13/2003 02:04'! scanner ^ Scanner new! ! !MczInstaller methodsFor: 'accessing' stamp: 'avi 2/17/2004 02:55'! stream: aStream stream := aStream! ! !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: 'installation' stamp: 'GuillermoPolito 5/5/2012 23:10'! installMember: member self useNewChangeSetDuring: [ | str |str := member contentStream text. str setConverterForCode. CodeImporter evaluateReadStream: str readStream. ]! ! !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 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: '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: 'utilities' stamp: 'cwp 8/13/2003 01:58'! parseMember: fileName | tokens | tokens := (self scanner scanTokens: (zip contentsOf: fileName)) first. ^ self associate: tokens! ! !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: '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 class instanceVariableNames: ''! !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: 'System-FileRegistry' stamp: 'avi 3/7/2004 14:51'! initialize self clearVersionInfo. self registerForFileList.! ! !MczInstaller class methodsFor: 'System-FileRegistry' stamp: 'cwp 8/7/2003 18:54'! loadVersionFile: fileName self installFileNamed: fileName ! ! !MczInstaller class methodsFor: 'System-FileRegistry' stamp: 'IgorStasenko 4/15/2011 17:17'! registerForFileList Smalltalk globals at: #MCReader ifAbsent: [ Smalltalk tools fileList registerFileReader: self ]! ! !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: 'ab 8/8/2003 18:01'! services ^ Array with: self serviceLoadVersion! ! !MczInstaller class methodsFor: 'installing' stamp: 'cwp 8/7/2003 18:13'! installFileNamed: aFileName self installStream: (FileStream readOnlyFileNamed: aFileName)! ! !MczInstaller class methodsFor: 'installing' stamp: 'cwp 8/7/2003 17:56'! installStream: aStream (self on: aStream) install! ! !MczInstaller class methodsFor: 'instance creation' stamp: 'cwp 8/7/2003 17:56'! on: aStream ^ self new stream: aStream! ! !MczInstaller class methodsFor: 'shrinking' stamp: 'EstebanLorenzano 7/27/2012 18:21'! unloadMonticello "self unloadMonticello" self breakDependents. Smalltalk globals at: #MCWorkingCopy ifPresent: [ :wc | wc allInstances do: [ :ea | Versions at: ea package name put: ea currentVersionInfo asDictionary. ea breakDependents. SystemAnnouncer uniqueInstance unsubscribe: ea. ] displayingProgress: 'Saving version info...' ]. "keep things simple and don't unload any class extensions" (Class superclassOrder: (PackageInfo named: 'Monticello') classes) reverseDo: [ :ea | ea removeFromSystem ]. self registerForFileList! ! !MczInstaller class methodsFor: 'versioninfo' stamp: 'avi 1/19/2004 13:13'! clearVersionInfo Versions := Dictionary new! ! !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: 'versioninfo' stamp: 'avi 2/17/2004 02:49'! versionInfo ^ Versions! ! MemoryFileSystemEntry subclass: #MemoryFileSystemDirectory instanceVariableNames: 'entries' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Memory'! !MemoryFileSystemDirectory commentStamp: '' prior: 0! I represent a memory file system entry for a directory! !MemoryFileSystemDirectory methodsFor: 'accessing' stamp: 'CamilloBruni 6/22/2012 20:02'! entries ^ entries! ! !MemoryFileSystemDirectory methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 14:47'! fileEntryAt: aFIleName ^ entries at: aFIleName! ! !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:48'! fileEntryAt: aFileName ifPresent: aBlock ^ entries at: aFileName ifPresent: aBlock! ! !MemoryFileSystemDirectory methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 14:48'! fileEntryAt: aFIleName put: anEntry ^ entries at: aFIleName ifAbsentPut: [ self modified. anEntry ]! ! !MemoryFileSystemDirectory methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 14:54'! fileSize ^ 0! ! !MemoryFileSystemDirectory methodsFor: 'accessing' stamp: 'CamilloBruni 6/22/2012 20:17'! includes: aFIleName ^ entries includesKey: aFIleName! ! !MemoryFileSystemDirectory methodsFor: 'accessing' stamp: 'CamilloBruni 6/22/2012 22:03'! remove: aFileName modificationTime := DateAndTime now. ^ entries removeKey: aFileName! ! !MemoryFileSystemDirectory methodsFor: 'creation' stamp: 'CamilloBruni 7/10/2012 14:53'! ensureDirectory: aDirectoryName ^ self fileEntryAt: aDirectoryName put: (MemoryFileSystemDirectory named: aDirectoryName)! ! !MemoryFileSystemDirectory methodsFor: 'creation' stamp: 'CamilloBruni 7/10/2012 14:53'! ensureFile: aFileName ^ self fileEntryAt: aFileName put: (MemoryFileSystemFile named: aFileName)! ! !MemoryFileSystemDirectory methodsFor: 'enumeration' stamp: 'CamilloBruni 7/10/2012 14:49'! fileEntriesDo: aBlock entries keys sorted do: [ :fileName| aBlock value: (entries at: fileName)].! ! !MemoryFileSystemDirectory methodsFor: 'initialize-release' stamp: 'CamilloBruni 6/22/2012 20:00'! initialize super initialize. entries := Dictionary new.! ! !MemoryFileSystemDirectory methodsFor: 'testing' stamp: 'CamilloBruni 6/22/2012 20:02'! isDirectory ^ true! ! Object subclass: #MemoryFileSystemEntry instanceVariableNames: 'creationTime modificationTime basename' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Memory'! !MemoryFileSystemEntry commentStamp: '' prior: 0! 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: 'CamilloBruni 7/10/2012 14:46'! basename ^ basename! ! !MemoryFileSystemEntry methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 14:46'! basename: aString basename := aString! ! !MemoryFileSystemEntry methodsFor: 'accessing' stamp: 'CamilloBruni 6/22/2012 19:59'! creationTime ^ creationTime! ! !MemoryFileSystemEntry methodsFor: 'accessing' stamp: 'PavelKrivanek 11/23/2012 12:21'! fileSize self subclassResponsibility ! ! !MemoryFileSystemEntry methodsFor: 'accessing' stamp: 'CamilloBruni 6/22/2012 19:59'! modificationTime ^ modificationTime! ! !MemoryFileSystemEntry methodsFor: 'accessing' stamp: 'CamilloBruni 6/22/2012 19:59'! modificationTime: anObject modificationTime := anObject! ! !MemoryFileSystemEntry methodsFor: 'initialize-release' stamp: 'CamilloBruni 6/22/2012 20:27'! initialize creationTime := modificationTime := DateAndTime now. super initialize! ! !MemoryFileSystemEntry methodsFor: 'testing' stamp: 'PavelKrivanek 11/23/2012 12:21'! isDirectory self subclassResponsibility! ! !MemoryFileSystemEntry methodsFor: 'testing' stamp: 'CamilloBruni 6/22/2012 20:13'! isFile ^ self isDirectory not! ! !MemoryFileSystemEntry methodsFor: 'private' stamp: 'CamilloBruni 6/22/2012 22:05'! modified modificationTime := DateAndTime now.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MemoryFileSystemEntry class instanceVariableNames: ''! !MemoryFileSystemEntry class methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 7/10/2012 14:53'! named: aFileName ^ self new basename: aFileName; yourself! ! MemoryFileSystemEntry subclass: #MemoryFileSystemFile instanceVariableNames: 'bytes size' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Memory'! !MemoryFileSystemFile commentStamp: '' prior: 0! I represent a memory file system entry for a regular file! !MemoryFileSystemFile methodsFor: 'accessing' stamp: 'CamilloBruni 6/23/2012 18:48'! bytes ^ bytes! ! !MemoryFileSystemFile methodsFor: 'accessing' stamp: 'CamilloBruni 7/10/2012 14:54'! fileSize ^ size! ! !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/22/2012 20:57'! sizeIncrement ^ (bytes size min: 20) max: 1024! ! !MemoryFileSystemFile methodsFor: 'accessing' stamp: 'CamilloBruni 6/23/2012 20:16'! truncate self truncateTo: size! ! !MemoryFileSystemFile methodsFor: 'accessing' stamp: 'CamilloBruni 6/23/2012 20:19'! truncateTo: aSize bytes size = aSize ifTrue: [ ^ self ]. bytes := bytes copyFrom: 1 to: aSize. size := bytes size. self modified.! ! !MemoryFileSystemFile methodsFor: 'initialize-release' stamp: 'CamilloBruni 6/22/2012 20:53'! initialize super initialize. bytes := #[]. size := 0! ! !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 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 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: '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: '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: 'stream-protocol' stamp: 'CamilloBruni 6/22/2012 21:07'! readStream ^ ReadStream on: bytes from: 1 to: size! ! !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: 'testing' stamp: 'CamilloBruni 6/22/2012 20:02'! isDirectory ^ false! ! !MemoryFileSystemFile methodsFor: 'private' stamp: 'CamilloBruni 6/22/2012 22:01'! updateSize: newSize size := newSize. modificationTime := nil.! ! FileSystemTest subclass: #MemoryFileSystemTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Tests-Memory'! !MemoryFileSystemTest methodsFor: 'initialize-release' stamp: 'EstebanLorenzano 4/3/2012 13:04'! createFileSystem ^ FileSystem memory! ! !MemoryFileSystemTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/3/2012 11:42'! testEqual | other | other := self createFileSystem. self deny: filesystem = other! ! FileSystemHandle subclass: #MemoryHandle instanceVariableNames: 'entry' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Memory'! !MemoryHandle commentStamp: '' prior: 0! 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: 'public' stamp: 'CamilloBruni 6/22/2012 20:52'! at: index ^ entry at: index! ! !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: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:55'! at: first write: aCollection startingAt: start count: count writable ifFalse: [ self primitiveFailed ]. entry at: first write: aCollection startingAt: start count: count.! ! !MemoryHandle methodsFor: 'public' stamp: 'CamilloBruni 6/23/2012 20:06'! close self isOpen ifFalse: [ ^ self ]. self truncate. entry := nil.! ! !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: 'public' stamp: 'CamilloBruni 6/23/2012 18:48'! size "return the size for the interna" ^ entry internalSize! ! !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! ! !MemoryHandle methodsFor: 'stream-protocol' stamp: 'CamilloBruni 6/23/2012 19:57'! copyFrom: from to: position ^ entry copyFrom: from to: position! ! !MemoryHandle methodsFor: 'stream-protocol' stamp: 'CamilloBruni 6/23/2012 18:47'! grownBy: length entry grownBy: length! ! !MemoryHandle methodsFor: 'stream-protocol' stamp: 'CamilloBruni 7/10/2012 14:56'! readStream "Return a readstream on my contents. Using myself as target collection allows to share the internal bytearray between multiple streams." ^ ReadStream on: self from: 1 to: entry fileSize! ! !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: 'testing' stamp: 'CamilloBruni 6/22/2012 20:57'! isOpen ^ entry notNil! ! !MemoryHandle methodsFor: 'private' stamp: 'CamilloBruni 6/22/2012 20:56'! grow entry grow! ! FileSystemHandleTest subclass: #MemoryHandleTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Tests-Memory'! !MemoryHandleTest methodsFor: 'running' stamp: 'EstebanLorenzano 4/3/2012 12:51'! createFileSystem ^ FileSystem memory! ! FileSystemStore subclass: #MemoryStore instanceVariableNames: 'root' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Memory'! !MemoryStore commentStamp: '' prior: 0! I'm a specific store for memory file system! !MemoryStore methodsFor: 'accessing' stamp: 'EstebanLorenzano 4/3/2012 09:36'! handleClass ^ MemoryHandle ! ! !MemoryStore methodsFor: 'accessing' stamp: 'cwp 2/18/2011 12:46'! root ^ root! ! !MemoryStore methodsFor: 'initialize-release' stamp: 'CamilloBruni 6/22/2012 20:16'! initialize root := MemoryFileSystemDirectory new! ! !MemoryStore methodsFor: 'printing' stamp: 'CamilloBruni 9/5/2012 17:43'! forReferencePrintOn: aStream aStream nextPutAll: 'memory://'! ! !MemoryStore methodsFor: 'public' stamp: 'CamilloBruni 7/10/2012 14:51'! basenameFromEntry: aMemoryFileSystemEntry ^ aMemoryFileSystemEntry basename! ! !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: 'public' stamp: 'CamilloBruni 7/10/2012 14:53'! 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 ensureDirectory: path basename ] ifAbsent: [ self signalDirectoryDoesNotExist: parent ]! ! !MemoryStore methodsFor: 'public' stamp: 'CamilloBruni 6/22/2012 20:11'! delete: path self nodeAt: path parent ifPresent: [ :dict | dict remove: path basename ] ifAbsent: [ ]! ! !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: 'private' stamp: 'CamilloBruni 6/22/2012 20:30'! basicIsDirectory: aMemoryFileSystemEntry ^ aMemoryFileSystemEntry isDirectory! ! !MemoryStore methodsFor: 'private' stamp: 'CamilloBruni 6/22/2012 20:04'! basicIsFile: aMemoryFileSystemEntry ^ aMemoryFileSystemEntry isFile! ! !MemoryStore methodsFor: 'private' stamp: 'EstebanLorenzano 8/2/2012 15:39'! basicIsSymlink: aNode ^false! ! !MemoryStore methodsFor: 'private' stamp: 'CamilloBruni 7/10/2012 20:57'! basicModificationTime: aMemoryFileSystemEntry ^ aMemoryFileSystemEntry modificationTime! ! !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: 'private' stamp: 'CamilloBruni 7/10/2012 21:18'! basicPosixPermissions: anEntry ^ 8r777! ! !MemoryStore methodsFor: 'private' stamp: 'CamilloBruni 7/10/2012 21:13'! basicSize: aMemoryFileSystemEntry ^ aMemoryFileSystemEntry fileSize! ! !MemoryStore methodsFor: 'private' stamp: 'CamilloBruni 7/10/2012 14:54'! 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 includes: destinationPath basename) ifTrue: [ "cannot overwrite existing file"^ presentBlock value ]. destinationNode fileEntryAt: destinationPath basename put: sourceNode copy ! ! !MemoryStore methodsFor: 'private' stamp: 'CamilloBruni 6/22/2012 20:10'! createFile: aPath ^ self nodeAt: aPath parent ifPresent: [ :entry | entry isDirectory ifTrue: [ entry ensureFile: aPath basename ]] ifAbsent: [ self signalDirectoryDoesNotExist: aPath parent ]! ! !MemoryStore methodsFor: 'private' stamp: 'CamilloBruni 7/10/2012 14:51'! directoryAt: aPath ifAbsent: absentBlock nodesDo: aBlock ^ self nodeAt: aPath ifPresent: [ :entry | entry isDirectory ifFalse: [ ^ absentBlock value ]. entry fileEntriesDo: aBlock ] ifAbsent: absentBlock! ! !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: '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 class instanceVariableNames: ''! !MemoryStore class methodsFor: 'public' stamp: 'cwp 2/18/2011 17:19'! delimiter ^ $/! ! !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 ^ $:! ! Morph subclass: #MenuCaptureMorph instanceVariableNames: 'worldBefore timeout timer' classVariableNames: '' poolDictionaries: '' category: 'SUnit-UITesting'! !MenuCaptureMorph methodsFor: 'initialize' stamp: 'SeanDeNigris 12/9/2011 21:20'! initialize worldBefore := World submorphs. timer := Stopwatch new activate.! ! !MenuCaptureMorph methodsFor: 'stepping' stamp: 'SeanDeNigris 12/9/2011 21:19'! setTimeout: aDuration timeout := aDuration. ^ self.! ! !MenuCaptureMorph methodsFor: 'stepping' stamp: 'SeanDeNigris 12/9/2011 21:12'! step Transcript show: 'moving'.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MenuCaptureMorph class instanceVariableNames: ''! !MenuCaptureMorph class methodsFor: 'as yet unclassified' stamp: 'SeanDeNigris 12/9/2011 21:19'! timingOutAfter: aDuration ^ (self new setTimeout: aDuration) openInWorld.! ! Morph subclass: #MenuCapturingMorph instanceVariableNames: 'menu' classVariableNames: '' poolDictionaries: '' category: 'SUnit-UITesting'! !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 ].! ! StringMorph subclass: #MenuItemMorph instanceVariableNames: 'isEnabled subMenu isSelected target selector arguments icon' classVariableNames: 'SubMenuMarker' poolDictionaries: '' category: 'Morphic-Menus'! !MenuItemMorph commentStamp: 'StephaneDucasse 4/22/2012 16:43' prior: 0! 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: '*Polymorph-Widgets' stamp: 'gvc 10/17/2008 14:43'! enabled "Delegate to exisitng method." ^self isEnabled! ! !MenuItemMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 10/17/2008 14:43'! enabled: aBoolean "Delegate to exisitng method." self isEnabled: aBoolean! ! !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: '*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: '*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: '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: 'accessing' stamp: 'jm 11/4/97 07:46'! arguments ^ arguments ! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'! arguments: aCollection arguments := aCollection. ! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'ar 1/16/2001 16:58'! contentString ^self valueOfProperty: #contentString! ! !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: 'accessing' stamp: 'ar 9/17/2000 18:32'! contents: aString ^self contents: aString withMarkers: true! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'ar 1/16/2001 16:57'! contents: aString withMarkers: aBool ^self contents: aString withMarkers: aBool inverse: false! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 4/23/2012 12:22'! 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 image: marker. marker position: self left @ (self top + 2). self addMorphFront: marker! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'nk 3/10/2004 15:19'! hasIcon "Answer whether the receiver has an icon." ^ icon notNil! ! !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: 'accessing' stamp: 'nk 3/10/2004 15:25'! hasMarker "Answer whether the receiver has a marker morph." ^ submorphs isEmpty not! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'ar 9/18/2000 11:40'! hasSubMenu "Return true if the receiver has a submenu" ^subMenu notNil! ! !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: 'dgd 3/22/2003 14:45'! icon "answer the receiver's icon" ^ icon! ! !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: 'accessing' stamp: 'jm 11/4/97 07:46'! isEnabled ^ isEnabled ! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'RAA 1/18/2001 18:24'! isStayUpItem ^selector == #toggleStayUp: or: [selector == #toggleStayUpIgnore:evt:]! ! !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: 'accessing' stamp: 'jm 11/4/97 07:46'! selector ^ selector ! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'! selector: aSymbol selector := aSymbol. ! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'! subMenu ^ subMenu ! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'! subMenu: aMenuMorph subMenu := aMenuMorph. self changed. ! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'! target ^ target! ! !MenuItemMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'! target: anObject target := anObject. ! ! !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: '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: '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: 'drawing' stamp: 'MarcusDenker 9/7/2010 17:39'! drawOn: aCanvas | stringColor stringBounds | isSelected & 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: 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: '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: '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: '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: '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: 'jm 11/4/97 07:15'! handlesMouseDown: evt ^ true ! ! !MenuItemMorph methodsFor: 'events' stamp: 'ar 9/16/2000 14:40'! handlesMouseOver: anEvent ^true! ! !MenuItemMorph methodsFor: 'events' stamp: 'ar 9/18/2000 21:46'! handlesMouseOverDragging: evt ^true! ! !MenuItemMorph methodsFor: 'events' stamp: 'CamilloBrui 7/8/2011 12:02'! invokeWithEvent: evt "Perform the action associated with the given menu item." | w | self isEnabled ifFalse: [^ self]. target class == HandMorph ifTrue: [(self notObsolete) 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: '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: '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: '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: '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: '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'! 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: '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: '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: 'ar 10/10/2000 02:05'! deleteIfPopUp: evt "Recurse up for nested pop ups" owner ifNotNil:[owner deleteIfPopUp: evt].! ! !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: '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: '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: '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: '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: '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: '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: 'rounding' stamp: 'dgd 9/1/2004 18:11'! wantsRoundedCorners ^ self isInDockingBar ifTrue: [true] ifFalse: [super wantsRoundedCorners]! ! !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: '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: 'selecting' stamp: 'dgd 9/9/2004 21:26'! isSelected ^ isSelected ! ! !MenuItemMorph methodsFor: 'selecting' stamp: 'ar 9/18/2000 11:09'! isSelected: aBoolean isSelected := aBoolean. self changed. ! ! !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: '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: 'private' stamp: 'dgd 3/31/2006 12:15'! bottomArrow ^ ColorForm mappingWhiteToTransparentFrom: ((SubMenuMarker rotateBy: 90) asFormOfDepth:8)! ! !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: 'private' stamp: 'dgd 3/31/2006 12:16'! leftArrow ^ ColorForm mappingWhiteToTransparentFrom: ((SubMenuMarker rotateBy: 180)asFormOfDepth: 8)! ! !MenuItemMorph methodsFor: 'private' stamp: 'ar 9/18/2000 10:27'! notObsolete "Provide backward compatibility with messages being sent to the Hand. Remove this when no projects made prior to 2.9 are likely to be used. If this method is removed early, the worst that can happen is a notifier when invoking an item in an obsolete menu." (HandMorph canUnderstand: (selector)) ifTrue: [^ true]. "a modern one" self inform: 'This world menu is obsolete. Please dismiss the menu and open a new one.'. ^ false ! ! !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: '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: 'private' stamp: 'dgd 9/1/2004 18:07'! rightArrow ^ SubMenuMarker! ! !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: '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: 'private' stamp: 'dgd 3/31/2006 12:16'! upArrow ^ ColorForm mappingWhiteToTransparentFrom: ((SubMenuMarker rotateBy: 270)asFormOfDepth: 8)! ! !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 class instanceVariableNames: ''! !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. ! ! Morph subclass: #MenuLineMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Menus'! !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: '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: 'initialization' stamp: 'ar 11/8/2000 23:09'! initialize super initialize. self hResizing: #spaceFill; vResizing: #spaceFill.! ! !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: '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! ! !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! ! AlignmentMorph subclass: #MenuMorph instanceVariableNames: 'defaultTarget selectedItem stayUp popUpOwner activeSubMenu activatorDockingBar embeddable menuItems' classVariableNames: 'CloseBoxImage PushPinImage' poolDictionaries: '' category: 'Morphic-Menus'! !MenuMorph commentStamp: '' prior: 0! 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: '*Keymapping-Core' stamp: 'ThierryGoubier 9/15/2012 22:29'! initializeShortcuts: aKMDispatcher super initializeShortcuts: aKMDispatcher. aKMDispatcher attachCategory: #MorphFocusNavigation! ! !MenuMorph methodsFor: '*Polymorph-Widgets' stamp: 'BenjaminVanRyseghem 3/28/2011 15:00'! addMenuItem: anItem self addMorphBack: anItem. ^ self menuItems add: anItem. ! ! !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: '*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: '*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: '*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: '*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: '*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: '*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: '*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: '*Polymorph-Widgets' stamp: 'GuillermoPolito 8/9/2010 21:25'! menuItems ^menuItems ifNil:[menuItems:= OrderedCollection new]. ! ! !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: 'gvc 1/16/2007 12:59'! takesKeyboardFocus "Answer whether the receiver can normally take keyboard focus." ^true! ! !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: '*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: 'accessing' stamp: 'dgd 9/1/2004 17:56'! activatedFromDockingBar: aDockingBar activatorDockingBar := aDockingBar! ! !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: 'accessing' stamp: 'sw 12/4/2001 21:22'! commandKeyHandler "Answer the receiver's commandKeyHandler" ^ self valueOfProperty: #commandKeyHandler ifAbsent: [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: 'accessing' stamp: 'ar 9/18/2000 13:19'! defaultTarget ^defaultTarget! ! !MenuMorph methodsFor: 'accessing' stamp: 'HilaireFernandes 11/19/2010 17:02'! embeddable ^ embeddable ifNil: [embeddable := false]. ! ! !MenuMorph methodsFor: 'accessing' stamp: 'AlainPlantec 12/14/2009 21:02'! embeddable: aBoolean embeddable := aBoolean! ! !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: 'accessing' stamp: 'ar 9/18/2000 11:18'! hasSubMenu: aMenuMorph self items do: [:each | (each hasSubMenu: aMenuMorph) ifTrue:[^true]]. ^ false ! ! !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: 'jm 11/4/97 07:46'! items ^ submorphs select: [:m | m isKindOf: MenuItemMorph] ! ! !MenuMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 3/22/2010 21:20'! lastItem submorphs reverseDo: [ :each | (each isKindOf: MenuItemMorph) ifTrue: [ ^each ] ]. ^submorphs last! ! !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: '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: 'accessing' stamp: 'ar 9/18/2000 10:07'! popUpOwner: aMenuItemMorph "Set the current pop-up owner" popUpOwner := aMenuItemMorph. ! ! !MenuMorph methodsFor: 'accessing' stamp: 'di 12/10/2001 22:11'! rootMenu popUpOwner ifNil: [^ self]. popUpOwner owner ifNil: [^ self]. ^ popUpOwner owner rootMenu! ! !MenuMorph methodsFor: 'accessing' stamp: 'jm 11/4/97 07:46'! stayUp ^ stayUp ! ! !MenuMorph methodsFor: 'accessing' stamp: 'alain.plantec 2/9/2009 16:16'! stayUp: aBoolean stayUp := aBoolean. aBoolean ifTrue: [ self removeStayUpBox ].! ! !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: '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: '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: '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: '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: '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: 'construction' stamp: 'EstebanLorenzano 1/31/2013 19:25'! addAllFromPragma: aString target: anObject self addAllFrom: (PragmaMenuBuilder pragmaKeyword: aString model: anObject) menu ! ! !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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: 'construction' stamp: 'MarcusDenker 10/6/2012 14:44'! 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: (self theme iconNamed: tuple fourth)]]]! ! !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: '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: '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: '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: '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: 'construction' stamp: 'AlainPlantec 12/13/2009 21:29'! 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: [| usm | usm := UpdatingStringMorph on: aTarget selector: aSelector. usm font: StandardFonts menuFont. usm useStringFormat. usm lock. titleContainer addMorphBack: usm]. "" 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: '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: '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: 'construction' stamp: 'sw 6/11/1999 16:49'! addUpdating: aWordingSelector action: aSymbol self addUpdating: aWordingSelector target: defaultTarget selector: aSymbol argumentList: EmptyArray ! ! !MenuMorph methodsFor: 'construction' stamp: 'sw 6/21/1999 11:34'! addUpdating: aWordingSelector enablement: anEnablementSelector action: aSymbol self addUpdating: aWordingSelector enablementSelector: anEnablementSelector target: defaultTarget selector: aSymbol argumentList: EmptyArray ! ! !MenuMorph methodsFor: 'construction' stamp: 'GuillermoPolito 8/9/2010 21:26'! addUpdating: wordingSelector 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 obtained by sending the wordingSelector to the target, and the optional enablementSelector determines whether or not the item should be enabled. Answer the item itself." | item | item := UpdatingMenuItemMorph new target: target; selector: aSymbol; wordingProvider: target wordingSelector: wordingSelector; enablementSelector: enablementSelector; arguments: argList asArray. self addMenuItem: item. ^ item ! ! !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: '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: '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: '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: 'construction' stamp: 'sw 11/5/1998 21:13'! balloonTextForLastItem: balloonText submorphs last setBalloonText: balloonText! ! !MenuMorph methodsFor: 'construction' stamp: 'jm 11/4/97 07:46'! defaultTarget: anObject "Set the default target for adding menu items." defaultTarget := anObject. ! ! !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: '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: 'control' stamp: 'AlainPlantec 12/14/2009 22:11'! activeSubmenu: aSubmenu activeSubMenu ifNotNil: [activeSubMenu delete]. activeSubMenu := aSubmenu. aSubmenu ifNotNil: [activeSubMenu activatedFromDockingBar: nil]! ! !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: '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: 'control' stamp: 'AlainPlantec 11/6/2011 13:35'! 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: (self theme blankIconOfWidth: maxIconWidth)]. ! ! !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: 'control' stamp: 'AlainPlantec 11/6/2011 13:33'! 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 submorphs select: [:m | m isKindOf: UpdatingMenuItemMorph]) do: [:m | m updateContents]. 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: '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: '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: 'control' stamp: 'sw 2/18/2001 00:52'! popUpInWorld "Present this menu in the current World" ^ self popUpInWorld: self currentWorld! ! !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: '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: '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: '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: '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: '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: '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: '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: '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: '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: 'events' stamp: 'ar 9/18/2000 10:13'! handlesMouseDown: evt ^true! ! !MenuMorph methodsFor: 'events' stamp: 'FernandoOlivero 4/12/2011 09:53'! 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 selectItem: nil event: evt. evt hand newMouseFocus: popUpOwner owner. ^evt hand newKeyboardFocus: popUpOwner owner]. (asc = 28 or: [asc = 29]) ifTrue: ["left or 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" matchString := self valueOfProperty: #matchString ifAbsentPut: [String new]. matchString := char = Character backspace ifTrue: [matchString isEmpty ifTrue: [matchString] ifFalse: [matchString allButLast]] ifFalse: [matchString copyWith: evt keyCharacter]. self setProperty: #matchString toValue: 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: '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: '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: '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 methodsFor: 'events' stamp: 'FernandoOlivero 4/12/2011 09:53'! updateColor "Update the color of the menu." | fill title bc | self theme preferGradientFill ifFalse: [^ self]. self fillStyle: (self theme menuFillStyleFor: self). "update the title color" title := self allMorphs detect: [:each | each hasProperty: #titleString] ifNone: [^ self]. title fillStyle: (self theme menuTitleFillStyleFor: title)! ! !MenuMorph methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/28/2012 18:10'! delete activeSubMenu ifNotNil:[activeSubMenu delete]. ^super delete! ! !MenuMorph methodsFor: 'initialization' stamp: 'FernandoOlivero 4/12/2011 09:53'! initialize super initialize. bounds := 0 @ 0 corner: 40 @ 10. 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: '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: '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: '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: '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: '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: '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: '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: 'keyboard control' stamp: 'rr 3/24/2004 13:41'! moveDown: evt ^self moveSelectionDown: 1 event: evt! ! !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: 'keyboard control' stamp: 'rr 3/24/2004 13:40'! moveUp: evt ^self moveSelectionDown: -1 event: 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: 'keyboard control' stamp: 'rr 9/15/2005 16:24'! selectMoreItem: evt | allItems more | allItems := self submorphs select: [:m | m isKindOf: MenuItemMorph]. more := allItems detect: [:m | (m contents size >= 4) and: [(m contents first: 4) asString = 'more'.]] ifNone: [^ self flash]. self selectItem: more event: evt. selectedItem invokeWithEvent: evt! ! !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: '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: '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: '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: '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: '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: 'menu' stamp: 'nk 3/31/2002 18:36'! removeStayUpItems | stayUpItems | stayUpItems := self items select: [ :item | item isStayUpItem ]. stayUpItems do: [ :ea | ea delete ]. ! ! !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: '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: '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: '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: '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: '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: '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: '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: 'modal control' stamp: 'KLC 4/11/2004 09:06'! 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 & self isModalInvokationDone not] whileTrue: [w doOneSubCycle]. self delete. originalFocusHolder ifNotNil: [aWorld primaryHand newKeyboardFocus: originalFocusHolder]. ^ self modalSelection! ! !MenuMorph methodsFor: 'modal control' stamp: 'ar 1/5/2002 21:33'! isModalInvokationDone ^self valueOfProperty: #isModalInvokationDone ifAbsent:[false]! ! !MenuMorph methodsFor: 'modal control' stamp: 'ar 1/5/2002 21:34'! isModalInvokationDone: aBool self setProperty: #isModalInvokationDone toValue: aBool ! ! !MenuMorph methodsFor: 'modal control' stamp: 'ar 1/5/2002 21:34'! modalSelection ^self valueOfProperty: #modalSelection ifAbsent:[nil]! ! !MenuMorph methodsFor: 'modal control' stamp: 'ar 1/5/2002 21:34'! modalSelection: anObject self setProperty: #modalSelection toValue: anObject. self isModalInvokationDone: true! ! !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: 'private' stamp: 'ar 10/7/2000 21:08'! invokeMetaMenu: evt stayUp ifFalse:[^self]. "Don't allow this" ^super invokeMetaMenu: evt! ! !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: '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: 'private' stamp: 'ar 9/18/2000 12:12'! selectedItem ^selectedItem! ! !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: 'MarcusDenker 10/26/2011 15:09'! 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: #topCenter; layoutInset: 0. ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MenuMorph class instanceVariableNames: ''! !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: '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: '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 ! ! !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: 'instance creation' stamp: 'AlainPlantec 1/5/2010 12:27'! initialize "MenuMorph initialize" PushPinImage := nil! ! !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: '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: '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: 'utilities' stamp: 'AlainPlantec 11/5/2011 14:30'! 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: self theme 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 == nil] whileTrue. ^result! ! !MenuMorph class methodsFor: 'utilities' stamp: 'AlainPlantec 11/5/2011 14:29'! inform: queryString "MenuMorph inform: 'I like Pharo'" | menu | (ProvideAnswerNotification signal: queryString) ifNotNil:[:answer | ^ self]. menu := self new. menu addTitle: queryString icon: self theme confirmIcon. menu add: 'OK' target: self selector: #yourself. menu invokeAt: ActiveHand position in: ActiveWorld allowKeyboard: true.! ! Object subclass: #MenuRegistration instanceVariableNames: 'parentName itemList order spec owner isGroup ordering precondition' classVariableNames: '' poolDictionaries: '' category: 'MenuRegistration-Core'! !MenuRegistration commentStamp: 'AlainPlantec 2/16/2010 23:17' prior: 0! 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: '*NautilusCommon' 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: '*NautilusCommon' stamp: 'BenjaminVanRyseghem 3/31/2011 01:50'! enabledBlock: aBlock self spec enabledBlock: aBlock! ! !MenuRegistration methodsFor: '*NautilusCommon' 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'! addItem: anItem "Add a MenuRegistration" self ensureItemList add: anItem! ! !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: '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/13/2010 12:52'! builder ^ owner builder! ! !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: 'accessing' stamp: 'AlainPlantec 2/16/2010 16:45'! ensureItemList "Return the list of MenuRegistration instances" ^ itemList ifNil: [itemList := OrderedCollection new]! ! !MenuRegistration methodsFor: 'accessing' stamp: 'AlainPlantec 2/16/2010 11:42'! isGroup: aBoolean isGroup := aBoolean! ! !MenuRegistration methodsFor: 'accessing' stamp: 'AlainPlantec 2/16/2010 16:45'! itemList "Return my children" ^ itemList ! ! !MenuRegistration methodsFor: 'accessing' stamp: 'AlainPlantec 2/15/2010 11:17'! itemList: aCollection "Set the list of MenuRegistration" itemList := aCollection! ! !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: 'accessing' stamp: 'AlainPlantec 2/13/2010 12:58'! itemReceiver ^ self target ifNil: [owner itemReceiver]! ! !MenuRegistration methodsFor: 'accessing' stamp: 'AlainPlantec 2/13/2010 12:54'! model ^ self builder model! ! !MenuRegistration methodsFor: 'accessing' stamp: 'AlainPlantec 2/11/2010 08:15'! order ^ order! ! !MenuRegistration methodsFor: 'accessing' stamp: 'AlainPlantec 2/15/2010 11:05'! order: aNumber "Set the value of order" order := aNumber! ! !MenuRegistration methodsFor: 'accessing' stamp: 'AlainPlantec 2/11/2010 08:15'! owner ^ owner! ! !MenuRegistration methodsFor: 'accessing' stamp: 'AlainPlantec 2/11/2010 08:15'! owner: anItem owner := anItem! ! !MenuRegistration methodsFor: 'accessing' stamp: 'AlainPlantec 2/10/2010 21:03'! parent: aSymbol self parentName: aSymbol! ! !MenuRegistration methodsFor: 'accessing' stamp: 'AlainPlantec 2/10/2010 13:54'! parentName ^ parentName! ! !MenuRegistration methodsFor: 'accessing' stamp: 'AlainPlantec 2/10/2010 13:54'! parentName: aSymbol parentName := aSymbol! ! !MenuRegistration methodsFor: 'accessing' stamp: 'AlainPlantec 4/10/2010 09:31'! precondition ^ precondition ifNil: [[true]]! ! !MenuRegistration methodsFor: 'accessing' stamp: 'AlainPlantec 4/10/2010 09:31'! precondition: aValuable precondition := aValuable! ! !MenuRegistration methodsFor: 'accessing' stamp: 'AlainPlantec 2/15/2010 11:05'! removeItem: anItem "Remove a MenuRegistration" self itemList remove: anItem ! ! !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: 'initialize-release' stamp: 'AlainPlantec 2/11/2010 16:35'! initialize super initialize. isGroup := false! ! !MenuRegistration methodsFor: 'initialize-release' stamp: 'AlainPlantec 2/15/2010 11:21'! release itemList := nil. super release ! ! !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: '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: '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 22:23'! icon: aForm "set the icon that is shown in the menu" self spec icon: aForm! ! !MenuRegistration methodsFor: 'spec accessing' stamp: 'EstebanLorenzano 1/30/2013 16:55'! keyText: aString self spec keyText: aString! ! !MenuRegistration methodsFor: 'spec accessing' stamp: 'AlainPlantec 2/12/2010 16:06'! label "return my label" ^ self spec label! ! !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: '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: '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: '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 16:08'! spec "return my PluggableMenuItemSpec" ^ spec ifNil: [spec := PluggableMenuItemSpec new]! ! !MenuRegistration methodsFor: 'spec accessing' stamp: 'AlainPlantec 2/13/2010 12:59'! target ^ self spec action ifNotNil: [:action | action receiver] ! ! !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: 'spec accessing' stamp: 'AlainPlantec 2/12/2010 16:09'! withSeparatorAfter "add a separator line after me" self spec separator: true! ! !MenuRegistration methodsFor: 'sub item creating' stamp: 'AlainPlantec 2/16/2010 11:42'! group: aSymbol ^ (self item: aSymbol) isGroup: true! ! !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: 'sub item creating' stamp: 'AlainPlantec 2/16/2010 13:43'! newSubItem | reg | reg := self class owner: self. self addItem: reg. ^ reg! ! !MenuRegistration methodsFor: 'sub item creating' stamp: 'AlainPlantec 2/16/2010 11:47'! with: aBlock self builder currentRoot: self while: aBlock! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MenuRegistration class instanceVariableNames: ''! !MenuRegistration class methodsFor: 'instance creation' stamp: 'AlainPlantec 2/16/2010 12:20'! owner: aMenuRegistration ^ self new owner: aMenuRegistration! ! Object subclass: #MenuRegistrationExample instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MenuRegistration-example'! !MenuRegistrationExample commentStamp: 'AlainPlantec 2/17/2010 01:10' prior: 0! 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 instanceVariableNames: ''! !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 actions' stamp: 'StephaneDucasse 3/17/2010 21:13'! saveAndQuit Smalltalk snapshot: true andQuit: true! ! !MenuRegistrationExample class methodsFor: 'menu actions' stamp: 'StephaneDucasse 6/11/2012 18:12'! saveAs Smalltalk saveAs.! ! !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: '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 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 declaring' stamp: 'AlainPlantec 2/12/2010 15:02'! pragmaKeyword ^ 'worldMenuExample'! ! !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: 'MarcusDenker 5/5/2012 12:50'! theme "Answer the ui theme that provides controls." ^UITheme current! ! !MenuRegistrationExample class methodsFor: 'menu declaring' stamp: 'IgorStasenko 4/15/2011 17:20'! toolsOn: aBuilder (aBuilder item: #Tools) order: 1.0; target: Smalltalk tools; icon: self theme 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]! ! Object subclass: #MenuSpec instanceVariableNames: 'name help' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Menus'! !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: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! ! !MenuSpec methodsFor: 'accessing' stamp: 'StephaneDucasse 6/10/2011 22:10'! name: anObject name := anObject! ! DiffMorph subclass: #MergeDiffMorph instanceVariableNames: 'allowJoinClicks' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Tools-Diff'! !MergeDiffMorph methodsFor: 'accessing' stamp: 'gvc 1/8/2009 18:17'! allowJoinClicks "Answer the value of allowJoinClicks" ^ allowJoinClicks! ! !MergeDiffMorph methodsFor: 'accessing' stamp: 'gvc 1/8/2009 18:17'! allowJoinClicks: anObject "Set the value of allowJoinClicks" allowJoinClicks := anObject! ! !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: '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: 'actions' stamp: 'gvc 11/1/2006 14:13'! joinSectionClass "Answer the class to use for a new join section." ^MergeJoinSection! ! !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: '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: 'initialize-release' stamp: 'gvc 1/8/2009 18:17'! initialize "Initialize the receiver." super initialize. self allowJoinClicks: true! ! !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: '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! ! JoinSection subclass: #MergeJoinSection instanceVariableNames: 'selectedBorderColor selected selectionState stateIcons allowClick' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Tools-Diff'! !MergeJoinSection methodsFor: 'accessing' stamp: 'gvc 1/8/2009 18:04'! allowClick "Answer the value of allowClick" ^ allowClick! ! !MergeJoinSection methodsFor: 'accessing' stamp: 'gvc 1/8/2009 18:04'! allowClick: anObject "Set the value of allowClick" allowClick := anObject! ! !MergeJoinSection methodsFor: 'accessing' stamp: 'gvc 10/25/2006 17:47'! selected "Answer the value of selected" ^ selected! ! !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: 'accessing' stamp: 'gvc 10/25/2006 17:43'! selectedBorderColor "Answer the value of selectedBorderColor" ^ selectedBorderColor! ! !MergeJoinSection methodsFor: 'accessing' stamp: 'gvc 10/25/2006 17:43'! selectedBorderColor: anObject "Set the value of selectedBorderColor" selectedBorderColor := anObject! ! !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:00'! selectionState: anObject "Set the value of selectionState" selectionState := anObject! ! !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:03'! stateIcons: anObject "Set the value of stateIcons" stateIcons := anObject! ! !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 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: '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: '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]]! ! !MergeJoinSection methodsFor: 'as yet unclassified' stamp: 'FernandoOlivero 4/12/2011 09:54'! defaultStateIcons "Answer the default state icons." | uiTheme | uiTheme :=self theme. ^{uiTheme smallBackIcon. uiTheme smallForwardIcon. uiTheme smallOkIcon. uiTheme smallCancelIcon}! ! !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 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: '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 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 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: 'as yet unclassified' stamp: 'MarcusDenker 4/14/2011 15:38'! theme "Answer the ui theme that provides controls." ^UITheme current! ! !MergeJoinSection methodsFor: 'as yet unclassified' stamp: 'gvc 1/8/2009 18:04'! wantsClick "Allow if explictly enabled and super." ^self allowClick and: [super wantsClick]! ! Object subclass: #Message instanceVariableNames: 'selector args lookupClass' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Methods'! !Message commentStamp: '' prior: 0! 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'! argument "Answer the first (presumably sole) argument" ^args at: 1! ! !Message methodsFor: 'accessing'! argument: newValue "Change the first argument to newValue and answer self" args at: 1 put: newValue! ! !Message methodsFor: 'accessing'! arguments "Answer the arguments of the receiver." ^args! ! !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: 'accessing'! selector "Answer the selector of the receiver." ^selector! ! !Message methodsFor: 'accessing'! sends: aSelector "answer whether this message's selector is aSelector" ^selector == aSelector! ! !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: '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: '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: 'ajh 1/22/2003 11:51'! sendTo: receiver "answer the result of sending this message to receiver" ^ receiver perform: selector withArguments: args! ! !Message methodsFor: 'sending' stamp: 'di 3/25/1999 21:54'! sentTo: receiver "answer the result of sending this message to receiver" lookupClass == nil ifTrue: [^ receiver perform: selector withArguments: args] ifFalse: [^ receiver perform: selector withArguments: args inSuperclass: lookupClass]! ! !Message methodsFor: 'testing' stamp: 'JuanVuletich 10/11/2010 20:33'! hasArguments ^args size > 0! ! !Message methodsFor: 'private' stamp: 'ajh 9/23/2001 04:59'! lookupClass: aClass lookupClass := aClass! ! !Message methodsFor: 'private' stamp: 'ajh 3/9/2003 19:25'! setSelector: aSymbol selector := aSymbol. ! ! !Message methodsFor: 'private'! setSelector: aSymbol arguments: anArray selector := aSymbol. args := anArray! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Message class instanceVariableNames: ''! !Message class methodsFor: 'instance creation'! selector: aSymbol "Answer an instance of me with unary selector, aSymbol." ^self new setSelector: aSymbol arguments: (Array new: 0)! ! !Message class methodsFor: 'instance creation'! 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)! ! !Message class methodsFor: 'instance creation'! selector: aSymbol arguments: anArray "Answer an instance of me with selector, aSymbol, and arguments, anArray." ^self new setSelector: aSymbol arguments: anArray! ! MessageNode subclass: #MessageAsTempNode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-ParseNodes'! !MessageAsTempNode commentStamp: '' prior: 0! 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 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: '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: '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! ! !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: '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! ! ComposableModel subclass: #MessageBrowser instanceVariableNames: 'listModel textModel toolbarModel maxClassSize refreshingBlockHolder cachedHierarchy wrapper searchedStringHolder titleHolder model topologicSortHolder textConverterHolder' classVariableNames: '' poolDictionaries: '' category: 'Spec-Tools-Senders'! !MessageBrowser commentStamp: '' prior: 0! 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: 'accessing' stamp: 'CamilloBruni 1/29/2013 23:50'! currentMethod ^ self selectedMessage! ! !MessageBrowser methodsFor: 'accessing'! listModel ^ listModel! ! !MessageBrowser methodsFor: 'accessing' stamp: 'EstebanLorenzano 1/31/2013 12:12'! model ^model! ! !MessageBrowser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/14/2012 10:32'! textConverter ^ textConverterHolder contents! ! !MessageBrowser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/14/2012 10:32'! textConverter: aTextConverter textConverterHolder contents: (aTextConverter method: self textConverter method). textModel aboutToStyle: self textConverter shouldShout . textModel text: self textConverter getText.! ! !MessageBrowser methodsFor: 'accessing'! textModel ^ textModel! ! !MessageBrowser methodsFor: 'accessing'! toolbarModel ^ toolbarModel! ! !MessageBrowser methodsFor: 'actions' stamp: 'CamilloBruni 1/29/2013 23:52'! browseClass self currentMethod ifNotNil: [ :method | method methodClass browse ]! ! !MessageBrowser methodsFor: 'actions' stamp: 'CamilloBruni 1/30/2013 00:01'! browseClassRefs self currentMethod ifNotNil: [ :method | model browseClassRefsOf: method methodClass ]! ! !MessageBrowser methodsFor: 'actions' stamp: 'CamilloBruni 1/29/2013 23:58'! browseMessages self currentMethod ifNotNil: [ :method | model browseMessagesFrom: method selector ]! ! !MessageBrowser methodsFor: 'actions' stamp: 'CamilloBruni 1/29/2013 23:52'! browseMethod self currentMethod ifNotNil: [ :method | method browse ]! ! !MessageBrowser methodsFor: 'actions' stamp: 'CamilloBruni 1/29/2013 23:57'! browseSendersOfMessage self currentMethod ifNotNil: [ :method | model browseSendersOfMessagesFrom: method selector ]! ! !MessageBrowser methodsFor: 'actions' stamp: 'CamilloBruni 1/29/2013 23:59'! browseVersions self currentMethod ifNotNil: [ :method | model browseVersionsFrom: method compiledMethod ]! ! !MessageBrowser methodsFor: 'actions' stamp: 'CamilloBruni 1/29/2013 23:51'! inspectMethod self currentMethod ifNotNil: [ :m | m inspect ]! ! !MessageBrowser methodsFor: 'actions' stamp: 'CamilloBruni 1/29/2013 23:55'! removeMethods self currentMethod ifNotNil: [ :method | model removeMethod: method inClass: method methodClass ]! ! !MessageBrowser methodsFor: 'announcements' stamp: 'GuillermoPolito 8/3/2012 13:32'! methodAdded: anAnnouncement | item | self isDisplayed ifFalse: [ ^ self ]. refreshingBlockHolder ifNil: [ ^ self ]. item := anAnnouncement method. (refreshingBlockHolder contents cull: item cull: anAnnouncement cull: self) ifFalse: [ ^ self ]. WorldState addDeferredUIMessage: [ | sel text boolean | boolean := textModel hasUnacceptedEdits. boolean ifTrue: [ text := textModel pendingText ]. sel := listModel selectedItem. self messages: (listModel listItems add: item; yourself). listModel setSelectedItem: sel. boolean ifTrue: [ textModel pendingText: text ] ]! ! !MessageBrowser methodsFor: 'announcements' stamp: 'GuillermoPolito 8/3/2012 13:34'! 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 contents cull: item cull: anAnnouncement cull: self) ifFalse: [ ^ self ]. index := listModel selectedIndex . WorldState addDeferredUIMessage: [ | text list edits | edits := textModel hasUnacceptedEdits. edits ifTrue: [ text := textModel pendingText ]. list := listModel listItems remove: sel ifAbsent: []; add: item asRingDefinition; "to ensure it's still as RGMethod" yourself. self messages: list. listModel setSelectedIndex: index. edits ifTrue: [ textModel pendingText: text. textModel hasEditingConflicts: true ]. ]! ! !MessageBrowser methodsFor: 'announcements'! methodRecategorized: aMethod! ! !MessageBrowser methodsFor: 'announcements' stamp: 'GuillermoPolito 8/3/2012 13:34'! 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 ]. WorldState addDeferredUIMessage:[ | sel itm hasPendingText | sel := listModel selectedIndex. itm := listModel selectedItem. hasPendingText := false. (itm notNil and: [(itm methodClass = item methodClass and: [ itm selector = item selector ])]) ifTrue: [ textModel hasUnacceptedEdits: false ]. self messages: (listModel listItems remove: item asRingDefinition ifAbsent: [ nil ]; yourself). listModel setSelectedIndex: sel. ]! ! !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: 'initialization' stamp: 'BenjaminVanRyseghem 12/12/2012 14:58'! initialize "Initialization code for MessageBrowser" textConverterHolder := SourceMethodConverter new asValueHolder. model := AbstractTool new. maxClassSize = nil. searchedStringHolder := '' asValueHolder. titleHolder := super title asValueHolder. topologicSortHolder := true asValueHolder. super initialize. self registerToAnnouncements.! ! !MessageBrowser methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 3/20/2012 15:25'! initializeDropList | item1 item2 item3 item4 | item1 := DropListItem named: 'Source' do: [ self textConverter: SourceMethodConverter new ]. item2 := DropListItem named: 'Byte Code' do: [ self textConverter: ByteCodeMethodConverter new ]. item3 := DropListItem named: 'Decompile' do: [ self textConverter: DecompileMethodConverter new ]. item4 := DropListItem named: 'Time stamp' do: [ self textConverter: TimeStampMethodConverter new ]. toolbarModel setDropListItems: {item1. item2. item3. item4}! ! !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: 'initialization' stamp: 'BenjaminVanRyseghem 2/8/2013 13:56'! initializeWidgets self instantiateModels: #( listModel MultiColumnListModel textModel TextModel toolbarModel MethodToolbar ). listModel displayBlock: [ :item | self wrapItem: item ]. textModel aboutToStyle: true. refreshingBlockHolder := [ :item | false ] asValueHolder. self setListMenu; initializeDropList; setFocus. ! ! !MessageBrowser methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 2/8/2013 14:23'! registerListShortcutsFor: aWidget aWidget on: $b command do: [ self browseMethod ]. aWidget on: $i command do: [ self inspectMethod ]. aWidget on: $m command do: [ self browseMessages ]. aWidget on: $n command do: [ self browseSendersOfMessage ]. aWidget on: $n shift command do: [ self browseClassRefs ]. aWidget on: $v command do: [ self browseVersions ]. aWidget on: $x command do: [ self removeMethods ].! ! !MessageBrowser methodsFor: 'initialization'! setFocus self focusOrder add: listModel; add: toolbarModel; add: textModel! ! !MessageBrowser methodsFor: 'initialization' stamp: 'EstebanLorenzano 1/31/2013 19:25'! setListMenu listModel menu: [ :menu | menu addAllFromPragma:'messageBrowserListMenu' target: self ].! ! !MessageBrowser methodsFor: 'messageList interface' stamp: 'BenjaminVanRyseghem 5/14/2012 02:00'! open self openWithSpec! ! !MessageBrowser methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/13/2012 10:48'! displayBlock: aBlock ^ listModel displayBlock: aBlock! ! !MessageBrowser methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/14/2012 10:55'! messages ^ listModel listItems! ! !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' stamp: 'BenjaminVanRyseghem 7/10/2012 15:32'! openWithSpec super openWithSpec. self updateTitle. textModel text: textModel getText. ^ window! ! !MessageBrowser methodsFor: 'protocol'! refreshingBlock: aBlock refreshingBlockHolder contents: aBlock! ! !MessageBrowser methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/14/2012 11:34'! selectedItem ^ listModel selectedItem! ! !MessageBrowser methodsFor: 'protocol'! selectedMessage ^ listModel selectedItem! ! !MessageBrowser methodsFor: 'protocol'! selectedMessage: aMessage listModel setSelectedItem: aMessage.! ! !MessageBrowser methodsFor: 'protocol'! setRefreshingBlockForImplementorsOf: aSelector self refreshingBlock: [:message | message selector = aSelector ].! ! !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: 'protocol' stamp: 'BenjaminVanRyseghem 6/14/2012 11:41'! setSelectedIndex: anIndex listModel setSelectedIndex: anIndex ! ! !MessageBrowser methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/14/2012 10:15'! sortingBlock: aBlock listModel sortingBlock: aBlock! ! !MessageBrowser methodsFor: 'protocol'! title: aString titleHolder contents: aString.! ! !MessageBrowser methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/14/2012 10:06'! topologicSort ^ topologicSortHolder contents! ! !MessageBrowser methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/14/2012 10:07'! topologicSort: aBoolean ^ topologicSortHolder contents: aBoolean! ! !MessageBrowser methodsFor: 'protocol-events' stamp: 'BenjaminVanRyseghem 6/14/2012 11:47'! whenSelectedItemChanged: aBlock listModel whenSelectedItemChanged: aBlock ! ! !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: '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: '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: '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: 'testing'! cacheHierarchyForClasses: aCollection cachedHierarchy := self buildHierarchyForMessages: aCollection.! ! !MessageBrowser methodsFor: 'testing'! 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: 'text selection'! autoSelect: aSelector textModel readSelectionBlock: [:text | self searchedString: aSelector in: text ]! ! !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: '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: 'private'! accept: text notifying: notifyer listModel selectedItem ifNotNil: [:message | message methodClass compile: text notifying: notifyer ]! ! !MessageBrowser methodsFor: 'private'! highlightSearchedString: string | searchedString interval firstIndex | searchedString := searchedStringHolder contents. 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: 'private'! initialExtent ^ (500 min: (World extent x)) @ (550 min: (World extent y))! ! !MessageBrowser methodsFor: 'private'! 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: 'private' stamp: 'BenjaminVanRyseghem 7/10/2012 15:31'! title ^ titleHolder contents , ' [' , listModel listSize printString , ']'! ! !MessageBrowser methodsFor: 'private' stamp: 'MarcusDenker 10/18/2012 17:33'! 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}.! ! !MessageBrowser methodsFor: 'private-focus' stamp: 'BenjaminVanRyseghem 2/8/2013 14:17'! ensureKeyBindingsFor: aWidget self registerListShortcutsFor: listModel! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MessageBrowser class instanceVariableNames: ''! !MessageBrowser class methodsFor: 'instance creation'! browseImplementors: aCollection of: aSymbol named: aName ^ self new setRefreshingBlockForImplementorsOf: aSymbol; messages: aCollection; title: aName; yourself! ! !MessageBrowser class methodsFor: 'instance creation'! browseMessages: aCollection refreshingBlock: aBlock named: anObject ^ self new refreshingBlock: aBlock; messages: aCollection; yourself! ! !MessageBrowser class methodsFor: 'instance creation'! browseSenders: aCollection of: aSymbol named: aName ^ self new setRefreshingBlockForSendersOf: aSymbol; messages: aCollection; title: aName; autoSelect: aSymbol; yourself! ! !MessageBrowser class methodsFor: 'instance creation'! on: aList named: aString autoSelect: aSelector ^ self new messages: aList; title: aString; autoSelect: aSelector; yourself! ! !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: 'messageList interface' stamp: 'BenjaminVanRyseghem 5/14/2012 02:00'! on: aMessageList named: aString ^ self new messages: aMessageList methodReferenceList; title: aString; 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: '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: '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: 'specs' stamp: 'BenjaminVanRyseghem 7/31/2012 17:16'! testSpec ^ SpecLayout composed newColumn: [:col | col add: #listModel; addSplitter; add: #toolbarModel height: 25; add: #textModel ] ! ! !MessageBrowser class methodsFor: 'specs'! title ^ 'Message Browser'! ! !MessageBrowser class methodsFor: 'tool registration'! openMessageList: messageList name: aString autoSelect: aSelector " Tool registry compitibility " | title | aString last = $] ifTrue: [ title := aString substrings allButLast joinUsing: ' ' ] ifFalse: [ title := aString ]. (aString beginsWith: 'Senders') ifTrue: [ ^ (self browseSenders: messageList of: aSelector named: title) openWithSpec ]. (aString beginsWith: 'Implementors') ifTrue: [ ^ (self browseImplementors: messageList of: aSelector named: title) openWithSpec ]. ^ (self on: messageList named: title autoSelect: aSelector) openWithSpec! ! !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! ! TestCase subclass: #MessageBrowserTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Spec-Tools-Senders-Tests'! !MessageBrowserTest commentStamp: '' prior: 0! A MessageBrowserTest is a test class for testing the behavior of MessageBrowser! !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))! ! !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 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))! ! ProtoObject subclass: #MessageCatcher instanceVariableNames: 'accumulator' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Methods'! !MessageCatcher commentStamp: '' prior: 0! Any message sent to me is returned as a Message object. "Message catcher" creates an instance of me. ! !MessageCatcher methodsFor: 'as yet unclassified' stamp: 'ajh 7/7/2004 18:22'! doesNotUnderstand: aMessage accumulator ifNotNil: [accumulator add: aMessage]. ^ aMessage! ! !MessageCatcher methodsFor: 'as yet unclassified' stamp: 'ajh 7/7/2004 18:22'! privAccumulator ^ accumulator! ! !MessageCatcher methodsFor: 'as yet unclassified' stamp: 'ajh 7/7/2004 18:22'! privAccumulator: collection accumulator := collection! ! DialogWindow subclass: #MessageDialogWindow instanceVariableNames: 'textMorph textFont iconMorph' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Windows'! !MessageDialogWindow commentStamp: 'gvc 5/18/2007 13:27' prior: 0! Dialog window displaying a message with a single OK button. Escape/return will close. Icon is a themed information icon.! !MessageDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/29/2007 13:29'! iconMorph "Answer the value of iconMorph" ^ iconMorph! ! !MessageDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/29/2007 13:28'! iconMorph: anObject "Set the value of iconMorph" iconMorph := anObject! ! !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: 'accessing' stamp: 'gvc 10/17/2006 14:19'! textFont "Answer the text font." ^textFont! ! !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: 'accessing' stamp: 'gvc 8/27/2006 10:26'! textMorph "Answer the value of textMorph" ^ textMorph! ! !MessageDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/27/2006 10:26'! textMorph: anObject "Set the value of textMorph" textMorph := anObject! ! !MessageDialogWindow methodsFor: 'actions' stamp: 'gvc 1/12/2007 15:15'! newButtons "Answer new buttons as appropriate." ^{self newOKButton isDefault: true}! ! !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: '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: '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: 'theme' stamp: 'AlainPlantec 10/25/2010 11:15'! themeChanged "Update the icon." super themeChanged. self iconMorph image: self icon ! ! !MessageDialogWindow methodsFor: 'visual properties' stamp: 'gvc 5/18/2007 10:30'! icon "Answer an icon for the receiver." ^self theme infoIcon! ! !MessageDialogWindow methodsFor: 'private' stamp: 'SeanDeNigris 7/24/2012 21:12'! lineLengths ^ self textLines collect: [ :line | self textFont widthOfString: line ].! ! !MessageDialogWindow methodsFor: 'private' stamp: 'gvc 8/29/2007 13:29'! newIconMorph "Answer an icon for the receiver." ^ImageMorph new image: self icon! ! !MessageDialogWindow methodsFor: 'private' stamp: 'GaryChambers 12/6/2011 10:09'! newTextMorph "Answer a text morph." ^self newText: ' '! ! !MessageDialogWindow methodsFor: 'private' stamp: 'SeanDeNigris 7/24/2012 21:09'! textLines ^ self textMorph text asString lines.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MessageDialogWindow class instanceVariableNames: ''! !MessageDialogWindow class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'gvc 5/22/2007 13:58'! taskbarIcon "Answer the icon for the receiver in a task bar." ^self theme smallInfoIcon! ! Object subclass: #MessageList instanceVariableNames: 'methodReferenceList versionsHistoryList useAsASet lastEntry sortingSelector environment dictionary sortedMethodReferencesList' classVariableNames: '' poolDictionaries: '' category: 'RecentSubmissions-Core'! !MessageList commentStamp: 'BenjaminVanRyseghem 11/29/2010 11:31' prior: 0! 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: '*RecentSubmissions-UI'! icon ^ self class icon! ! !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: '*RecentSubmissions-UI' stamp: 'BenjaminVanRyseghem 1/11/2011 14:06'! title ^'Message List'! ! !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'! dictionary dictionary ifNil: [self groupedByClass]. ^dictionary! ! !MessageList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:25'! dictionary: aDictionary dictionary := aDictionary! ! !MessageList methodsFor: 'accessing'! lastEntry ^lastEntry! ! !MessageList methodsFor: 'accessing'! level (self level2Selectors includes: (self sortingSelector)) ifTrue: [^2]. (self level3Selectors includes: (self sortingSelector)) ifTrue: [^3]. self error: 'The selector isn''t classified'! ! !MessageList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:25'! methodReferenceList ^ methodReferenceList! ! !MessageList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:25'! methodReferenceList: anObject methodReferenceList := anObject! ! !MessageList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:25'! sortedMethodReferencesList ^sortedMethodReferencesList! ! !MessageList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:25'! sortedMethodReferencesList: anObject sortedMethodReferencesList := anObject! ! !MessageList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:25'! sortingSelector sortingSelector ifNil: [^ #groupedByClass]. ^sortingSelector ! ! !MessageList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:25'! sortingSelector: anObject sortingSelector := anObject.! ! !MessageList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:26'! useAsASet ^ useAsASet! ! !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:26'! versionsHistoryList ^ versionsHistoryList! ! !MessageList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:26'! versionsHistoryList: anObject versionsHistoryList := anObject! ! !MessageList methodsFor: 'actions' stamp: 'BenjaminVanRyseghem 5/6/2011 15:10'! addFirstVersion | systemVersion date association | systemVersion := SystemVersion new date: '1 January 1901'. date := TimeStamp new. association := Association key: systemVersion value: date. self versionsHistoryList add: association.! ! !MessageList methodsFor: 'actions' stamp: 'BenjaminVanRyseghem 12/16/2010 15:29'! addMethodReference: aMethodReference self addMethodReferenceSilently: aMethodReference. self updateView.! ! !MessageList methodsFor: 'actions' stamp: 'BenjaminVanRyseghem 5/9/2011 14:47'! addMethodReference: aMethodReference at: index self addMethodReferenceSilently: aMethodReference at: index. self updateView.! ! !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: '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: 'actions' stamp: 'BenjaminVanRyseghem 11/29/2010 11:28'! addVersion: anAssociation self versionsHistoryList add: anAssociation. self updateView! ! !MessageList methodsFor: 'actions'! clearAll self methodReferenceList: OrderedCollection new. self updateView.! ! !MessageList methodsFor: 'actions' stamp: 'BenjaminVanRyseghem 11/29/2010 11:28'! reSort ^ self perform: (self sortingSelector,'Silently') asSymbol! ! !MessageList methodsFor: 'actions'! removeMethodReference: aMethodReference self methodReferenceList remove: aMethodReference. self updateView.! ! !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: '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: '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: '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: '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: 'converting' stamp: 'BenjaminVanRyseghem 1/11/2011 14:32'! groupedByClass "update the instance variable" self groupedByClassSilently. self updateView! ! !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: 'converting' stamp: 'BenjaminVanRyseghem 1/11/2011 14:10'! groupedByDateAscending "update the instance variable" self groupedByDateAscendingSilently. self updateView.! ! !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 1/11/2011 14:09'! groupedByDateDescending "update the instance variable" self groupedByDateDescendingSilently. 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: 'converting' stamp: 'BenjaminVanRyseghem 1/11/2011 14:09'! groupedByPackage "update the instance variable" self groupedByPackageSilently. self updateView! ! !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: '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'! groupedByVersionSilently "update the instance variable" | association | association := self buildByVersion. self dictionary: association key. self sortedMethodReferencesList: association value. self sortingSelector: self byVersionSelector.! ! !MessageList methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 11/29/2010 11:29'! environment ^Smalltalk globals! ! !MessageList methodsFor: 'initialize' 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: '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: '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: 'testing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:29'! isSortedByClass ^ self sortingSelector = self byClassSelector ! ! !MessageList methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:29'! isSortedByDateAscending ^self sortingSelector = self byDateAscendingSelector ! ! !MessageList methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:29'! isSortedByDateDescending ^self sortingSelector = self byDateDescendingSelector ! ! !MessageList methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:30'! isSortedByPackage ^self sortingSelector = self byPackageSelector ! ! !MessageList methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:30'! isSortedByVersion ^self sortingSelector = self byVersionSelector ! ! !MessageList methodsFor: 'private'! byClassSelector ^ #groupedByClass! ! !MessageList methodsFor: 'private'! byDateAscendingSelector ^ #groupedByDateAscending! ! !MessageList methodsFor: 'private'! byDateDescendingSelector ^ #groupedByDateDescending! ! !MessageList methodsFor: 'private'! byPackageSelector ^ #groupedByPackage! ! !MessageList methodsFor: 'private'! byVersionSelector ^ #groupedByVersion! ! !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: '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: 'private' stamp: 'BenjaminVanRyseghem 11/29/2010 11:30'! findVersionOf: aMethodReference | index | index := self findIndexOfVersionOf: aMethodReference. ^(self versionsHistoryList at: index) key! ! !MessageList methodsFor: 'private' stamp: 'StephaneDucasse 5/15/2011 18:01'! isEmpty ^ self methodReferenceList isEmpty! ! !MessageList methodsFor: 'private' stamp: 'BenjaminVanRyseghem 1/20/2011 15:51'! level2Selectors ^#( #groupedByClass #groupedByVersion)! ! !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: 'private' stamp: 'StephaneDucasse 5/15/2011 18:04'! zork ^ 34! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MessageList class instanceVariableNames: ''! !MessageList class methodsFor: '*Polymorph-Widgets'! 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: '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: 'instance creation'! with: aCollection. ^self new methodReferenceList: aCollection.! ! !MessageList class methodsFor: 'setting'! icon ^ThemeIcons smallInfoIcon! ! !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! ! MorphTreeNodeModel subclass: #MessageListAbstractNode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'RecentSubmissions-UI'! !MessageListAbstractNode commentStamp: '' prior: 0! A MessageListAbstractNode is an abstract node model. Instance Variables ! !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'! ! !MessageListAbstractNode methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:08'! getClass ^self subclassResponsibility! ! !MessageListAbstractNode methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:08'! inspectableContents ^self subclassResponsibility! ! !MessageListAbstractNode methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:08'! originalIndex ^self subclassResponsibility! ! !MessageListAbstractNode methodsFor: 'action' stamp: 'BenjaminVanRyseghem 11/29/2010 11:08'! printList: aStream ^self subclassResponsibility! ! !MessageListAbstractNode methodsFor: 'action' stamp: 'BenjaminVanRyseghem 11/29/2010 11:08'! removeMe ^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: 'overrided' stamp: 'BenjaminVanRyseghem 11/29/2010 11:08'! doubleClick ^self subclassResponsibility! ! !MessageListAbstractNode methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:08'! includes: aNode ^self subclassResponsibility! ! !MessageListAbstractNode methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:09'! isInspectable ^self subclassResponsibility ! ! !MessageListAbstractNode methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:09'! isMethod ^ self item isMethod.! ! MorphTreeModel subclass: #MessageListBrowser instanceVariableNames: 'model textArea preference wrapper preferenceList sortingList sortingSelector' classVariableNames: '' poolDictionaries: '' category: 'RecentSubmissions-UI'! !MessageListBrowser commentStamp: 'BenjaminVanRyseghem 8/31/2010 01:43' prior: 0! MessageListBrowser is the UI for instances of MessageList Instance Variables: messageList dictionary originalList selectedMorph treeMorph textArea dropList preference sortingSelector ! !MessageListBrowser methodsFor: '*Polymorph-Widgets'! taskbarIcon ^ self model taskbarIcon! ! !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: '*necompletion-extensions' stamp: 'SeanDeNigris 6/24/2012 09:25'! isCodeCompletionAllowed ^ true.! ! !MessageListBrowser methodsFor: '*necompletion-extensions' stamp: 'SeanDeNigris 6/24/2012 09:34'! selectedClassOrMetaClass ^ self selectedItem methodClass.! ! !MessageListBrowser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/10/2011 14:39'! dictionary | result | result := self model dictionary. result ifEmpty: [self selection: nil]. ^result! ! !MessageListBrowser methodsFor: 'accessing' stamp: 'AlainPlantec 2/13/2011 17:32'! emptySelection self selection: nil! ! !MessageListBrowser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:11'! environment ^ self model environment! ! !MessageListBrowser methodsFor: 'accessing' stamp: 'AlainPlantec 2/13/2011 15:28'! isComment | node | node := self selectedNode. ^(node isInspectable) & (node item = 'Comment'). ! ! !MessageListBrowser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 10:22'! model ^model! ! !MessageListBrowser methodsFor: 'accessing' stamp: 'AlainPlantec 2/13/2011 17:27'! model: aModel model := aModel. model when: #changed send: #updateView to: self. ! ! !MessageListBrowser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:11'! originalList ^ self model sortedMethodReferencesList! ! !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: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:11'! textArea ^ textArea! ! !MessageListBrowser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:11'! textArea: anObject textArea := anObject! ! !MessageListBrowser methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 11/29/2010 11:09'! browseButtonAction self browseSelectedMorph! ! !MessageListBrowser methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 11/29/2010 11:09'! browseButtonLabel ^'Browse'! ! !MessageListBrowser methodsFor: 'buttons behavior' stamp: 'AlainPlantec 2/13/2011 15:22'! browseButtonState ^self selectedItem isNil.! ! !MessageListBrowser methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 11/29/2010 11:09'! clearButtonAction self promptForClear ifTrue: [self model clearAll]! ! !MessageListBrowser methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 11/29/2010 11:10'! clearButtonLabel ^'Clear List'! ! !MessageListBrowser methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 5/11/2011 16:44'! clearButtonState ^self model dictionary isEmpty.! ! !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: '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: 'buttons behavior' stamp: 'BenjaminVanRyseghem 11/29/2010 11:10'! removeButtonAction self removeSelectedMorph! ! !MessageListBrowser methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 11/29/2010 11:10'! removeButtonLabel ^'Remove'! ! !MessageListBrowser methodsFor: 'buttons behavior' stamp: 'AlainPlantec 2/13/2011 15:24'! removeButtonState ^self selectedItem isNil.! ! !MessageListBrowser methodsFor: 'buttons behavior' stamp: 'AlainPlantec 2/13/2011 15:28'! removeSelectedMorph self selectedNode ifNotNil: [:n | (self promptForRemove: n) ifTrue: [n removeMe]]! ! !MessageListBrowser methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 11/29/2010 11:10'! revertButtonAction (self revertButtonState not and: [self textArea hasUnacceptedEdits not]) ifTrue: [self compileMethod: self textArea getText asString.] ifFalse: [ExampleBuilderMorph new alert: 'The source code must have not been modified']! ! !MessageListBrowser methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 11/29/2010 11:10'! revertButtonLabel ^'Revert'! ! !MessageListBrowser methodsFor: 'buttons behavior' stamp: 'AlainPlantec 2/13/2011 15:29'! revertButtonState ^self selectedNode notNil and: [self selectedNode isInspectable not] ! ! !MessageListBrowser methodsFor: 'display'! icon ^ self model icon! ! !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: 'display' stamp: 'AlainPlantec 2/13/2011 15:42'! updateTree | prevSelected | prevSelected := self selectedItem. self changed: #rootNodes. prevSelected ifNotNil: [self selectItems: prevSelected] ! ! !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: '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: '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: 'droplist' stamp: 'BenjaminVanRyseghem 11/29/2010 11:11'! preference ^ preference! ! !MessageListBrowser methodsFor: 'droplist' stamp: 'BenjaminVanRyseghem 3/20/2012 14:26'! preference: anObject preference := anObject. anObject value. self changed: #textToDisplay.! ! !MessageListBrowser methodsFor: 'droplist' stamp: 'BenjaminVanRyseghem 11/29/2010 11:13'! preferenceHelpText ^'Choose way to show'! ! !MessageListBrowser methodsFor: 'droplist' stamp: 'BenjaminVanRyseghem 3/20/2012 14:56'! sortingSelector ^ sortingSelector! ! !MessageListBrowser methodsFor: 'droplist' stamp: 'BenjaminVanRyseghem 3/20/2012 14:56'! sortingSelector: anObject anObject value. sortingSelector := anObject. self updateView.! ! !MessageListBrowser methodsFor: 'droplist' stamp: 'BenjaminVanRyseghem 11/29/2010 11:13'! sortingSelectorHelpText ^'Set the way to sort items' ! ! !MessageListBrowser methodsFor: 'droplist'! wrapDropListItem: anItem ^ anItem label! ! !MessageListBrowser methodsFor: 'droplist'! wrapPreference: anItem ^ anItem label! ! !MessageListBrowser methodsFor: 'droplist-items'! byClassItem ^ DropListItem named: self byClassLabel do: [ self model ifNotNil: [:m | m groupedByClass ]]! ! !MessageListBrowser methodsFor: 'droplist-items'! byDateAscendingItem ^ DropListItem named: self byDateAscendingLabel do: [ self model ifNotNil: [:m | m groupedByDateAscending ]]! ! !MessageListBrowser methodsFor: 'droplist-items'! byDateDescendingItem ^ DropListItem named: self byDateDescendingLabel do: [ self model ifNotNil: [:m | m groupedByDateDescending ]]! ! !MessageListBrowser methodsFor: 'droplist-items'! byPackageItem ^ DropListItem named: self byPackageLabel do: [ self model ifNotNil: [:m | m groupedByPackage ]]! ! !MessageListBrowser methodsFor: 'droplist-items'! byVersionItem ^ DropListItem named: self byVersionLabel do: [ self model ifNotNil: [:m | m groupedByVersion ]]! ! !MessageListBrowser methodsFor: 'droplist-items'! byteCodeItem ^ DropListItem named: self byteCodeLabel do: [ wrapper := ByteCodeMethodConverter method: wrapper method ]! ! !MessageListBrowser methodsFor: 'droplist-items'! diffItem ^ DropListItem named: self diffLabel do: [ wrapper := DiffMethodReferenceConverter methodReference: wrapper method referencesList: self originalList ]! ! !MessageListBrowser methodsFor: 'droplist-items'! infoItem ^ DropListItem named: self infoLabel do: [ wrapper := TimeStampMethodConverter method: wrapper method ]! ! !MessageListBrowser methodsFor: 'droplist-items'! sourceItem ^ DropListItem named: self sourceLabel do: [ wrapper := SourceMethodConverter method: wrapper method ]! ! !MessageListBrowser methodsFor: 'droplist-items'! versionItem ^ DropListItem named: self versionLabel do: [ wrapper := VersionMethodReferenceConverter methodReference: wrapper method referencesList: self originalList ]! ! !MessageListBrowser methodsFor: 'droplist-labels' stamp: 'BenjaminVanRyseghem 11/29/2010 11:12'! byClassLabel ^'By Class'! ! !MessageListBrowser methodsFor: 'droplist-labels' stamp: 'BenjaminVanRyseghem 11/29/2010 11:12'! byDateAscendingLabel ^'By Date Ascending'! ! !MessageListBrowser methodsFor: 'droplist-labels' stamp: 'BenjaminVanRyseghem 11/29/2010 11:12'! byDateDescendingLabel ^'By Date Descending'! ! !MessageListBrowser methodsFor: 'droplist-labels' stamp: 'BenjaminVanRyseghem 11/29/2010 11:12'! byPackageLabel ^'By Package'! ! !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'! byteCodeLabel ^ 'Byte Code'! ! !MessageListBrowser methodsFor: 'droplist-labels' stamp: 'BenjaminVanRyseghem 3/20/2012 14:20'! diffLabel ^'Diffs'! ! !MessageListBrowser methodsFor: 'droplist-labels' stamp: 'BenjaminVanRyseghem 3/20/2012 14:20'! infoLabel ^'Change Date'! ! !MessageListBrowser methodsFor: 'droplist-labels' stamp: 'BenjaminVanRyseghem 3/20/2012 14:20'! sourceLabel ^'Source'! ! !MessageListBrowser methodsFor: 'droplist-labels' stamp: 'BenjaminVanRyseghem 11/29/2010 11:13'! versionLabel ^'Version'! ! !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: '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: 'items creation' stamp: 'BenjaminVanRyseghem 11/29/2010 11:13'! buildButtonBrowse ^(PluggableButtonMorph on: self getState: #browseButtonState action: #browseButtonAction label: #browseButtonLabel) hResizing: #spaceFill! ! !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: 'items creation' stamp: 'BenjaminVanRyseghem 11/29/2010 11:13'! buildButtonRemove ^(PluggableButtonMorph on: self getState: #removeButtonState action: #removeButtonAction label: #removeButtonLabel) hResizing: #spaceFill! ! !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: '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: '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: '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: '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: 'items creation' stamp: 'AlainPlantec 10/8/2011 14:21'! treeMorph ^ super defaultTreeMorph doubleClickSelector: #doubleClick; autoDeselection: true; getMenuSelector: #menu:shifted: ! ! !MessageListBrowser methodsFor: 'menus' stamp: 'AlainPlantec 2/13/2011 15:30'! browseSelectedMorph self selectedNode ifNotNil: [ :node | node doubleClick].! ! !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: '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: '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: '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: '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: 'text' stamp: 'BenjaminVanRyseghem 3/16/2012 02:24'! displayInformationFrom: aMessageListInspectableNode ^ wrapper getTextFor: aMessageListInspectableNode item! ! !MessageListBrowser methodsFor: 'text' stamp: 'AlainPlantec 2/13/2011 15:31'! textToDisplay self selectedNode isNil ifFalse: [ self selectedNode isInspectable ifTrue: [^self displayInformationFrom: self selectedNode]]. ^nil! ! !MessageListBrowser methodsFor: 'text' stamp: 'BenjaminVanRyseghem 5/11/2011 16:45'! updateTextArea self textArea ifNil: [^self]. (self selectedNode isNil) ifTrue: [self textArea visible: false] ifFalse: [ (self selectedNode isInspectable) ifTrue: [self textArea visible: true] ifFalse: [self textArea hide]]! ! !MessageListBrowser methodsFor: 'tree' stamp: 'BenjaminVanRyseghem 11/29/2010 11:16'! doubleClick self selectedNode ifNotNil: [:n | n doubleClick]! ! !MessageListBrowser methodsFor: 'tree' stamp: 'BenjaminVanRyseghem 11/29/2010 11:16'! getMethod: aMessageListInspectableNode | methodReference | methodReference := (self getMethodReference: aMessageListInspectableNode) . ^ methodReference compiledMethod. ! ! !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: 'tree'! getMethodReference: aMessageListInspectableNode ^aMessageListInspectableNode item.! ! !MessageListBrowser methodsFor: 'tree' stamp: 'BenjaminVanRyseghem 11/29/2010 11:16'! level ^ self model level.! ! !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: '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: 'private'! 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: 'private' stamp: 'BenjaminVanRyseghem 5/5/2011 14:04'! textMorphClass ^ PluggableTextMorph! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MessageListBrowser class instanceVariableNames: ''! !MessageListBrowser class methodsFor: 'deprecated' stamp: 'StephaneDucasse 11/26/2010 16:58'! byClassOn: aMessageList ^self on: aMessageList groupedUsing: aMessageList byClassSelector! ! !MessageListBrowser class methodsFor: 'deprecated' stamp: 'StephaneDucasse 11/26/2010 16:58'! byDateAscendingOn: aMessageList ^self on: aMessageList groupedUsing: aMessageList byDateAscendingSelector! ! !MessageListBrowser class methodsFor: 'deprecated' stamp: 'StephaneDucasse 11/26/2010 16:58'! byDateDescendingOn: aMessageList ^self on: aMessageList groupedUsing: aMessageList byDateDescendingSelector.! ! !MessageListBrowser class methodsFor: 'deprecated' stamp: 'BenjaminVanRyseghem 9/17/2011 16:53'! on: aMessageList groupedUsing: aSelector aMessageList perform: aSelector. ^self new model: aMessageList. ! ! !MessageListBrowser class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 11/29/2010 10:23'! on: aMessageList ^self new model: aMessageList ! ! MessageListAbstractNode subclass: #MessageListInspectableNode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'RecentSubmissions-UI'! !MessageListInspectableNode methodsFor: 'accessing' stamp: 'VeronicaUquillas 9/3/2011 20:14'! getClass ^self item realClass! ! !MessageListInspectableNode methodsFor: 'accessing' stamp: 'AlainPlantec 2/13/2011 17:48'! inspectableContents ^ OrderedCollection with: self! ! !MessageListInspectableNode methodsFor: 'accessing'! 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: 'overrided' stamp: 'VeronicaUquillas 8/31/2011 23:51'! asString ^ self item ifNotNil: [self item fullName ] ! ! !MessageListInspectableNode methodsFor: 'overrided' stamp: 'BenjaminVanRyseghem 11/29/2010 11:17'! doubleClick self item browse! ! !MessageListInspectableNode methodsFor: 'testing'! includes: aNode ^ self = aNode complexContents.! ! !MessageListInspectableNode methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:17'! isInspectable ^true! ! MessageListAbstractNode subclass: #MessageListNonInspectableNode instanceVariableNames: 'dictionary' classVariableNames: '' poolDictionaries: '' category: 'RecentSubmissions-UI'! !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 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:18'! dictionary dictionary ifNil: [ self parentNode isNil ifTrue: [ self model level = 2 ifTrue: [dictionary := self model dictionary]. self model level = 3 ifTrue:[dictionary := self model dictionary at: self item]] ifFalse: [dictionary := self model dictionary at: (self parentNode item)]]. ^dictionary! ! !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: '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: '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: 'action'! removeMe self contents do: [:each | each removeMe].! ! !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: '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: 'AlainPlantec 2/13/2011 19:35'! includes: aNode ^ self = aNode complexContents | (self contents detect: [:each | each includes: aNode] ifNone: []) notNil ! ! !MessageListNonInspectableNode methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/29/2010 11:18'! isInspectable ^false! ! ParseNode subclass: #MessageNode instanceVariableNames: 'receiver selector precedence special arguments sizes equalNode caseErrorNode originalSelector originalArguments' classVariableNames: 'MacroEmitters MacroPrinters MacroSelectors MacroSizers MacroTransformers StdTypers ThenFlag' poolDictionaries: '' category: 'Compiler-ParseNodes'! !MessageNode commentStamp: '' prior: 0! 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: 'cascading'! cascadeReceiver "Nil out rcvr (to indicate cascade) and return what it had been." | rcvr | rcvr := receiver. receiver := nil. ^rcvr! ! !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: '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: '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: '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: '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: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: '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: '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: '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: '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 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: '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: '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: '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: '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: '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: '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: 'equation translation'! arguments ^arguments! ! !MessageNode methodsFor: 'equation translation' stamp: 'tk 10/27/2000 15:11'! arguments: list arguments := list! ! !MessageNode methodsFor: 'equation translation'! receiver ^receiver! ! !MessageNode methodsFor: 'equation translation' stamp: 'RAA 2/14/2001 14:07'! receiver: val "14 feb 2001 - removed return arrow" receiver := val! ! !MessageNode methodsFor: 'equation translation'! selector ^selector! ! !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: 'initialize-release' stamp: 'nice 4/1/2011 19:34'! 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 isNil ifTrue: [selector := SelectorNode new key: (MacroSelectors at: special) code: #macro]] ifFalse: [selector := encoder encodeSelector: aSelector. rcvr == NodeSuper ifTrue: [encoder noteSuper]]. ! ! !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: 'initialize-release' stamp: 'tk 10/26/2000 15:37'! selector: sel selector := sel! ! !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: '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'! transform: encoder special = 0 ifTrue: [^false]. (self perform: (MacroTransformers at: special) with: encoder) ifTrue: [^true] ifFalse: [special := 0. ^false]! ! !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: 'macro transformations'! transformBoolean: encoder ^self checkBlock: (arguments at: 1) as: 'argument' from: encoder! ! !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/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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: 'printing' stamp: 'RAA 2/15/2001 19:25'! macroPrinter special > 0 ifTrue: [^MacroPrinters at: special]. ^nil ! ! !MessageNode methodsFor: 'printing'! precedence ^precedence! ! !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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: 'printing' stamp: 'eem 6/2/2008 11:47'! printWithClosureAnalysisCaseOn: 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 printWithClosureAnalysisOn: aStream indent: level precedence: 3. aStream nextPutAll: ' caseOf: '. braceNode isVariableReference ifTrue: [braceNode printWithClosureAnalysisOn: aStream indent: level] ifFalse: [aStream nextPutAll: '{'; crtab: level + 1. braceNode casesForwardDo: [:keyNode :valueNode :last | keyNode printWithClosureAnalysisOn: aStream indent: level + 1. aStream nextPutAll: ' -> '. valueNode isComplex ifTrue: [aStream crtab: level + 2. extra := 1] ifFalse: [extra := 0]. valueNode printWithClosureAnalysisOn: 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 printWithClosureAnalysisOn: aStream indent: level + 1 + extra]! ! !MessageNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! printWithClosureAnalysisIfNil: aStream indent: level self printWithClosureAnalysisReceiver: receiver on: aStream indent: level. ^self printWithClosureAnalysisKeywords: selector key arguments: (Array with: arguments first) on: aStream indent: level! ! !MessageNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! printWithClosureAnalysisIfNilNotNil: aStream indent: level self printWithClosureAnalysisReceiver: receiver ifNilReceiver on: aStream indent: level. (arguments first isJust: NodeNil) ifTrue: [^self printWithClosureAnalysisKeywords: #ifNotNil: arguments: { arguments second } on: aStream indent: level]. (arguments second isJust: NodeNil) ifTrue: [^self printWithClosureAnalysisKeywords: #ifNil: arguments: { arguments first } on: aStream indent: level]. ^self printWithClosureAnalysisKeywords: #ifNil:ifNotNil: arguments: arguments on: aStream indent: level! ! !MessageNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! printWithClosureAnalysisIfOn: aStream indent: level receiver ifNotNil: [receiver printWithClosureAnalysisOn: aStream indent: level + 1 precedence: precedence]. (arguments last isJust: NodeNil) ifTrue: [^self printWithClosureAnalysisKeywords: #ifTrue: arguments: (Array with: arguments first) on: aStream indent: level]. (arguments last isJust: NodeFalse) ifTrue: [^self printWithClosureAnalysisKeywords: #and: arguments: (Array with: arguments first) on: aStream indent: level]. (arguments first isJust: NodeNil) ifTrue: [^self printWithClosureAnalysisKeywords: #ifFalse: arguments: (Array with: arguments last) on: aStream indent: level]. (arguments first isJust: NodeTrue) ifTrue: [^self printWithClosureAnalysisKeywords: #or: arguments: (Array with: arguments last) on: aStream indent: level]. self printWithClosureAnalysisKeywords: #ifTrue:ifFalse: arguments: arguments on: aStream indent: level! ! !MessageNode methodsFor: 'printing' stamp: 'eem 9/25/2008 14:51'! printWithClosureAnalysisKeywords: 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 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 printWithClosureAnalysisOn: aStream indent: level + 1 + indent precedence: (precedence = 2 ifTrue: [1] ifFalse: [precedence])]! ! !MessageNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! printWithClosureAnalysisOn: 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 printWithClosureAnalysisReceiver: receiver on: aStream indent: level. self printWithClosureAnalysisKeywords: selector key arguments: arguments on: aStream indent: level! ! !MessageNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! printWithClosureAnalysisOn: strm indent: level precedence: outerPrecedence | parenthesize | parenthesize := precedence > outerPrecedence or: [outerPrecedence = 3 and: [precedence = 3 "both keywords"]]. parenthesize ifTrue: [strm nextPutAll: '('. self printWithClosureAnalysisOn: strm indent: level. strm nextPutAll: ')'] ifFalse: [self printWithClosureAnalysisOn: strm indent: level]! ! !MessageNode methodsFor: 'printing' stamp: 'eem 9/25/2008 14:53'! printWithClosureAnalysisParenReceiver: rcvr on: aStream indent: level rcvr isBlockNode ifTrue: [^rcvr printWithClosureAnalysisOn: aStream indent: level]. aStream nextPut: $(. rcvr printWithClosureAnalysisOn: aStream indent: level. aStream nextPut: $)! ! !MessageNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! printWithClosureAnalysisReceiver: rcvr on: aStream indent: level rcvr ifNil: [^self]. "Force parens around keyword receiver of kwd message" rcvr printWithClosureAnalysisOn: aStream indent: level precedence: precedence! ! !MessageNode methodsFor: 'printing' stamp: 'ul 11/15/2010 11:54'! printWithClosureAnalysisToDoOn: aStream indent: level | limitNode | self printWithClosureAnalysisReceiver: receiver on: aStream indent: level. limitNode := (arguments last == nil or: [arguments last isAssignmentNode not]) ifTrue: [arguments first] ifFalse: [arguments last value]. (selector key = #to:by:do: and: [(arguments at: 2) isConstantNumber and: [(arguments at: 2) key = 1]]) ifTrue: [self printWithClosureAnalysisKeywords: #to:do: arguments: (Array with: limitNode with: (arguments at: 3)) on: aStream indent: level] ifFalse: [self printWithClosureAnalysisKeywords: selector key arguments: (Array with: limitNode) , arguments allButFirst on: aStream indent: level]! ! !MessageNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! printWithClosureAnalysisWhileOn: aStream indent: level self printWithClosureAnalysisReceiver: 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 printWithClosureAnalysisKeywords: selector key arguments: arguments on: aStream indent: level! ! !MessageNode methodsFor: 'printing' stamp: 'di 5/2/2000 00:16'! test 3 > 4 ifTrue: [4+5 between: 6 and: 7] ifFalse: [4 between: 6+5 and: 7-2]! ! !MessageNode methodsFor: 'testing' stamp: 'eem 2/3/2011 09:08'! canCascade ^receiver ~~ NodeSuper! ! !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: 'testing'! isComplex ^(special between: 1 and: 10) or: [arguments size > 2 or: [receiver isComplex]]! ! !MessageNode methodsFor: 'testing' stamp: 'md 7/27/2006 19:09'! isMessage ^true! ! !MessageNode methodsFor: 'testing'! 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: 'testing' stamp: 'John M McIntosh 3/2/2009 19:58'! isMessageNode ^true! ! !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: 'eem 7/20/2009 09:31'! isOptimized ^special > 0! ! !MessageNode methodsFor: 'testing' stamp: 'eem 7/20/2009 10:44'! isOptimizedLoop ^special > 0 and: [#(transformWhile: transformToDo:) includes: (MacroTransformers at: special)]! ! !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: 'testing'! toDoIncrement: variable (receiver = variable and: [selector key = #+]) ifFalse: [^ nil]. arguments first isConstantNumber ifTrue: [^ arguments first] ifFalse: [^ nil]! ! !MessageNode methodsFor: 'testing'! toDoLimit: variable (receiver = variable and: [selector key = #<= or: [selector key = #>=]]) ifTrue: [^ arguments first] ifFalse: [^ nil]! ! !MessageNode methodsFor: 'visiting' stamp: 'eem 9/6/2009 12:35'! accept: aVisitor ^aVisitor visitMessageNode: self! ! !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: 'vb 4/15/2007 09:10'! checkBlock: node as: nodeName from: encoder ^self checkBlock: node as: nodeName from: encoder maxArgs: 0! ! !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: 'private' stamp: 'acg 1/28/2000 00:57'! ifNilReceiver ^receiver! ! !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 class instanceVariableNames: ''! !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:)! ! Error subclass: #MessageNotUnderstood instanceVariableNames: 'message receiver reachedDefaultHandler' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Methods'! !MessageNotUnderstood commentStamp: '' prior: 0! This exception is provided to support Object>>doesNotUnderstand:.! !MessageNotUnderstood methodsFor: 'accessing' stamp: 'stephane.ducasse 12/22/2008 13:51'! reachedDefaultHandler ^reachedDefaultHandler! ! !MessageNotUnderstood methodsFor: 'exceptionBuilder' stamp: 'bf 6/17/2009 13:44'! messageText "Return an exception's message text." ^messageText == nil ifTrue: [message == nil ifTrue: [super messageText] ifFalse: [ message lookupClass == UndefinedObject ifTrue: ['receiver of "{1}" is nil' translated format: {message selector asString}] ifFalse: [message lookupClass printString, '>>', message selector asString]]] ifFalse: [messageText]! ! !MessageNotUnderstood methodsFor: 'exceptionbuilder' stamp: 'pnm 8/16/2000 15:03'! message: aMessage message := aMessage! ! !MessageNotUnderstood methodsFor: 'exceptionbuilder' stamp: 'ajh 10/9/2001 16:38'! receiver: obj receiver := obj! ! !MessageNotUnderstood methodsFor: 'exceptiondescription' stamp: 'stephane.ducasse 12/22/2008 13:50'! defaultAction reachedDefaultHandler := true. super defaultAction.! ! !MessageNotUnderstood methodsFor: 'exceptiondescription' stamp: 'tfei 6/4/1999 18:30'! isResumable "Determine whether an exception is resumable." ^true! ! !MessageNotUnderstood methodsFor: 'exceptiondescription' stamp: 'tfei 6/4/1999 18:27'! message "Answer the selector and arguments of the message that failed." ^message! ! !MessageNotUnderstood methodsFor: 'exceptiondescription' stamp: 'ajh 10/9/2001 16:39'! receiver "Answer the receiver that did not understand the message" ^ receiver! ! !MessageNotUnderstood methodsFor: 'initialization' stamp: 'stephane.ducasse 12/22/2008 13:50'! initialize super initialize. reachedDefaultHandler := false ! ! Object subclass: #MessageSend instanceVariableNames: 'receiver selector arguments' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Objects'! !MessageSend commentStamp: 'DF 5/25/2006 19:54' prior: 0! 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: 'accessing' stamp: 'sma 2/29/2000 20:39'! arguments ^ arguments! ! !MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:40'! arguments: anArray arguments := anArray! ! !MessageSend methodsFor: 'accessing' stamp: 'eem 1/3/2009 10:42'! numArgs "Answer the number of arguments in this message" ^arguments size! ! !MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:39'! receiver ^ receiver! ! !MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:39'! receiver: anObject receiver := anObject! ! !MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:39'! selector ^ selector! ! !MessageSend methodsFor: 'accessing' stamp: 'sma 2/29/2000 20:39'! selector: aSymbol selector := aSymbol! ! !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: 'comparing' stamp: 'sma 3/11/2000 10:35'! hash ^ receiver hash bitXor: selector hash! ! !MessageSend methodsFor: 'converting' stamp: 'nk 12/20/2002 17:54'! asMinimalRepresentation ^self! ! !MessageSend methodsFor: 'converting' stamp: 'IgorStasenko 3/12/2011 17:49'! asWeakMessageSend ^ WeakMessageSend receiver: receiver selector: selector arguments: arguments copy! ! !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:16'! cull: arg1 cull: arg2 ^ selector numArgs < 2 ifTrue: [ self cull: arg1] ifFalse: [ self value: arg1 value: arg2 ]! ! !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: '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: '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: '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: 'reThink 2/18/2001 16:51'! valueWithArguments: anArray ^ receiver perform: selector withArguments: (self collectArguments: anArray)! ! !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: 'testing' stamp: 'nk 4/25/2002 08:04'! isMessageSend ^true ! ! !MessageSend methodsFor: 'testing' stamp: 'nk 7/21/2003 15:16'! isValid ^true! ! !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 instanceVariableNames: ''! !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:44'! receiver: anObject selector: aSymbol argument: aParameter ^ self receiver: anObject selector: aSymbol arguments: (Array with: aParameter)! ! !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! ! Magnitude subclass: #MessageTally instanceVariableNames: 'class method process tally receivers senders time gcStats maxClassNameSize maxClassPlusSelectorSize maxTabs reportOtherProcesses' classVariableNames: 'DefaultPollPeriod Timer' poolDictionaries: '' category: 'Tools-Profilers'! !MessageTally commentStamp: 'StephaneDucasse 9/27/2009 10:42' prior: 0! 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: 'accessing' stamp: 'Alexandre Bergel 3/5/2010 17:18'! method "Return the compiled method associated to this tally" ^method! ! !MessageTally methodsFor: 'accessing' stamp: 'Alexandre Bergel 3/5/2010 17:19'! process "Return the profiled process" ^process! ! !MessageTally methodsFor: 'accessing' stamp: 'ar 3/3/2009 19:29'! process: aProcess process := aProcess! ! !MessageTally methodsFor: 'accessing' stamp: 'Alexandre Bergel 3/15/2010 21:02'! receivers ^ receivers ! ! !MessageTally methodsFor: 'accessing' stamp: 'Alexandre Bergel 3/4/2010 19:19'! reportOtherProcesses ^ reportOtherProcesses! ! !MessageTally methodsFor: 'accessing' stamp: 'jmv 9/24/2009 16:02'! reportOtherProcesses: aBoolean reportOtherProcesses := aBoolean! ! !MessageTally methodsFor: 'accessing' stamp: 'stp 05/08/1999 12:06'! tally "Answer the receiver's number of tally." ^tally! ! !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: 'accessing' stamp: 'stp 05/08/1999 11:47'! time "Answer the receiver's run time." ^time! ! !MessageTally methodsFor: 'collecting leaves'! bump: hitCount tally := tally + hitCount! ! !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: '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: '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'! < aMessageTally "Refer to the comment in Magnitude|<." ^tally > aMessageTally tally! ! !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: 'comparing'! > aMessageTally "Refer to the comment in Magnitude|>." ^tally < aMessageTally tally! ! !MessageTally methodsFor: 'comparing' stamp: 'jmv 8/20/2009 08:20'! hash "Hash is reimplemented because = is implemented." ^method hash! ! !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: '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: '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: 'initialize-release' stamp: 'MarcusDenker 8/21/2011 11:52'! 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 ifNotNil: [ gcStats at: idx put: (gcVal - (gcStats at: idx))]]. time := Time millisecondClockValue - time0]! ! !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: 'initialize-release' stamp: 'MarcusDenker 8/21/2011 11:52'! 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 ifNotNil: [ gcStats at: idx put: (gcVal - (gcStats at: idx)) ] ]. time := Time millisecondClockValue - time0! ! !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: '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' 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: '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: '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: 'printing' stamp: 'MarcusDenker 1/23/2011 09:13'! 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 isNil ifTrue: [ aStream nextPutAll: 'primitives'; cr] ifFalse: [ | 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: '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' 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: 'printing' stamp: 'nk 3/8/2004 12:23'! 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 format' stamp: 'nk 3/8/2004 12:29'! maxClassNameSize ^maxClassNameSize! ! !MessageTally methodsFor: 'printing format' stamp: 'nk 3/8/2004 12:30'! maxClassNameSize: aNumber maxClassNameSize := aNumber! ! !MessageTally methodsFor: 'printing format' stamp: 'nk 3/8/2004 12:29'! maxClassPlusSelectorSize ^maxClassPlusSelectorSize! ! !MessageTally methodsFor: 'printing format' stamp: 'nk 3/8/2004 12:30'! maxClassPlusSelectorSize: aNumber maxClassPlusSelectorSize := aNumber! ! !MessageTally methodsFor: 'printing format' stamp: 'nk 3/8/2004 12:29'! maxTabs ^maxTabs! ! !MessageTally methodsFor: 'printing format' stamp: 'nk 3/8/2004 12:30'! maxTabs: aNumber maxTabs := aNumber! ! !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: '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: '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: 'tallying'! bumpBy: count tally := tally + count! ! !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: '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: '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: '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: 'private'! class: aClass method: aMethod class := aClass. method := aMethod. tally := 0. receivers := Array new: 0! ! !MessageTally methodsFor: 'private' stamp: 'jmv 9/25/2009 08:48'! close Timer ifNotNil: [ Timer terminate ]. Timer := nil. class := method := tally := receivers := nil! ! !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: 'private'! primitives: anInteger tally := anInteger. receivers := nil! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MessageTally class instanceVariableNames: ''! !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: '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: '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: '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: '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: '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: '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: '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: '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! ! !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:20'! spyOn: aBlock cutoff: aNumber ^self spyOn: aBlock reportOtherProcesses: false cutoff: aNumber! ! !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: '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: '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: '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: 'Alexandre Bergel 3/16/2010 15:21'! spyOnProcess: aProcess forMilliseconds: msecDuration ^self spyOnProcess: aProcess forMilliseconds: msecDuration reportOtherProcesses: false ! ! !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: '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/4/2010 18:47'! tallySendsTo: receiver inBlock: aBlock showTree: treeOption ^ self tallySendsTo: receiver inBlock: aBlock showTree: treeOption closeAfter: true! ! !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: 'MarcusDenker 1/28/2011 15:50'! 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 isNil ifFalse: ["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'! time: aBlock ^ Time millisecondsToRun: aBlock! ! !MessageTally class methodsFor: 'private' stamp: 'jmv 2/19/2010 14:43'! terminateTimerProcess Timer ifNotNil: [ Timer terminate ]. Timer := nil! ! TestCase subclass: #MessageTallyTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolsTest-MessageTally'! !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)! ! !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: '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. ! ! Object subclass: #MetacelloAbstractConstructor instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Constructors'! !MetacelloAbstractConstructor methodsFor: 'accessing' stamp: 'DaleHenrichs 11/3/2010 11:41'! configurationClass ^self subclassResponsibility! ! !MetacelloAbstractConstructor methodsFor: 'pragma extraction' stamp: 'DaleHenrichs 11/3/2010 11:44'! extractAllVersionPragmas | aDict | aDict := Dictionary new. self extractPragmas: #version: into: aDict. self extractPragmas: #version:imports: into: aDict. ^aDict! ! !MetacelloAbstractConstructor methodsFor: 'pragma extraction' stamp: 'DaleHenrichs 11/8/2010 10:16'! extractCommonDefaultSymbolicVersionPragmas | aDict | aDict := Dictionary new. self extractPragmas: #defaultSymbolicVersion: for: MetacelloBaseConfiguration into: aDict. ^aDict! ! !MetacelloAbstractConstructor methodsFor: 'pragma extraction' stamp: 'DaleHenrichs 11/8/2010 09:58'! extractDefaultSymbolicVersionPragmas | aDict | aDict := Dictionary new. self extractPragmas: #defaultSymbolicVersion: into: aDict. ^aDict! ! !MetacelloAbstractConstructor methodsFor: 'pragma extraction' stamp: 'DaleHenrichs 11/3/2010 11:43'! extractSymbolicVersionPragmas | aDict | aDict := Dictionary new. self extractPragmas: #symbolicVersion: into: aDict. ^aDict! ! !MetacelloAbstractConstructor methodsFor: 'pragma extraction' stamp: 'DaleHenrichs 11/3/2010 11:43'! extractVersionImportPragmas | aDict | aDict := Dictionary new. self extractPragmas: #version:imports: into: aDict. ^aDict! ! !MetacelloAbstractConstructor methodsFor: 'pragma extraction' stamp: 'DaleHenrichs 11/3/2010 11:43'! extractVersionPragmas | aDict | aDict := Dictionary new. self extractPragmas: #version: into: aDict. ^aDict! ! !MetacelloAbstractConstructor methodsFor: 'private' stamp: 'DaleHenrichs 11/8/2010 10:02'! 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: 'private' stamp: 'DaleHenrichs 11/8/2010 10:02'! extractPragmas: pragmaKeyword into: versionDict ^self extractPragmas: pragmaKeyword for: self configurationClass into: versionDict ! ! MetacelloSpec subclass: #MetacelloAbstractPackageSpec instanceVariableNames: 'name requires includes answers' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Specs'! !MetacelloAbstractPackageSpec methodsFor: '*metacello-mc' stamp: 'DaleHenrichs 11/12/2010 06:31'! forceUpdatePackageSpec: updatedSpecs using: anMCLoader ^self updatePackageSpec: updatedSpecs using: anMCLoader! ! !MetacelloAbstractPackageSpec methodsFor: '*metacello-mc' stamp: 'DaleHenrichs 3/5/2010 09:46'! loadUsing: aLoader gofer: gofer ^self subclassResponsibility! ! !MetacelloAbstractPackageSpec methodsFor: '*metacello-mc' stamp: 'dkh 11/12/2009 16:57'! packageRepository ^nil! ! !MetacelloAbstractPackageSpec methodsFor: '*metacello-mc' stamp: 'dkh 12/22/2009 09:56'! packagesNeedSavingVisited: visitedProjects using: repos into: aCollection "noop by default" ! ! !MetacelloAbstractPackageSpec methodsFor: '*metacello-mc' stamp: 'dkh 08/03/2009 12:40'! repositorySpecs ^#()! ! !MetacelloAbstractPackageSpec methodsFor: '*metacello-mc' stamp: 'dkh 10/21/2009 15:50'! 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 10/21/2009 15:37'! resolveToAllPackagesIn: aVersionSpec visited: visited | packages | packages := Dictionary new. self resolveToAllPackagesIn: aVersionSpec into: packages visited: visited. ^packages values asOrderedCollection ! ! !MetacelloAbstractPackageSpec methodsFor: '*metacello-mc' stamp: 'dkh 10/6/2009 15:02'! resolveToLoadableSpec ^self! ! !MetacelloAbstractPackageSpec methodsFor: '*metacello-mc' stamp: 'dkh 10/21/2009 15:22'! resolveToPackagesIn: aVersionSpec visited: visited ^self subclassResponsibility! ! !MetacelloAbstractPackageSpec methodsFor: '*metacello-mc' stamp: 'DaleHenrichs 11/16/2010 16:31'! 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' stamp: 'dkh 08/03/2009 13:19'! updatePackageRepositoriesFor: aVersionSpec "noop by default" ^true ! ! !MetacelloAbstractPackageSpec methodsFor: '*metacello-mc' stamp: 'dkh 10/5/2009 16:16'! updatePackageSpec: updatedSpecs using: anMCLoader "Add pkg copy to updatedSpecs if the file in current image is different from the receiver's file" ! ! !MetacelloAbstractPackageSpec methodsFor: '*metacello-mc' stamp: 'dkh 10/21/2009 15:50'! visitingWithPackages: packages "noop"! ! !MetacelloAbstractPackageSpec methodsFor: '*metacello-mc-querying' stamp: 'dkh 8/18/2009 11:42'! file "MetacelloPackageSpec compatibility" ^nil! ! !MetacelloAbstractPackageSpec methodsFor: '*metacello-mc-querying' stamp: 'DaleHenrichs 01/20/2010 13:40'! isPackageLoaded ^false! ! !MetacelloAbstractPackageSpec methodsFor: '*metacello-mc-querying' stamp: 'dkh 6/23/2009 13:55'! repository ^nil! ! !MetacelloAbstractPackageSpec methodsFor: '*metacello-mc-querying' stamp: 'dkh 10/24/2009 10:43'! version "MetacelloPackageSpec compatibility" ^nil! ! !MetacelloAbstractPackageSpec methodsFor: 'accessing' stamp: 'dkh 1/4/2010 19:01'! answers: aListOfPairs self setAnswers: aListOfPairs! ! !MetacelloAbstractPackageSpec methodsFor: 'accessing' stamp: 'dkh 9/23/2009 08:45'! includes: aCollection aCollection setIncludesInMetacelloPackage: self! ! !MetacelloAbstractPackageSpec methodsFor: 'accessing' stamp: 'dkh 6/23/2009 11:24'! name: aString name := aString! ! !MetacelloAbstractPackageSpec methodsFor: 'accessing' stamp: 'dkh 10/24/2009 19:41'! referencedSpec ^self! ! !MetacelloAbstractPackageSpec methodsFor: 'accessing' stamp: 'dkh 6/23/2009 11:25'! requires: aCollection aCollection setRequiresInMetacelloPackage: self! ! !MetacelloAbstractPackageSpec methodsFor: 'adding' stamp: 'dkh 10/5/2009 12:07'! addToMetacelloPackages: aMetacelloPackagesSpec aMetacelloPackagesSpec addMember: (aMetacelloPackagesSpec addMember name: self name; spec: self; yourself)! ! !MetacelloAbstractPackageSpec methodsFor: 'copying' stamp: 'dkh 1/4/2010 18:55'! postCopy super postCopy. requires := requires copy. includes := includes copy. answers := answers copy. ! ! !MetacelloAbstractPackageSpec methodsFor: 'merging' stamp: 'dkh 6/23/2009 11:22'! mergeIntoMetacelloPackages: aMetacelloPackagesSpec aMetacelloPackagesSpec addMember: (aMetacelloPackagesSpec mergeMember name: self name; spec: self; yourself)! ! !MetacelloAbstractPackageSpec methodsFor: 'merging' stamp: 'DaleHenrichs 1/21/2010 20:36'! mergeMap | map | map := super mergeMap. map at: #requires put: requires. map at: #includes put: includes. map at: #answers put: answers. ^map! ! !MetacelloAbstractPackageSpec methodsFor: 'merging' stamp: 'DaleHenrichs 1/21/2010 20:21'! 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: 'merging' stamp: 'DaleHenrichs 1/21/2010 20:21'! nonOverridable ^#( includes requires answers )! ! !MetacelloAbstractPackageSpec methodsFor: 'printing' stamp: 'DaleHenrichs 1/14/2011 15:09'! 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: 'printing' stamp: 'dkh 10/5/2009 12:41'! configMethodCascadeOn: aStream member: aMember last: lastCascade indent: indent self subclassResponsibility ! ! !MetacelloAbstractPackageSpec methodsFor: 'printing' stamp: 'DaleHenrichs 12/21/2010 15:22'! 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: 'printing' stamp: 'DaleHenrichs 3/9/2010 16:33'! label ^self name! ! !MetacelloAbstractPackageSpec methodsFor: 'querying' stamp: 'dkh 1/4/2010 18:54'! answers answers == nil ifTrue: [ answers := #() ]. ^answers! ! !MetacelloAbstractPackageSpec methodsFor: 'querying' stamp: 'dkh 9/23/2009 08:45'! includes includes == nil ifTrue: [ includes := #() ]. ^includes! ! !MetacelloAbstractPackageSpec methodsFor: 'querying' stamp: 'dkh 6/23/2009 11:24'! name ^name! ! !MetacelloAbstractPackageSpec methodsFor: 'querying' stamp: 'dkh 6/23/2009 11:25'! requires requires == nil ifTrue: [ requires := #() ]. ^requires! ! !MetacelloAbstractPackageSpec methodsFor: 'removing' stamp: 'dkh 6/23/2009 11:24'! removeFromMetacelloPackages: aMetacelloPackagesSpec aMetacelloPackagesSpec addMember: (aMetacelloPackagesSpec removeMember name: self name; spec: self; yourself)! ! !MetacelloAbstractPackageSpec methodsFor: 'visiting' stamp: 'dkh 10/5/2009 09:38'! projectDo: projectBlock packageDo: packageBlock groupDo: groupBlock self subclassResponsibility! ! !MetacelloAbstractPackageSpec methodsFor: 'private' stamp: 'dkh 10/10/2009 10:59'! includesForPackageOrdering ^#()! ! !MetacelloAbstractPackageSpec methodsFor: 'private' stamp: 'dkh 1/4/2010 18:54'! setAnswers: aCollection answers := aCollection! ! !MetacelloAbstractPackageSpec methodsFor: 'private' stamp: 'dkh 9/23/2009 08:45'! setIncludes: aCollection includes := aCollection! ! !MetacelloAbstractPackageSpec methodsFor: 'private' stamp: 'dkh 6/23/2009 11:25'! setRequires: aCollection requires := aCollection! ! MetacelloAbstractConstructor subclass: #MetacelloAbstractVersionConstructor instanceVariableNames: 'root configuration project attributeMap attributeOrder symbolicVersion currentContext' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Constructors'! !MetacelloAbstractVersionConstructor methodsFor: '*metacello-mc-accessing' stamp: 'DaleHenrichs 10/27/2010 11:36'! project project == nil ifTrue: [ project := MetacelloMCProject new]. ^project! ! !MetacelloAbstractVersionConstructor methodsFor: 'accessing' stamp: 'DaleHenrichs 12/4/2010 09:56'! addAttribute: anAttribute self attributeOrder add: anAttribute! ! !MetacelloAbstractVersionConstructor methodsFor: 'accessing' stamp: 'dkh 10/3/2009 16:28'! attributeMap attributeMap == nil ifTrue: [ attributeMap := Dictionary new ]. ^attributeMap! ! !MetacelloAbstractVersionConstructor methodsFor: 'accessing' stamp: 'dkh 10/5/2009 16:41'! attributeOrder attributeOrder == nil ifTrue: [ attributeOrder := OrderedCollection new ]. ^attributeOrder! ! !MetacelloAbstractVersionConstructor methodsFor: 'accessing' stamp: 'dkh 10/3/2009 16:26'! configuration ^configuration! ! !MetacelloAbstractVersionConstructor methodsFor: 'accessing' stamp: 'dkh 10/3/2009 16:26'! configuration: aConfig configuration := aConfig! ! !MetacelloAbstractVersionConstructor methodsFor: 'accessing' stamp: 'DaleHenrichs 11/3/2010 11:41'! configurationClass ^self configuration class! ! !MetacelloAbstractVersionConstructor methodsFor: 'accessing' stamp: 'dkh 10/3/2009 16:36'! root ^root! ! !MetacelloAbstractVersionConstructor methodsFor: 'accessing' stamp: 'dkh 10/3/2009 16:37'! root: aMetacelloSpec root := aMetacelloSpec! ! !MetacelloAbstractVersionConstructor methodsFor: 'accessing' stamp: 'DaleHenrichs 03/12/2011 22:10'! setProject: aProject project := aProject! ! !MetacelloAbstractVersionConstructor methodsFor: 'accessing' stamp: 'DaleHenrichs 9/22/2010 16:43'! symbolicVersion ^symbolicVersion! ! !MetacelloAbstractVersionConstructor methodsFor: 'accessing' stamp: 'DaleHenrichs 9/22/2010 16:43'! symbolicVersion: aSymbol symbolicVersion := aSymbol! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! author: aBlockOrString aBlockOrString setAuthorInMetacelloConfig: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! blessing: aBlockOrString aBlockOrString setBlessingInMetacelloConfig: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! className: anObject self root className: anObject! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! description: aBlockOrString aBlockOrString setDescriptionInMetacelloConfig: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! file: anObject self root file: anObject! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'dkh 9/6/2012 07:41'! for: attributeListOrSymbol do: aBlock "conditional version support" attributeListOrSymbol setForDo: aBlock withInMetacelloConfig: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'dkh 9/6/2012 07:41'! for: attributeListOrSymbol version: aString "conditional symbolicVersion support" attributeListOrSymbol setForVersion: aString withInMetacelloConfig: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! group: aString overrides: aStringOrCollection | spec | spec := (self project groupSpec) name: aString; includes: aStringOrCollection; yourself. self root packages add: spec. ! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! group: 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'! includes: anObject self root includes: anObject! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! loads: anObject self root loads: anObject! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! name: anObject self root name: anObject! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! operator: anObject self root operator: anObject! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! package: aString | spec | spec := (self project packageSpec) name: aString; yourself. self root packages add: spec. ! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! package: 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'! package: aString with: aBlockOrString aBlockOrString setPackage: aString withInMetacelloConfig: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! postLoadDoIt: aSymbol self validateDoItSelector: aSymbol. self root postLoadDoIt: aSymbol! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! preLoadDoIt: aSymbol self validateDoItSelector: aSymbol. self root preLoadDoIt: aSymbol! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 03/12/2011 22:11'! project: aString self project: aString with: '' ! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! project: aString copyFrom: oldSpecName with: aBlock | spec projectSpec | projectSpec := (self project projectSpec) name: aString; projectPackage: self project packageSpec; 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' stamp: 'DaleHenrichs 11/12/2010 09:54'! project: aString overrides: aBlock | spec projectSpec | projectSpec := (self project projectSpec) name: aString; projectPackage: self project packageSpec; yourself. projectSpec projectPackage: self project packageSpec. 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'! project: aString with: aBlockOrString aBlockOrString setProject: aString withInMetacelloConfig: self ! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! projectPackage: aBlock | spec | (spec := self root projectPackage) == nil ifTrue: [ spec := self project packageSpec. self root projectPackage: spec ]. self with: spec during: aBlock! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! removeGroup: aString | spec | spec := (self project groupSpec) name: aString; yourself. self root packages remove: spec. ! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! removePackage: aString | spec | spec := (self project packageSpec) name: aString; yourself. self root packages remove: spec. ! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! removeProject: aString | spec | spec := (self project projectReferenceSpec) name: aString; yourself. self root packages remove: spec. ! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! repositories: aBlock self with: self root repositories during: aBlock! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! repository: anObject self root repository: 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! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! requires: anObject self root requires: anObject! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! supplyingAnswers: aCollection self root answers: aCollection! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! timestamp: aBlockOrString aBlockOrString setTimestampInMetacelloConfig: self! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! value: anObject self root value: anObject! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! version: anObject self root versionString: anObject! ! !MetacelloAbstractVersionConstructor methodsFor: 'api' stamp: 'DaleHenrichs 11/12/2010 09:54'! versionString: anObject self root versionString: anObject! ! !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: 'api callbacks' stamp: 'DaleHenrichs 11/12/2010 09:54'! setAuthorWithString: aString self root author: aString! ! !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 callbacks' stamp: 'DaleHenrichs 11/12/2010 09:54'! setBlessingWithString: aString self root blessing: 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 callbacks' stamp: 'DaleHenrichs 11/12/2010 09:54'! setDescriptionWithString: aString self root description: aString! ! !MetacelloAbstractVersionConstructor methodsFor: 'api callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! 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 callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! setFor: attributeList version: aString "conditional symbolicVersion support" attributeList asMetacelloAttributeList do: [ :attribute | self attributeMap at: attribute put: aString. self addAttribute: attribute ]! ! !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 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: 'api callbacks' stamp: 'DaleHenrichs 11/12/2010 09:54'! setProject: aString withBlock: aBlock | spec projectSpec | projectSpec := (self project projectSpec) name: aString; projectPackage: self project packageSpec; yourself. projectSpec projectPackage: self project packageSpec. spec := (self project projectReferenceSpec) name: aString; projectReference: projectSpec; yourself. self root packages merge: spec. self with: projectSpec during: aBlock! ! !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 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'! setTimestampWithString: aString self root timestamp: aString! ! !MetacelloAbstractVersionConstructor methodsFor: 'initialization' stamp: 'dkh 10/5/2009 16:42'! reset attributeMap := attributeOrder := nil ! ! !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: 'private' stamp: 'DaleHenrichs 11/12/2010 12:28'! evaluatePragma: pragma currentContext := pragma. [ self configuration perform: pragma selector with: self ] ensure: [ currentContext := nil ]! ! !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 class instanceVariableNames: ''! !MetacelloAbstractVersionConstructor class methodsFor: 'method generation' stamp: 'DaleHenrichs 11/13/2010 18:13'! symbolicMethodSelectorAndPragma: selector symbolicVersionSymbol: symbolicVersionSymbol on: strm strm nextPutAll: selector asString , ' spec'; cr; tab; nextPutAll: ''; cr! ! MetacelloMemberSpec subclass: #MetacelloAddMemberSpec instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Members'! !MetacelloAddMemberSpec methodsFor: 'accessing' stamp: 'dkh 10/9/2009 11:43'! methodUpdateSelector ^#overrides:! ! !MetacelloAddMemberSpec methodsFor: 'actions' stamp: 'dkh 10/4/2009 10:16'! applyAdd: addBlock copy: copyBlock merge: mergeBlock remove: removeBlock addBlock value: self! ! !MetacelloAddMemberSpec methodsFor: 'actions' stamp: 'dkh 06/02/2009 18:26'! applyToList: aListSpec aListSpec add: self! ! MetacelloVersionLoadDirective subclass: #MetacelloAtomicLoadDirective instanceVariableNames: 'packageloads preloads postloads' classVariableNames: '' poolDictionaries: '' category: 'Metacello-MC-Directives'! !MetacelloAtomicLoadDirective methodsFor: 'accessing' stamp: 'DaleHenrichs 3/9/2010 15:05'! packageloads packageloads == nil ifTrue: [ packageloads := OrderedCollection new ]. ^ packageloads! ! !MetacelloAtomicLoadDirective methodsFor: 'accessing' stamp: 'DaleHenrichs 3/9/2010 15:04'! packageloads: anObject packageloads := anObject! ! !MetacelloAtomicLoadDirective methodsFor: 'accessing' stamp: 'DaleHenrichs 4/9/2010 13:00'! postloads postloads == nil ifTrue: [ postloads := OrderedCollection new ]. ^ postloads! ! !MetacelloAtomicLoadDirective methodsFor: 'accessing' stamp: 'DaleHenrichs 4/9/2010 13:00'! preloads preloads == nil ifTrue: [ preloads := OrderedCollection new ]. ^ preloads! ! !MetacelloAtomicLoadDirective methodsFor: 'accessing' stamp: 'DaleHenrichs 3/9/2010 16:35'! title ^'atomic load'! ! !MetacelloAtomicLoadDirective methodsFor: 'actions' stamp: 'DaleHenrichs 4/14/2010 14:28'! 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: 'actions' stamp: 'DaleHenrichs 3/21/2010 16:20'! loadAtomicLoadDirective: aLoaderDirective gofer: aGofer aLoaderDirective loadDirectives do: [:directive | directive loadUsing: self gofer: aGofer ]. ! ! !MetacelloAtomicLoadDirective methodsFor: 'actions' stamp: 'DaleHenrichs 4/13/2010 17:27'! loadLinearLoadDirective: aLoaderDirective gofer: aGofer self finalizeLoad: aGofer. super loadLinearLoadDirective: aLoaderDirective gofer: aGofer! ! !MetacelloAtomicLoadDirective methodsFor: 'actions' stamp: 'DaleHenrichs 4/14/2010 14:21'! loadUsing: aLoaderDirective gofer: aGofer self loadDirectives isEmpty ifTrue: [ ^self ]. aLoaderDirective loadAtomicLoadDirective: self gofer: aGofer. ! ! !MetacelloAtomicLoadDirective methodsFor: 'enumerating' stamp: 'DaleHenrichs 4/9/2010 13:01'! 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: 'enumerating' stamp: 'DaleHenrichs 4/9/2010 13:03'! 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: 'enumerating' stamp: 'DaleHenrichs 4/9/2010 13:03'! prepostLoadsDo: aBlock self preloads do: [:directive | directive prepostLoadDo: aBlock ]. self loadDirectives do: [:directive | directive prepostLoadDo: aBlock ]. self postloads do: [:directive | directive prepostLoadDo: aBlock ]. ! ! !MetacelloAtomicLoadDirective methodsFor: 'loading' stamp: 'DaleHenrichs 3/16/2010 01:53'! loadPackageDirective: aPackageLoadDirective gofer: aGofer "accumulate packages" self packageloads add: aPackageLoadDirective! ! !MetacelloAtomicLoadDirective methodsFor: 'loading' stamp: 'DaleHenrichs 4/14/2010 14:23'! loadPostloadDirective: aPostloadDirective "accumulate postloads" self postloads add: aPostloadDirective! ! !MetacelloAtomicLoadDirective methodsFor: 'loading' stamp: 'DaleHenrichs 4/14/2010 14:23'! loadPreloadDirective: aPreloadDirective "accumulate preloads" self preloads add: aPreloadDirective! ! Object subclass: #MetacelloBaseConfiguration instanceVariableNames: 'project' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Base'! !MetacelloBaseConfiguration commentStamp: '' prior: 0! THIS IS AN EXPERIMENTAL CLASS. Use MetacelloConfigTemplate for creating configurations. Subclass me to create a new configuration, then edit and evaluate the following expression to create the initial baseline version: "create 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'. ! !MetacelloBaseConfiguration methodsFor: 'accessing' stamp: 'DaleHenrichs 11/2/2010 14:03'! 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 ]! ! !MetacelloBaseConfiguration methodsFor: 'accessing' stamp: 'DaleHenrichs 11/2/2010 14:27'! project: aProject project ifNil: [ self class ensureMetacello ]. project := aProject! ! !MetacelloBaseConfiguration methodsFor: 'defaults' stamp: 'DaleHenrichs 11/8/2010 10:42'! bleedingEdge "override if different behavior desired. Use: self versionDoesNotExistError: #bleedingEdge if #bleedingEdge version is disallowed." ^self defaultBleedingEdgeVersion! ! !MetacelloBaseConfiguration methodsFor: 'defaults' stamp: 'DaleHenrichs 1/7/2011 16:24'! defaultBleedingEdgeVersion | bleedingEdgeVersion | bleedingEdgeVersion := (self project map values select: [ :version | version blessing == #baseline ]) detectMax: [ :version | version ]. bleedingEdgeVersion ifNil: [ ^#'notDefined' ]. ^ bleedingEdgeVersion versionString! ! !MetacelloBaseConfiguration methodsFor: 'private' stamp: 'DaleHenrichs 11/4/2010 14:22'! versionDoesNotExistError: versionStringOrSymbol ((Smalltalk at: #MetacelloSymbolicVersionDoesNotExistError) project: self project versionString: versionStringOrSymbol) signal! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MetacelloBaseConfiguration class instanceVariableNames: ''! !MetacelloBaseConfiguration class methodsFor: 'accessing' stamp: 'DaleHenrichs 11/2/2010 14:03'! project ^self new project! ! !MetacelloBaseConfiguration class methodsFor: 'development support' stamp: 'DaleHenrichs 12/17/2010 10:20'! DevelopmentProcess "DEVELOPMENT Process - load current version: (self project version: #stable) load: 'ALL'. - open new version for development: self createNewDevelopmentVersion - do development and periodically save mcz files and configuration until ready for release self saveModifiedPackagesAndConfiguration: '- fixed a bug' - update the the development version to match mcz file versions self updateToLatestPackageVersions: '- fixed a bug' - save configuration self saveConfiguration: '- checkpoint configuration' RELEASE Process - mark development version as release: self releaseDevelopmentVersion: '- release' " ! ! !MetacelloBaseConfiguration class methodsFor: 'development support' stamp: 'DaleHenrichs 1/14/2011 11:51'! compareVersions "Compare the #stable version to #development version" "self compareVersions" self ensureMetacello. ((Smalltalk at: #MetacelloToolBox) compareVersionsIn: self) inspect ! ! !MetacelloBaseConfiguration class methodsFor: 'development support' stamp: 'DaleHenrichs 1/11/2011 15:00'! createNewBaselineVersion "Create a new baseline version based upon the #stable version's baseline. A new baseline should be created if new packages have been added or package dependencies have changed." "self createNewDevelopmentVersion" self ensureMetacello. (Smalltalk at: #MetacelloToolBox) createNewBaselineVersionIn: self description: '' ! ! !MetacelloBaseConfiguration class methodsFor: 'development support' stamp: 'DaleHenrichs 1/11/2011 15:00'! createNewDevelopmentVersion "Create a new development version using the #stable version as model." "self createNewDevelopmentVersion" self ensureMetacello. (Smalltalk at: #MetacelloToolBox) createNewDevelopmentVersionIn: self description: ''! ! !MetacelloBaseConfiguration class methodsFor: 'development support' stamp: 'DaleHenrichs 1/11/2011 15:06'! releaseDevelopmentVersion: commitMessage "Release #development version: set version blessing to #release, update the #development and #stable symbolic version methods and save the configuration." "self releaseDevelopmentVersion: '- release version 1.0.2'" self ensureMetacello. (Smalltalk at: #MetacelloToolBox) releaseDevelopmentVersionIn: self description: commitMessage! ! !MetacelloBaseConfiguration class methodsFor: 'development support' stamp: 'DaleHenrichs 1/11/2011 15:07'! saveConfiguration: commitMessage "Save mcz file that contains the configuration to it's repository." "self saveConfiguration: '- fixed bug'" self ensureMetacello. (Smalltalk at: #MetacelloToolBox) saveConfigurationPackageFor: self name asString description: commitMessage! ! !MetacelloBaseConfiguration class methodsFor: 'development support' stamp: 'DaleHenrichs 1/11/2011 15:10'! saveModifiedPackagesAndConfiguration: commitMessage "Save modified mcz files, update the #development version and then save the configuration." "self saveModifiedPackagesAndConfiguration: '- fixed bug'" self ensureMetacello. (Smalltalk at: #MetacelloToolBox) saveModifiedPackagesAndConfigurationIn: self description: commitMessage! ! !MetacelloBaseConfiguration class methodsFor: 'development support' stamp: 'DaleHenrichs 1/11/2011 15:11'! updateToLatestPackageVersions: descriptionString "Update the #development version to match currently loaded mcz files." "self updateToLatestPackageVersions: '- fixed a bug'" self ensureMetacello. ((Smalltalk at: #MetacelloToolBox) updateToLatestPackageVersionsIn: self description: descriptionString) isEmpty ifTrue: [ self inform: 'All specs up to date' ]! ! !MetacelloBaseConfiguration class methodsFor: 'development support' stamp: 'DaleHenrichs 12/6/2010 11: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! ! !MetacelloBaseConfiguration class methodsFor: 'loading' stamp: 'DaleHenrichs 11/29/2010 14:55'! 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! ! !MetacelloBaseConfiguration class methodsFor: 'loading' stamp: 'DaleHenrichs 11/29/2010 14:57'! 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! ! !MetacelloBaseConfiguration class methodsFor: 'loading' stamp: 'DaleHenrichs 11/29/2010 14:54'! 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! ! !MetacelloBaseConfiguration class methodsFor: 'metacello tool support' stamp: 'DaleHenrichs 11/2/2010 14:03'! isMetacelloConfig "Answer true and the Metacello tools will operate on you" ^true! ! !MetacelloBaseConfiguration class methodsFor: 'unloading Metacello' stamp: 'DaleHenrichs 11/29/2010 15:00'! 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.! ! !MetacelloBaseConfiguration class methodsFor: 'private' stamp: 'DaleHenrichs 11/2/2010 14:03'! 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]! ! !MetacelloBaseConfiguration class methodsFor: 'private' stamp: 'DaleHenrichs 11/2/2010 14:03'! 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 ]! ! GoferResolvedReference subclass: #MetacelloCachingGoferResolvedReference instanceVariableNames: 'cachedVersion' classVariableNames: '' poolDictionaries: '' category: 'Metacello-MC-Gofer'! !MetacelloCachingGoferResolvedReference methodsFor: 'accessing' stamp: 'DaleHenrichs 1/12/2010 20:40'! version "Answer a Monticello version of the receiver." cachedVersion == nil ifTrue: [ cachedVersion := super version ]. ^cachedVersion! ! !MetacelloCachingGoferResolvedReference methodsFor: 'querying' stamp: 'DaleHenrichs 01/15/2010 17:15'! 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' ]! ! Error subclass: #MetacelloCannotUpdateReleasedVersionError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Exceptions'! !MetacelloCannotUpdateReleasedVersionError methodsFor: 'private' stamp: 'DaleHenrichs 12/20/2010 11:52'! isResumable "Determine whether an exception is resumable." ^ true! ! MetacelloCleanNotification subclass: #MetacelloCleanLoadAndTestsNotification instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Exceptions'! MetacelloCleanNotification subclass: #MetacelloCleanLoadNotification instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Exceptions'! Notification subclass: #MetacelloCleanNotification instanceVariableNames: 'version' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Exceptions'! !MetacelloCleanNotification methodsFor: 'accessing' stamp: 'DaleHenrichs 11/21/2010 19:16'! version ^ version! ! !MetacelloCleanNotification methodsFor: 'accessing' stamp: 'DaleHenrichs 11/21/2010 19:16'! version: anObject version := anObject! ! !MetacelloCleanNotification methodsFor: 'signaling' stamp: 'DaleHenrichs 11/21/2010 19:16'! signal: aMetacelloVersion self version: aMetacelloVersion. ^ self signal! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MetacelloCleanNotification class instanceVariableNames: ''! !MetacelloCleanNotification class methodsFor: 'exceptioninstantiator' stamp: 'DaleHenrichs 11/21/2010 19:16'! signal: aMetacelloVersion ^ self new signal: aMetacelloVersion! ! Notification subclass: #MetacelloClearStackCacheNotification instanceVariableNames: 'cacheNames' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Exceptions'! !MetacelloClearStackCacheNotification methodsFor: 'accessing' stamp: 'dkh 4/6/2011 23:14'! cacheNames ^ cacheNames! ! !MetacelloClearStackCacheNotification methodsFor: 'accessing' stamp: 'dkh 4/6/2011 23:14'! cacheNames: anArray cacheNames := anArray! ! !MetacelloClearStackCacheNotification methodsFor: 'signaling' stamp: 'dkh 4/6/2011 23:15'! signal: anArray "Signal the occurrence of an exceptional condition with a specified cacheName." self cacheNames: anArray. ^ self signal! ! MetacelloSpecLoader subclass: #MetacelloCommonMCSpecLoader instanceVariableNames: 'operator loaderPolicy disablePackageCache' classVariableNames: '' poolDictionaries: '' category: 'Metacello-MC-Loaders'! !MetacelloCommonMCSpecLoader methodsFor: 'accessing' stamp: 'DaleHenrichs 3/10/2010 14:29'! fetchingSpecLoader ^self! ! !MetacelloCommonMCSpecLoader methodsFor: 'accessing' stamp: 'DaleHenrichs 4/12/2010 11:30'! ignoreImage ^self loaderPolicy ignoreImage! ! !MetacelloCommonMCSpecLoader methodsFor: 'accessing' stamp: 'DaleHenrichs 3/10/2010 14:35'! loaderPolicy loaderPolicy == nil ifTrue: [ loaderPolicy := MetacelloLoaderPolicy new ]. ^loaderPolicy! ! !MetacelloCommonMCSpecLoader methodsFor: 'accessing' stamp: 'DaleHenrichs 3/10/2010 14:35'! loaderPolicy: anObject loaderPolicy := anObject! ! !MetacelloCommonMCSpecLoader methodsFor: 'accessing' stamp: 'DaleHenrichs 3/6/2010 07:43'! loadingSpecLoader ^self! ! !MetacelloCommonMCSpecLoader methodsFor: 'accessing' stamp: 'dkh 08/10/2009 15:06'! operator operator == nil ifTrue: [ ^#= ]. ^operator! ! !MetacelloCommonMCSpecLoader methodsFor: 'accessing' stamp: 'dkh 08/10/2009 15:06'! operator: aSymbol operator := aSymbol! ! !MetacelloCommonMCSpecLoader methodsFor: 'accessing' stamp: 'DaleHenrichs 3/11/2010 16:37'! recordingSpecLoader ^(MetacelloNullRecordingMCSpecLoader on: self spec) shouldDisablePackageCache: self shouldDisablePackageCache; loaderPolicy: self loaderPolicy copy; yourself! ! !MetacelloCommonMCSpecLoader methodsFor: 'accessing' stamp: 'DaleHenrichs 3/10/2010 14:43'! repositoryMap ^self loaderPolicy repositoryMap! ! !MetacelloCommonMCSpecLoader methodsFor: 'accessing' stamp: 'DaleHenrichs 3/10/2010 14:34'! shouldDisablePackageCache disablePackageCache == nil ifTrue: [ disablePackageCache := false ]. ^ disablePackageCache! ! !MetacelloCommonMCSpecLoader methodsFor: 'accessing' stamp: 'DaleHenrichs 3/10/2010 14:34'! shouldDisablePackageCache: anObject disablePackageCache := anObject! ! !MetacelloCommonMCSpecLoader methodsFor: 'actions' stamp: 'DaleHenrichs 3/10/2010 15:16'! doLoad self subclassResponsibility! ! !MetacelloCommonMCSpecLoader methodsFor: 'actions' stamp: 'TestRunner 10/23/2009 11:33'! doingLoads: aBlock "escape mechanism for recording and null loaders to skip doing loaderlike things" aBlock value! ! !MetacelloCommonMCSpecLoader methodsFor: 'actions' stamp: 'DaleHenrichs 4/9/2010 12:17'! linearLoadPackageSpec: packageSpec gofer: gofer self subclassResponsibility! ! !MetacelloCommonMCSpecLoader methodsFor: 'actions' stamp: 'DaleHenrichs 3/10/2010 14:33'! 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: 'actions' stamp: 'dkh 4/6/2011 22:32'! 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: MetacelloGofer new. 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: 'DaleHenrichs 4/9/2010 12:12'! 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: 'doits' stamp: 'DaleHenrichs 03/12/2010 16:43'! postLoad: packageOrVersionSpec "subclassResponsibility, but it gets called during an upgrade, so leave it as NOOP"! ! !MetacelloCommonMCSpecLoader methodsFor: 'doits' stamp: 'DaleHenrichs 3/10/2010 14:32'! preLoad: packageOrVersionSpec self subclassResponsibility! ! !MetacelloCommonMCSpecLoader methodsFor: 'initialize-release' stamp: 'DaleHenrichs 3/10/2010 14:41'! initialize self loaderPolicy! ! !MetacelloCommonMCSpecLoader methodsFor: 'packages' stamp: 'dkh 07/22/2009 14:50'! nameComponentsFrom: aVersionName ^self class nameComponentsFrom: aVersionName! ! !MetacelloCommonMCSpecLoader methodsFor: 'repositories' stamp: 'DaleHenrichs 3/10/2010 14:42'! repositoriesFrom: aMetacelloMVRepositorySpecs ^self repositoriesFrom: aMetacelloMVRepositorySpecs ignoreOverrides: false! ! !MetacelloCommonMCSpecLoader methodsFor: 'repositories' stamp: 'DaleHenrichs 3/10/2010 14:42'! 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: 'testing' stamp: 'DaleHenrichs 3/11/2010 20:48'! ensureForDevelopment ^true! ! !MetacelloCommonMCSpecLoader methodsFor: 'testing' stamp: 'DaleHenrichs 3/10/2010 14:40'! hasRepositoryOverrides ^self loaderPolicy hasRepositoryOverrides! ! !MetacelloCommonMCSpecLoader methodsFor: 'versionInfo' stamp: 'dkh 3/20/2011 17:46'! 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: 'versionInfo' stamp: 'DaleHenrichs 9/24/2010 14:47'! 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 4/6/2011 22:33'! linearLoadPackageSpecs: packageSpecs repositories: repositories | gofer | gofer := MetacelloGofer new. repositories do: [:repo | gofer repository: repo ]. packageSpecs do: [:pkg | pkg loadUsing: self gofer: gofer ]. ! ! !MetacelloCommonMCSpecLoader methodsFor: 'private' stamp: 'dkh 3/20/2011 17:49'! 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: 'private' stamp: 'dkh 4/6/2011 22:32'! 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: 'private' stamp: 'dkh 4/26/2011 15:45'! 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 | 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: [ | repositoryString | repositoryString := ''. gofer repositories do: [:repo | repositoryString := repositoryString, ' ', repo description ]. Transcript cr; show: '...FAILED->', packageSpec file. self error: 'Could not resolve: ', packageSpec name, ' [', packageSpec file, ']', ' in', 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 ]) ]. ^references! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MetacelloCommonMCSpecLoader class instanceVariableNames: ''! !MetacelloCommonMCSpecLoader class methodsFor: 'utilities' stamp: 'dkh 9/10/2009 17:23'! 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! ! Object subclass: #MetacelloConfigTemplate instanceVariableNames: 'project' classVariableNames: 'LastVersionLoad' poolDictionaries: '' category: 'Metacello-MC-Model'! !MetacelloConfigTemplate commentStamp: '' prior: 0! 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: 'SeanDeNigris 7/12/2012 09:41'! project ^ project ifNil: [ | constructor | "Bootstrap Metacello if it is not already loaded" (self class baseConfigurationClassIfAbsent: []) ensureMetacello. "Construct Metacello project" project := MetacelloMCProject new projectAttributes: self customProjectAttributes. constructor := (Smalltalk at: #MetacelloVersionConstructor) on: self project: project. project loadType: #linear. "change to #atomic if desired" project ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MetacelloConfigTemplate class instanceVariableNames: ''! !MetacelloConfigTemplate class methodsFor: 'accessing' stamp: 'dkh 10/13/2009 10:36'! project ^self new project! ! !MetacelloConfigTemplate class methodsFor: 'development support' stamp: 'DaleHenrichs 12/17/2010 10:23'! 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: 'development support' stamp: 'DaleHenrichs 1/13/2011 15:37'! 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: 'loading' stamp: 'DaleHenrichs 11/29/2010 15:00'! 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: 'loading' stamp: 'DaleHenrichs 11/29/2010 15:00'! 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: 'loading' stamp: 'DaleHenrichs 11/29/2010 15:00'! 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! ! !MetacelloConfigTemplate class methodsFor: 'metacello tool support' stamp: 'DaleHenrichs 11/2/2010 14:58'! isMetacelloConfig "Answer true and the Metacello tools will operate on you" ^true! ! !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: 'private' stamp: 'DaleHenrichs 12/6/2010 13:34'! ensureMetacello (self baseConfigurationClassIfAbsent: []) ensureMetacello! ! !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 ] ]! ! Object subclass: #MetacelloConfigurationBrowser instanceVariableNames: 'window selectedConfiguration trustedTree untrustedTree selectedRepository' classVariableNames: '' poolDictionaries: '' category: 'Tools-ConfigurationBrowser'! !MetacelloConfigurationBrowser commentStamp: 'StephaneDucasse 8/10/2010 21:09' prior: 0! A MetacelloConfigurationBrowser is simple tool to browse Metacello configurations published at http://www.squeaksource.com/MetaRepoForPharoXX where XX denotes different pharo versions. MetaRepoForPharo1.0 acts as a distribution of all the packages/projects that can be loaded in Pharo1.0. We are sorry for the name but the source limits the length of the project name: The full name is MetacelloRepositoriesForPharoXX. Metacello is a configuration language for packages. It allows one to define dependencies between packages as well as between complete projects. ! !MetacelloConfigurationBrowser methodsFor: 'actions' stamp: 'EstebanLorenzano 6/20/2012 11:06'! loadSelectedConfiguration self loadConfigurationWithStable: false! ! !MetacelloConfigurationBrowser methodsFor: 'actions' stamp: 'tbn 4/2/2012 19:10'! loadStableFromSelectedConfiguration self loadConfigurationWithStable: true! ! !MetacelloConfigurationBrowser methodsFor: 'actions' stamp: 'tbn 8/4/2010 11:06'! open self refresh. window openInWorld! ! !MetacelloConfigurationBrowser methodsFor: 'actions' stamp: 'EstebanLorenzano 6/20/2012 11:03'! refresh |repo reductionMap split configName author version last topMostItems item | "Set as list contents" trustedTree list: (self retrieveConfigurationMorphsFrom: self pharoDistribution). untrustedTree list: (self retrieveConfigurationMorphsFrom: self untrustedDistribution). window title: self pharoDistribution.! ! !MetacelloConfigurationBrowser methodsFor: 'defaults' stamp: 'tbn 7/5/2012 09:22'! pharoDistribution "Returns the correct pharo distribution url" ^'http://ss3.gemstone.com/ss/MetaRepoForPharo', SystemVersion current major asString, SystemVersion current minor asString! ! !MetacelloConfigurationBrowser methodsFor: 'defaults' stamp: 'EstebanLorenzano 6/20/2012 11:06'! untrustedDistribution "Returns the untrusted pharo distribution url" ^'http://www.squeaksource.com/MetacelloRepository'. ! ! !MetacelloConfigurationBrowser methodsFor: 'events' stamp: 'EstebanLorenzano 6/20/2012 11:21'! onTrustedSelected: aString selectedRepository := self pharoDistribution. selectedConfiguration := aString! ! !MetacelloConfigurationBrowser methodsFor: 'events' stamp: 'EstebanLorenzano 6/20/2012 11:21'! onUntrustedSelected: aString selectedRepository := self untrustedDistribution. selectedConfiguration := aString! ! !MetacelloConfigurationBrowser methodsFor: 'initialize' stamp: 'EstebanLorenzano 6/20/2012 11:01'! initialize "Initializes the receiver" super initialize. self initializeWindow! ! !MetacelloConfigurationBrowser methodsFor: 'initialize' stamp: 'tbn 2/28/2013 08:08'! initializeWindow "Create the window" | leftPanel tabs | window := StandardWindow new. window title: 'Browser on ', self pharoDistribution. leftPanel := PanelMorph new changeTableLayout. tabs := TabGroupMorph new hResizing: #spaceFill; vResizing: #spaceFill. leftPanel addMorph: tabs. window addMorph: leftPanel fullFrame: LayoutFrame identity. trustedTree := PluggableTreeMorph new. tabs addPage: trustedTree label: 'Verified'. trustedTree model: self; setSelectedSelector: #onTrustedSelected:; getMenuSelector: #configurationMenu:. window addMorph: trustedTree fullFrame: (0@0 corner: 0@1) asLayoutFrame. tabs selectedPageIndex: 1. untrustedTree := PluggableTreeMorph new. tabs addPage: untrustedTree label: 'Unverified'. untrustedTree model: self; setSelectedSelector: #onUntrustedSelected:; getMenuSelector: #configurationMenu:. window addMorph: untrustedTree fullFrame: (0@0 corner: 0@1) asLayoutFrame. tabs selectedPageIndex: 1. ! ! !MetacelloConfigurationBrowser methodsFor: 'menu' stamp: 'MarcusDenker 10/7/2012 11:19'! configurationMenu: aMenu selectedConfiguration ifNil: [^aMenu add: 'Refresh' action: #refresh]. ^aMenu addList: #( ('Install configuration (Stable version)' loadStableFromSelectedConfiguration) ('Load configuration (Do not install)' loadSelectedConfiguration) - ('Refresh' refresh))! ! !MetacelloConfigurationBrowser methodsFor: 'private' stamp: 'EstebanLorenzano 6/20/2012 11:22'! loadConfigurationWithStable: loadStable "Load the configuration and (depending on the flag) load the latest stable version" | configName | configName := selectedConfiguration readStream upTo: $-. Gofer new url: selectedRepository; package: configName; load. loadStable ifFalse: [^self]. "Now load the latest stable version" (Smalltalk at: (configName) asSymbol) project stableVersion load.! ! !MetacelloConfigurationBrowser methodsFor: 'private' stamp: 'SeanDeNigris 8/26/2012 11:35'! retrieveConfigurationMorphsFrom: locationString | repo reductionMap split configName author version last topMostItems item | 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: ((PluggableListItemWrapper with: (key, '-', val key, '.', val value asString)) string: (key allButFirst: 15), ' (', val key, '.', val value asString, ')'; yourself)]. ^topMostItems! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MetacelloConfigurationBrowser class instanceVariableNames: ''! !MetacelloConfigurationBrowser class methodsFor: 'instance creation' stamp: 'tbn 8/4/2010 10:56'! open ^(self new) open; yourself ! ! !MetacelloConfigurationBrowser class methodsFor: 'registration' stamp: 'FernandoOlivero 4/12/2011 10:01'! menuCommandOn: aBuilder (aBuilder item: 'Configuration Browser') parent: #Tools; order: 0.5; action: [self open]; icon: self theme smallLoadProjectIcon! ! !MetacelloConfigurationBrowser class methodsFor: 'registration' stamp: 'FernandoOlivero 4/12/2011 10:01'! theme ^ UITheme current ! ! MetacelloMemberSpec subclass: #MetacelloCopyMemberSpec instanceVariableNames: 'sourceName' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Members'! !MetacelloCopyMemberSpec methodsFor: 'accessing' stamp: 'dkh 10/4/2009 10:19'! methodUpdateSelector ^#copy:! ! !MetacelloCopyMemberSpec methodsFor: 'accessing' stamp: 'dkh 10/4/2009 10:35'! sourceName ^sourceName! ! !MetacelloCopyMemberSpec methodsFor: 'accessing' stamp: 'dkh 10/4/2009 10:36'! sourceName: aString sourceName := aString! ! !MetacelloCopyMemberSpec methodsFor: 'actions' stamp: 'dkh 10/4/2009 10:18'! applyAdd: addBlock copy: copyBlock merge: mergeBlock remove: removeBlock copyBlock value: self ! ! !MetacelloCopyMemberSpec methodsFor: 'actions' stamp: 'dkh 10/4/2009 10:19'! applyToList: aListSpec aListSpec copy: self! ! Object subclass: #MetacelloDirective instanceVariableNames: 'spec loader' classVariableNames: '' poolDictionaries: '' category: 'Metacello-MC-Directives'! !MetacelloDirective methodsFor: 'accessing' stamp: 'DaleHenrichs 3/9/2010 10:44'! loader ^loader! ! !MetacelloDirective methodsFor: 'accessing' stamp: 'DaleHenrichs 3/9/2010 12:19'! loader: aLoader loader := aLoader! ! !MetacelloDirective methodsFor: 'accessing' stamp: 'DaleHenrichs 3/10/2010 11:06'! spec ^spec! ! !MetacelloDirective methodsFor: 'accessing' stamp: 'DaleHenrichs 3/9/2010 16:35'! title self subclassResponsibility! ! !MetacelloDirective methodsFor: 'actions' stamp: 'DaleHenrichs 3/9/2010 12:11'! addTo: aLoaderDirective aLoaderDirective add: self! ! !MetacelloDirective methodsFor: 'actions' stamp: 'DaleHenrichs 3/9/2010 14:53'! loadUsing: aLoaderDirective gofer: aGofer self subclassResponsibility! ! !MetacelloDirective methodsFor: 'actions' stamp: 'DaleHenrichs 3/11/2010 13:49'! packageDo: aBlock ! ! !MetacelloDirective methodsFor: 'actions' stamp: 'DaleHenrichs 4/8/2010 16:31'! postLoadDo: aBlock ! ! !MetacelloDirective methodsFor: 'actions' stamp: 'DaleHenrichs 4/8/2010 16:31'! preLoadDo: aBlock! ! !MetacelloDirective methodsFor: 'actions' stamp: 'DaleHenrichs 4/7/2010 12:32'! versionDo: aBlock ! ! !MetacelloDirective methodsFor: 'enumerating' stamp: 'DaleHenrichs 3/10/2010 15:48'! directivesDo: aBlock aBlock value: self! ! !MetacelloDirective methodsFor: 'enumerating' stamp: 'DaleHenrichs 3/11/2010 13:40'! packageDirectivesDo: aBlock ! ! !MetacelloDirective methodsFor: 'enumerating' stamp: 'DaleHenrichs 4/7/2010 12:25'! prepostLoadDirectivesDo: aBlock ! ! !MetacelloDirective methodsFor: 'enumerating' stamp: 'DaleHenrichs 4/7/2010 12:26'! prepostLoadDo: aBlock ! ! !MetacelloDirective methodsFor: 'enumerating' stamp: 'DaleHenrichs 12/7/2010 02:21'! versionDirectivesDepthFirstDo: aBlock ! ! !MetacelloDirective methodsFor: 'enumerating' stamp: 'DaleHenrichs 3/12/2010 10:27'! versionDirectivesDo: aBlock ! ! !MetacelloDirective methodsFor: 'initialize-release' stamp: 'DaleHenrichs 3/9/2010 10:46'! spec: packageOrVersionSpec loader: aLoader spec := packageOrVersionSpec. loader := aLoader! ! !MetacelloDirective methodsFor: 'printing' stamp: 'DaleHenrichs 3/9/2010 16:36'! label ^self spec label! ! !MetacelloDirective methodsFor: 'printing' stamp: 'DaleHenrichs 3/9/2010 11:53'! printOn: aStream self printOn: aStream indent: 0! ! !MetacelloDirective methodsFor: 'printing' stamp: 'DaleHenrichs 3/9/2010 16:35'! printOn: aStream indent: indent indent timesRepeat: [ aStream tab ]. aStream nextPutAll: self title; nextPutAll: ' : '; nextPutAll: self label. ! ! !MetacelloDirective methodsFor: 'printing' stamp: 'DaleHenrichs 12/6/2010 23:00'! 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 class instanceVariableNames: ''! !MetacelloDirective class methodsFor: 'instance creation' stamp: 'DaleHenrichs 3/9/2010 16:42'! loadPackage: aPackageSpec externalReference: externalReference loader: aLoader ^MetacelloPackageLoadDirective new spec: aPackageSpec externalReference: externalReference loader: aLoader ! ! !MetacelloDirective class methodsFor: 'instance creation' stamp: 'DaleHenrichs 3/9/2010 12:19'! loader: aLoader ^self new loader: aLoader! ! !MetacelloDirective class methodsFor: 'instance creation' stamp: 'DaleHenrichs 3/9/2010 10:48'! postLoadSpec: packageOrVersionSpec loader: aLoader ^MetacelloPostLoadDirective new spec: packageOrVersionSpec loader: aLoader! ! !MetacelloDirective class methodsFor: 'instance creation' stamp: 'DaleHenrichs 3/9/2010 10:48'! preLoadSpec: packageOrVersionSpec loader: aLoader ^MetacelloPreLoadDirective new spec: packageOrVersionSpec loader: aLoader! ! MetacelloVersionLoadDirective subclass: #MetacelloExplicitLoadDirective instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Metacello-MC-Directives'! !MetacelloExplicitLoadDirective methodsFor: 'accessing' stamp: 'DaleHenrichs 3/18/2010 11:46'! title ^'explicit load'! ! !MetacelloExplicitLoadDirective methodsFor: 'actions' stamp: 'DaleHenrichs 3/21/2010 13:39'! explicitLoadUsing: aLoaderDirective gofer: aGofer aLoaderDirective loadLinearLoadDirective: self gofer: aGofer. ! ! !MetacelloExplicitLoadDirective methodsFor: 'actions' stamp: 'dkh 4/6/2011 22:34'! explicitLoadWithPolicy: aLoadPolicy | gofer | gofer := MetacelloGofer new. gofer disablePackageCache. gofer repository: aLoadPolicy cacheRepository. self explicitLoadUsing: self gofer: gofer! ! !MetacelloExplicitLoadDirective methodsFor: 'actions' stamp: 'DaleHenrichs 3/21/2010 13:38'! loadUsing: aLoaderDirective gofer: aGofer aLoaderDirective loadExplicitLoadDirective: self gofer: aGofer. ! ! !MetacelloExplicitLoadDirective methodsFor: 'testing' stamp: 'DaleHenrichs 12/7/2010 02:25'! isExplicit ^true! ! MetacelloCommonMCSpecLoader subclass: #MetacelloFetchingMCSpecLoader instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Metacello-MC-Loaders'! !MetacelloFetchingMCSpecLoader methodsFor: 'accessing' stamp: 'DaleHenrichs 3/11/2010 16:33'! actionLabel ^'Fetching '! ! !MetacelloFetchingMCSpecLoader methodsFor: 'accessing' stamp: 'DaleHenrichs 3/10/2010 14:39'! cacheRepository ^self loaderPolicy cacheRepository! ! !MetacelloFetchingMCSpecLoader methodsFor: 'accessing' stamp: 'DaleHenrichs 3/10/2010 14:40'! ensuredMap ^self loaderPolicy ensuredMap! ! !MetacelloFetchingMCSpecLoader methodsFor: 'accessing' stamp: 'DaleHenrichs 3/10/2010 11:58'! loadData ^self loaderPolicy loadData! ! !MetacelloFetchingMCSpecLoader methodsFor: 'accessing' stamp: 'DaleHenrichs 3/10/2010 14:36'! loadDirective ^self loaderPolicy loadDirective! ! !MetacelloFetchingMCSpecLoader methodsFor: 'accessing' stamp: 'DaleHenrichs 3/10/2010 10:25'! loadingSpecLoader ^(MetacelloLoadingMCSpecLoader on: self spec) shouldDisablePackageCache: self shouldDisablePackageCache; loaderPolicy: self loaderPolicy copy; yourself! ! !MetacelloFetchingMCSpecLoader methodsFor: 'actions' stamp: 'DaleHenrichs 3/10/2010 16:42'! doLoad self loaderPolicy copy load! ! !MetacelloFetchingMCSpecLoader methodsFor: 'actions' stamp: 'dkh 4/6/2011 23:48'! linearLoadPackageSpec: packageSpec gofer: gofer MetacelloPlatform current do: [ | references nearestReference cachedReference externalReference mcVersion loadedVersionInfos | "check to see if mcz file is already in cacheRepository" self flag: #cleanup. "validate the comment" "packageSpec name = 'OmniBrowser' ifTrue: [self halt: packageSpec file ]." cachedReference := self resolvePackageSpec: packageSpec cachedGofer: self loaderPolicy cacheGofer. (cachedReference ~~ nil and: [ packageSpec getFile ~~ nil ]) ifTrue: [ cachedReference name = packageSpec file ifTrue: [ ^self ]]. "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: [ ^self ]. "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 info ]. self loadData addVersion: mcVersion versionInfo: mcVersion info resolvedReference: reference packageSpec: pSpec ]]. self loaderPolicy resetCacheGofer. self preLoad: packageSpec. (MetacelloDirective loadPackage: packageSpec externalReference: externalReference loader: self) addTo: self loadDirective. self postLoad: packageSpec. Transcript cr; show: 'Fetched -> ', externalReference name, ' --- ', externalReference repository description, ' --- ', nearestReference repository description ] displaying: 'Fetching ', packageSpec file! ! !MetacelloFetchingMCSpecLoader methodsFor: 'doits' stamp: 'DaleHenrichs 3/11/2010 13:43'! postLoad: packageOrVersionSpec (MetacelloDirective postLoadSpec: packageOrVersionSpec loader: self) addTo: self loadDirective ! ! !MetacelloFetchingMCSpecLoader methodsFor: 'doits' stamp: 'DaleHenrichs 3/11/2010 13:43'! preLoad: packageOrVersionSpec (MetacelloDirective preLoadSpec: packageOrVersionSpec loader: self) addTo: self loadDirective ! ! !MetacelloFetchingMCSpecLoader methodsFor: 'printing' stamp: 'DaleHenrichs 5/17/2010 16:42'! printOn: aStream super printOn: aStream. aStream nextPut: $(. self loadDirective printOn: aStream. aStream nextPut: $)! ! !MetacelloFetchingMCSpecLoader methodsFor: 'versionInfo' stamp: 'dkh 3/20/2011 17:51'! ancestorsFor: packageSpec ^self loadData ancestorsFor: packageSpec ifAbsent: [ super ancestorsFor: packageSpec ]! ! !MetacelloFetchingMCSpecLoader methodsFor: 'versionInfo' stamp: 'DaleHenrichs 3/10/2010 11:59'! currentVersionInfoFor: packageSpec ^self loadData currentVersionInfoFor: packageSpec ifAbsent: [ super currentVersionInfoFor: packageSpec ]! ! !MetacelloFetchingMCSpecLoader methodsFor: 'private' stamp: 'DaleHenrichs 3/9/2010 12:23'! atomicLoadPackageSpecs: packageSpecs repositories: repositories self loaderPolicy pushAtomicLoadDirectivesDuring: [ super linearLoadPackageSpecs: packageSpecs repositories: repositories ] for: self ! ! !MetacelloFetchingMCSpecLoader methodsFor: 'private' stamp: 'DaleHenrichs 3/21/2010 13:21'! explicitLoadPackageSpecs: packageSpecs repositories: repositories | directive | directive := self loaderPolicy pushExplicitLoadDirectivesDuring: [ super linearLoadPackageSpecs: packageSpecs repositories: repositories ] for: self. directive explicitLoadWithPolicy: self loaderPolicy.! ! !MetacelloFetchingMCSpecLoader methodsFor: 'private' stamp: 'DaleHenrichs 3/9/2010 12:39'! linearLoadPackageSpecs: packageSpecs repositories: repositories self loaderPolicy pushLinearLoadDirectivesDuring: [ super linearLoadPackageSpecs: packageSpecs repositories: repositories ] for: self! ! !MetacelloFetchingMCSpecLoader methodsFor: 'private' stamp: 'dkh 4/10/2011 18:03'! 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: 'private' stamp: 'DaleHenrichs 3/4/2010 19:29'! resolvePackageSpec: packageSpec cachedGofer: gofer | versionReference references | versionReference := packageSpec goferLoaderReference. (references := versionReference resolveAllWith: gofer) isEmpty ifTrue: [ ^nil ]. ^references last asMetacelloCachingResolvedReference. ! ! Gofer subclass: #MetacelloGofer instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Metacello-MC-Gofer'! !MetacelloGofer methodsFor: 'operations' stamp: 'dkh 4/17/2011 14:42'! interactiveCommit ^ self execute: MetacelloGoferCommit! ! !MetacelloGofer methodsFor: 'private' stamp: 'dkh 4/7/2011 18:40'! 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) ]! ! GoferCommit subclass: #MetacelloGoferCommit instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Metacello-MC-Gofer'! !MetacelloGoferCommit methodsFor: 'running' stamp: 'dkh 4/17/2011 14:42'! execute: aWorkingCopy | version | version := aWorkingCopy newVersion. self gofer repositories do: [ :repository | repository storeVersion: version ]! ! GoferLoad subclass: #MetacelloGoferLoad instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Metacello-MC-Gofer'! !MetacelloGoferLoad methodsFor: 'private' stamp: 'DaleHenrichs 12/18/2010 13:39'! updateCategories MetacelloPlatform current bypassGoferLoadUpdateCategories ifFalse: [ super updateCategories ]! ! !MetacelloGoferLoad methodsFor: 'private' stamp: 'DaleHenrichs 3/5/2010 10:48'! updateRepositories "Noop for Metacello...done by loader itself" ! ! GoferPackageReference subclass: #MetacelloGoferPackage instanceVariableNames: 'packageFilename version workingCopy' classVariableNames: '' poolDictionaries: '' category: 'Metacello-MC-Gofer'! !MetacelloGoferPackage methodsFor: 'accessing' stamp: 'dkh 10/12/2009 16:25'! packageFilename ^packageFilename! ! !MetacelloGoferPackage methodsFor: 'accessing' stamp: 'dkh 10/15/2009 10:00'! workingCopy workingCopy == nil ifTrue: [ workingCopy := self findWorkingCopy ]. ^workingCopy! ! !MetacelloGoferPackage methodsFor: 'initialization' stamp: 'dkh 12/15/2009 10:31'! initializeName: aString packageFilename: packagefilename name := aString. packageFilename := packagefilename! ! !MetacelloGoferPackage methodsFor: 'querying' stamp: 'dkh 3/20/2011 17:45'! ancestors | wc | (wc := self workingCopy) ~~ nil ifTrue: [ wc ancestry ancestors isEmpty not ifTrue: [ ^wc ancestry ancestors ]]. ^nil! ! !MetacelloGoferPackage methodsFor: 'querying' stamp: 'dkh 9/25/2009 11:26'! currentVersionInfo | wc | (wc := self workingCopy) ~~ nil ifTrue: [ wc ancestry ancestors isEmpty not ifTrue: [ ^wc ancestry ancestors first ]]. ^nil! ! !MetacelloGoferPackage methodsFor: 'private' stamp: 'dkh 10/15/2009 10:48'! 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: 'private' stamp: 'DaleHenrichs 3/19/2010 10:04'! matches: aLoadableReference "does Monticello-style #versionInfoFromVersionNamed: matching" | pFilename | (((pFilename := self packageFilename) == nil) or: [ self name = self packageFilename] ) ifTrue: [ ^super matches: aLoadableReference ]. ^aLoadableReference name beginsWith: pFilename ! ! !MetacelloGoferPackage methodsFor: 'private' stamp: 'DaleHenrichs 12/21/2010 10:39'! 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 class instanceVariableNames: ''! !MetacelloGoferPackage class methodsFor: 'instance creation' stamp: 'dkh 12/15/2009 10:32'! name: aString packageFilename: packageFilename ^ self basicNew initializeName: aString packageFilename: packageFilename! ! !MetacelloGoferPackage class methodsFor: 'package name matching' stamp: 'DaleHenrichs 3/18/2010 16:54'! 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) = $. ] ! ! MetacelloAbstractPackageSpec subclass: #MetacelloGroupSpec instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Specs'! !MetacelloGroupSpec methodsFor: '*metacello-mc' stamp: 'DaleHenrichs 3/5/2010 09:46'! loadUsing: aLoader gofer: gofer "noop"! ! !MetacelloGroupSpec methodsFor: '*metacello-mc' stamp: 'DaleHenrichs 1/19/2010 12:14'! resolveToLoadableSpec ^nil! ! !MetacelloGroupSpec methodsFor: '*metacello-mc' stamp: 'DaleHenrichs 1/21/2010 15:54'! 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 ]]]! ! !MetacelloGroupSpec methodsFor: '*metacello-mc' stamp: 'dkh 10/21/2009 15:23'! resolveToPackagesIn: aVersionSpec visited: visited | packages | packages := Dictionary new. self resolveToPackagesIn: aVersionSpec into: packages visited: visited. ^packages values asOrderedCollection ! ! !MetacelloGroupSpec methodsFor: 'accessing' stamp: 'dkh 1/4/2010 19:02'! answers: aListOfPairs self shouldNotImplement! ! !MetacelloGroupSpec methodsFor: 'accessing' stamp: 'dkh 10/4/2009 09:41'! requires: aCollection self shouldNotImplement! ! !MetacelloGroupSpec methodsFor: 'printing' stamp: 'dkh 10/24/2009 15:09'! 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: 'printing' stamp: 'dkh 1/6/2010 18:39'! 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: 'visiting' stamp: 'dkh 10/5/2009 09:39'! projectDo: projectBlock packageDo: packageBlock groupDo: groupBlock groupBlock value: self! ! MetacelloVersionLoadDirective subclass: #MetacelloLinearLoadDirective instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Metacello-MC-Directives'! !MetacelloLinearLoadDirective methodsFor: 'accessing' stamp: 'DaleHenrichs 3/9/2010 16:35'! title ^'linear load'! ! !MetacelloLinearLoadDirective methodsFor: 'actions' stamp: 'DaleHenrichs 3/21/2010 13:40'! loadUsing: aLoaderDirective gofer: aGofer self loadDirectives isEmpty ifTrue: [ ^self ]. aLoaderDirective loadLinearLoadDirective: self gofer: aGofer. ! ! Object subclass: #MetacelloLoadData instanceVariableNames: 'dataMap versionInfoMap packageNameMap' classVariableNames: '' poolDictionaries: '' category: 'Metacello-MC-Loaders'! !MetacelloLoadData methodsFor: 'accessing' stamp: 'dkh 3/20/2011 19:02'! 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 07/08/2009 12:34'! dataMap dataMap == nil ifTrue: [ dataMap := Dictionary new ]. ^dataMap! ! !MetacelloLoadData methodsFor: 'accessing' stamp: 'dkh 08/10/2009 16:17'! packageNameMap packageNameMap == nil ifTrue: [ packageNameMap := Dictionary new ]. ^packageNameMap! ! !MetacelloLoadData methodsFor: 'accessing' stamp: 'dkh 07/08/2009 12:48'! versionInfoMap versionInfoMap == nil ifTrue: [ versionInfoMap := Dictionary new ]. ^versionInfoMap! ! !MetacelloLoadData methodsFor: 'enumerating' stamp: 'dkh 7/29/2009 19:53'! do: aBlock self dataMap valuesDo: [:ar | aBlock value: (ar at: 1) value: (ar at: 2) value: (ar at: 3) ]! ! !MetacelloLoadData methodsFor: 'testing' stamp: 'dkh 07/08/2009 12:38'! isEmpty ^self dataMap isEmpty! ! !MetacelloLoadData methodsFor: 'versionInfo' stamp: 'dkh 3/20/2011 17:50'! ancestorsFor: packageSpec ifAbsent: aBlock ^self versionInfoMap at: packageSpec file ifAbsent: [ self packageNameMap at: packageSpec name ifAbsent: aBlock ]! ! !MetacelloLoadData methodsFor: 'versionInfo' stamp: 'dkh 08/10/2009 16:37'! currentVersionInfoFor: packageSpec ifAbsent: aBlock ^self versionInfoMap at: packageSpec file ifAbsent: [ self packageNameMap at: packageSpec name ifAbsent: aBlock ]! ! Object subclass: #MetacelloLoader instanceVariableNames: '' classVariableNames: 'PackagesBeforeLastLoad' poolDictionaries: '' category: 'ScriptLoader20'! !MetacelloLoader commentStamp: '' prior: 0! 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.! !MetacelloLoader methodsFor: 'accessing' stamp: 'EstebanLorenzano 5/8/2012 12:18'! currentMajorVersionNumber ^ self class currentMajorVersionNumber ! ! !MetacelloLoader methodsFor: 'accessing' stamp: 'EstebanLorenzano 5/8/2012 12:18'! currentMajorVersionNumberWithoutDot "self new currentMajorVersionNumberWithoutDot" ^ self class currentMajorVersionNumber asString copyWithout: $.! ! !MetacelloLoader methodsFor: 'compute' stamp: 'EstebanLorenzano 5/8/2012 12:18'! currentChangedPackages "self new currentChangedPackages" ^ self currentPackages select: [:each | each needsSaving or: [ (PackagesBeforeLastLoad includes: each ancestry ancestorString) not ] ]! ! !MetacelloLoader methodsFor: 'compute' stamp: 'EstebanLorenzano 5/8/2012 12:18'! currentVersionsToBeSaved "self new currentVersionsToBeSaved" ^ self allCurrentVersions reject: [ :each | self packagesNotToSavePatternNames anySatisfy: [ :p | p match: each ] ]! ! !MetacelloLoader methodsFor: 'elementary steps' stamp: 'EstebanLorenzano 5/8/2012 15:04'! 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 ! ! !MetacelloLoader methodsFor: 'initialize' stamp: 'EstebanLorenzano 5/8/2012 12:18'! initialize super initialize. PackagesBeforeLastLoad ifNil: [ PackagesBeforeLastLoad := Set new ]! ! !MetacelloLoader methodsFor: 'mc related utils' stamp: 'EstebanLorenzano 5/8/2012 12:18'! 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! ! !MetacelloLoader methodsFor: 'private' stamp: 'EstebanLorenzano 5/8/2012 16:11'! 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! ! !MetacelloLoader methodsFor: 'private' stamp: 'EstebanLorenzano 5/8/2012 12:18'! packagesNotToSavePatternNames ^ #( 'ScriptLoader*' 'Metacello*' 'SLICE*' 'Slice*' 'slice*' ).! ! !MetacelloLoader methodsFor: 'private' stamp: 'EstebanLorenzano 5/8/2012 12:18'! resetPackagesBeforeLastLoad PackagesBeforeLastLoad := Set new! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MetacelloLoader class instanceVariableNames: ''! !MetacelloLoader class methodsFor: 'private' stamp: 'EstebanLorenzano 5/8/2012 12:18'! packageToBeTestedFolderName ^ 'packages-to-be-tested'! ! !MetacelloLoader class methodsFor: 'private' stamp: 'SeanDeNigris 7/12/2012 08:45'! waitingCacheFolder ^ self packageToBeTestedFolderName asFileReference ensureDirectory; yourself ! ! Object subclass: #MetacelloLoaderPolicy instanceVariableNames: 'overrideRepositories repositoryMap ensuredMap cacheRepository cacheGofer ignoreImage loadData loadDirective silently' classVariableNames: '' poolDictionaries: '' category: 'Metacello-MC-Loaders'! !MetacelloLoaderPolicy methodsFor: 'accessing' stamp: 'dkh 4/7/2011 18:37'! 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: 'DaleHenrichs 3/7/2010 08:34'! cacheRepository cacheRepository == nil ifTrue: [ cacheRepository := MCDictionaryRepository new ]. ^ cacheRepository! ! !MetacelloLoaderPolicy methodsFor: 'accessing' stamp: 'dkh 4/7/2011 19:41'! cacheRepository: anMCRepository cacheRepository := anMCRepository. "getting a new repository, so wipe out the cacheGofer and ensureMap" ensuredMap := cacheGofer := nil! ! !MetacelloLoaderPolicy methodsFor: 'accessing' stamp: 'DaleHenrichs 03/08/2010 14:47'! ensuredMap ensuredMap == nil ifTrue: [ ensuredMap := Dictionary new ]. ^ensuredMap! ! !MetacelloLoaderPolicy methodsFor: 'accessing' stamp: 'DaleHenrichs 03/08/2010 14:47'! ensuredMap: anObject ensuredMap := anObject! ! !MetacelloLoaderPolicy methodsFor: 'accessing' stamp: 'DaleHenrichs 3/8/2010 11:39'! ignoreImage ^ ignoreImage! ! !MetacelloLoaderPolicy methodsFor: 'accessing' stamp: 'DaleHenrichs 3/8/2010 11:39'! ignoreImage: anObject ignoreImage := anObject! ! !MetacelloLoaderPolicy methodsFor: 'accessing' stamp: 'DaleHenrichs 3/11/2010 12:59'! loadData loadData == nil ifTrue: [ loadData := MetacelloLoadData new ]. ^loadData ! ! !MetacelloLoaderPolicy methodsFor: 'accessing' stamp: 'DaleHenrichs 3/10/2010 11:11'! loadDirective loadDirective == nil ifTrue: [ loadDirective := MetacelloLinearLoadDirective new ]. ^ loadDirective! ! !MetacelloLoaderPolicy methodsFor: 'accessing' stamp: 'DaleHenrichs 3/7/2010 08:09'! overrideRepositories ^ overrideRepositories! ! !MetacelloLoaderPolicy methodsFor: 'accessing' stamp: 'DaleHenrichs 3/7/2010 08:09'! overrideRepositories: anObject overrideRepositories := anObject! ! !MetacelloLoaderPolicy methodsFor: 'accessing' stamp: 'DaleHenrichs 3/5/2010 15:11'! repositoryMap repositoryMap == nil ifTrue: [ repositoryMap := Dictionary new ]. ^repositoryMap! ! !MetacelloLoaderPolicy methodsFor: 'accessing' stamp: 'DaleHenrichs 3/5/2010 10:51'! repositoryMap: anObject repositoryMap := anObject! ! !MetacelloLoaderPolicy methodsFor: 'accessing' stamp: 'DaleHenrichs 03/08/2010 16:23'! resetCacheGofer cacheGofer := nil! ! !MetacelloLoaderPolicy methodsFor: 'accessing' stamp: 'DaleHenrichs 3/11/2010 19:35'! silently silently == nil ifTrue: [ silently := false ]. ^ silently! ! !MetacelloLoaderPolicy methodsFor: 'accessing' stamp: 'DaleHenrichs 3/11/2010 19:35'! silently: anObject silently := anObject! ! !MetacelloLoaderPolicy methodsFor: 'actions' stamp: 'DaleHenrichs 3/10/2010 10:02'! load overrideRepositories := Array with: self cacheRepository. "ensure that hasRepositoryOverrides is true" self loadDirective loadWithPolicy: self! ! !MetacelloLoaderPolicy methodsFor: 'actions' stamp: 'DaleHenrichs 3/9/2010 16:50'! pushAtomicLoadDirectivesDuring: aBlock for: aLoader self pushLoadDirective: (MetacelloAtomicLoadDirective loader: aLoader) during: aBlock. ! ! !MetacelloLoaderPolicy methodsFor: 'actions' stamp: 'DaleHenrichs 3/21/2010 13:11'! pushExplicitLoadDirectivesDuring: aBlock for: aLoader | directive | directive := MetacelloExplicitLoadDirective loader: aLoader. self pushLoadDirective: directive during: aBlock. ^directive! ! !MetacelloLoaderPolicy methodsFor: 'actions' stamp: 'DaleHenrichs 3/9/2010 16:50'! pushLinearLoadDirectivesDuring: aBlock for: aLoader self pushLoadDirective: (MetacelloLinearLoadDirective loader: aLoader) during: aBlock. ! ! !MetacelloLoaderPolicy methodsFor: 'initialize-release' stamp: 'DaleHenrichs 03/08/2010 14:47'! initialize self repositoryMap; cacheRepository; ensuredMap. ignoreImage := false ! ! !MetacelloLoaderPolicy methodsFor: 'testing' stamp: 'DaleHenrichs 3/7/2010 08:14'! hasRepositoryOverrides ^self overrideRepositories ~~ nil! ! !MetacelloLoaderPolicy methodsFor: 'private' stamp: 'DaleHenrichs 3/9/2010 15:33'! pushLoadDirective: aLoaderDirective during: aBlock | oldRoot | self loadDirective add: aLoaderDirective. oldRoot := loadDirective. loadDirective := aLoaderDirective. aBlock ensure: [ loadDirective := oldRoot ]. ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MetacelloLoaderPolicy class instanceVariableNames: ''! !MetacelloLoaderPolicy class methodsFor: 'instance creation' stamp: 'DaleHenrichs 3/7/2010 08:10'! overrideRepositories: aCollection ^self new overrideRepositories: aCollection ! ! MetacelloCommonMCSpecLoader subclass: #MetacelloLoadingMCSpecLoader instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Metacello-MC-Loaders'! !MetacelloLoadingMCSpecLoader methodsFor: 'accessing' stamp: 'DaleHenrichs 3/11/2010 16:33'! actionLabel ^'Loading '! ! !MetacelloLoadingMCSpecLoader methodsFor: 'accessing' stamp: 'DaleHenrichs 3/10/2010 14:28'! fetchingSpecLoader ^(MetacelloFetchingMCSpecLoader on: self spec) shouldDisablePackageCache: self shouldDisablePackageCache; loaderPolicy: self loaderPolicy copy; yourself! ! !MetacelloLoadingMCSpecLoader methodsFor: 'actions' stamp: 'DaleHenrichs 3/10/2010 15:16'! doLoad "NOOP"! ! !MetacelloLoadingMCSpecLoader methodsFor: 'development support' stamp: 'dkh 4/6/2011 22:36'! 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: 'DaleHenrichs 12/08/2010 11:06'! 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 4/17/2011 14:27'! 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: 'development support' stamp: 'dkh 4/6/2011 22:35'! 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: 'DaleHenrichs 3/6/2010 09:04'! 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: 'DaleHenrichs 3/10/2010 14:42'! repositoryFor: pkgSpec from: repositorySpecs ^([self resolveSpec: pkgSpec from: repositorySpecs] on: Error do: [:ignored | ^nil ]) repository! ! !MetacelloLoadingMCSpecLoader methodsFor: 'development support' stamp: 'DaleHenrichs 3/10/2010 14:42'! repositoryFor: pkgSpec with: gofer ^([self resolveSpec: pkgSpec with: gofer] on: Error do: [:ignored | ^nil ]) repository! ! !MetacelloLoadingMCSpecLoader methodsFor: 'development support' stamp: 'dkh 4/6/2011 22:36'! 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: 'development support' stamp: 'DaleHenrichs 3/10/2010 14:44'! resolveSpec: pkgSpec with: gofer ^pkgSpec goferLoaderReference resolveWith: gofer! ! !MetacelloLoadingMCSpecLoader methodsFor: 'development support' stamp: 'DaleHenrichs 3/6/2010 09:04'! 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 := wc newVersion) == nil ifTrue: [ ^false ]. repo storeVersion: newVersion. ^true! ! !MetacelloLoadingMCSpecLoader methodsFor: 'doits' stamp: 'DaleHenrichs 3/10/2010 14:31'! postLoad: packageOrVersionSpec | block | (block := packageOrVersionSpec postLoadDoItBlock) ~~ nil ifTrue: [ block valueWithPossibleArgs: { self. packageOrVersionSpec. } ]! ! !MetacelloLoadingMCSpecLoader methodsFor: 'doits' stamp: 'DaleHenrichs 3/10/2010 14:31'! preLoad: packageOrVersionSpec | block | (block := packageOrVersionSpec preLoadDoItBlock) ~~ nil ifTrue: [ block valueWithPossibleArgs: { self. packageOrVersionSpec. } ]! ! !MetacelloLoadingMCSpecLoader methodsFor: 'packages' stamp: 'dkh 4/6/2011 22:35'! 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: 'private' stamp: 'dkh 4/6/2011 22:36'! 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! ! Object subclass: #MetacelloMCPartiallyLoadedStatus instanceVariableNames: 'hasNoPackage hasNoProject aProjectIsLoaded aPackageIsLoaded aLoadedProjectIsExact aLoadedPackageIsExact aLoadedProjectIsCurrent aLoadedPackageIsCurrent aLoadedProjectIsNotCurrent aLoadedPackageIsNotCurrent aProjectNotLoaded aPackageNotLoaded vrsnStatus abort' classVariableNames: '' poolDictionaries: '' category: 'Metacello-MC-Specs'! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 7/11/2011 15:03'! aLoadedPackageIsCurrent ^ aLoadedPackageIsCurrent! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 7/11/2011 15:01'! aLoadedPackageIsCurrent: aBoolean aLoadedPackageIsCurrent := aBoolean! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 7/11/2011 15:03'! aLoadedPackageIsExact ^ aLoadedPackageIsExact! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 7/11/2011 15:00'! aLoadedPackageIsExact: aBoolean aLoadedPackageIsExact := aBoolean! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 7/11/2011 15:03'! aLoadedPackageIsNotCurrent ^ aLoadedPackageIsNotCurrent! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 7/11/2011 15:02'! aLoadedPackageIsNotCurrent: aBoolean aLoadedPackageIsNotCurrent := aBoolean! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 7/11/2011 15:01'! aLoadedProjectIsCurrent: aBoolean aLoadedProjectIsCurrent := aBoolean! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 7/11/2011 15:03'! aLoadedProjectIsExact ^ aLoadedProjectIsExact! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 7/11/2011 15:00'! aLoadedProjectIsExact: aBoolean aLoadedProjectIsExact := aBoolean! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 7/11/2011 15:04'! aLoadedProjectIsNotCurrent ^ aLoadedProjectIsNotCurrent! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 7/11/2011 15:01'! aLoadedProjectIsNotCurrent: aBoolean aLoadedProjectIsNotCurrent := aBoolean! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 7/11/2011 15:04'! aPackageIsLoaded ^aPackageIsLoaded! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 7/11/2011 15:00'! aPackageIsLoaded: aBoolean aPackageIsLoaded := aBoolean! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 7/11/2011 15:04'! aPackageNotLoaded ^aPackageNotLoaded! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 7/11/2011 15:02'! aPackageNotLoaded: aBoolean aPackageNotLoaded := aBoolean! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 7/11/2011 15:05'! aProjectIsLoaded ^aProjectIsLoaded! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 7/11/2011 14:59'! aProjectIsLoaded: aBoolean aProjectIsLoaded := aBoolean! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 7/11/2011 15:05'! aProjectNotLoaded ^aProjectNotLoaded! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 7/11/2011 15:02'! aProjectNotLoaded: aBoolean aProjectNotLoaded := aBoolean! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 7/11/2011 15:05'! abort ^ abort! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 7/11/2011 15:02'! abort: aBoolean abort := aBoolean! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 7/11/2011 15:06'! hasNoPackage ^ hasNoPackage! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 7/11/2011 14:59'! hasNoPackage: aBoolean hasNoPackage := aBoolean! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 7/11/2011 15:06'! hasNoProject ^ hasNoProject! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 7/11/2011 14:55'! hasNoProject: aBoolean hasNoProject := aBoolean! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'accessing' stamp: 'dkh 7/11/2011 14:53'! vrsnStatus ^vrsnStatus! ! !MetacelloMCPartiallyLoadedStatus methodsFor: 'evaulation' stamp: 'dkh 7/11/2011 16:20'! 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: 'initialization' stamp: 'dkh 7/11/2011 14:52'! 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: 'testing' stamp: 'dkh 7/11/2011 15:58'! 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: 'testing' stamp: 'dkh 7/11/2011 16:03'! 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: 'testing' stamp: 'dkh 7/11/2011 16:05'! 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: 'testing' stamp: 'dkh 7/11/2011 16:07'! isSomethingLoaded: somethingLoadedBlock "at least one package loaded" (self evaluateStatus: #(#allLoadedToSpec #loadedToSpec #loadedMatchConstraints #somethingLoaded)) ifTrue: [ aPackageIsLoaded ifTrue: [ somethingLoadedBlock value: #somethingLoaded ] ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MetacelloMCPartiallyLoadedStatus class instanceVariableNames: ''! !MetacelloMCPartiallyLoadedStatus class methodsFor: 'instance creation' stamp: 'dkh 7/11/2011 14:47'! new ^ self basicNew initialize! ! MetacelloProject subclass: #MetacelloMCProject instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Metacello-MC-Model'! !MetacelloMCProject methodsFor: 'development support' stamp: 'DaleHenrichs 3/7/2010 09:51'! fetchProject "fetch the latest version of the configuration package" ^self fetchProject: MetacelloLoaderPolicy new! ! !MetacelloMCProject methodsFor: 'development support' stamp: 'DaleHenrichs 3/7/2010 09:49'! 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: 'development support' stamp: 'dkh 4/17/2011 14:37'! goferBranch: branchName project: commitMessage | pkgSpec | (pkgSpec := self projectPackage) == nil ifTrue: [ ^false ]. pkgSpec file: pkgSpec name, '.', branchName. ^pkgSpec goferBranchPackage: branchName message: commitMessage! ! !MetacelloMCProject methodsFor: 'development support' stamp: 'DaleHenrichs 3/15/2010 11:37'! goferCommitProject: commitMessage | pkgSpec | (pkgSpec := self projectPackage) == nil ifTrue: [ ^false ]. ^pkgSpec goferCommitPackage: commitMessage! ! !MetacelloMCProject methodsFor: 'development support' stamp: 'dkh 12/22/2009 10:00'! 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: 'development support' stamp: 'DaleHenrichs 03/20/2010 12:48'! 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 description. ^pkgSpec]. ^nil! ! !MetacelloMCProject methodsFor: 'development support' stamp: 'Dalehenrichs 02/10/2010 10:15'! saveProject | pkgSpec | (pkgSpec := self projectPackage) == nil ifTrue: [ ^false ]. ^pkgSpec savePackage! ! !MetacelloMCProject methodsFor: 'development support' stamp: 'DaleHenrichs 3/24/2010 15:50'! 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: 'development support' stamp: 'dkh 4/7/2011 23:26'! 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: 'repository creation' stamp: 'dkh 10/22/2009 08:53'! createRepository: aRepositorySpec ^ MetacelloPlatform current createRepository: aRepositorySpec! ! !MetacelloMCProject methodsFor: 'repository updating' stamp: 'dkh 9/2/2009 06:21'! updatePackageRepositoriesFor: versionString | versionSpec | (versionSpec := (self version: versionString) versionSpec) packageSpecsInLoadOrder do: [:pkgSpec | pkgSpec updatePackageRepositoriesFor: versionSpec ]. ^true! ! !MetacelloMCProject methodsFor: 'spec classes' stamp: 'DaleHenrichs 3/6/2010 07:46'! defaultLoaderClass ^MetacelloLoadingMCSpecLoader! ! !MetacelloMCProject methodsFor: 'spec classes' stamp: 'dkh 06/01/2009 10:58'! packageSpec ^self packageSpecClass for: self! ! !MetacelloMCProject methodsFor: 'spec classes' stamp: 'dkh 06/01/2009 10:24'! packageSpecClass ^MetacelloPackageSpec! ! !MetacelloMCProject methodsFor: 'spec classes' stamp: 'DaleHenrichs 10/27/2010 11:14'! projectSpecClass ^MetacelloMCProjectSpec! ! !MetacelloMCProject methodsFor: 'spec classes' stamp: 'dkh 6/7/2009 10:11'! repositoriesSpec ^self repositoriesSpecClass for: self! ! !MetacelloMCProject methodsFor: 'spec classes' stamp: 'dkh 6/7/2009 10:11'! repositoriesSpecClass ^MetacelloRepositoriesSpec! ! !MetacelloMCProject methodsFor: 'spec classes' stamp: 'dkh 06/01/2009 10:59'! repositorySpec ^self repositorySpecClass for: self! ! !MetacelloMCProject methodsFor: 'spec classes' stamp: 'dkh 06/01/2009 10:25'! repositorySpecClass ^MetacelloRepositorySpec! ! !MetacelloMCProject methodsFor: 'spec classes' stamp: 'dkh 6/6/2009 12:19'! versionSpecClass ^MetacelloMCVersionSpec! ! !MetacelloMCProject methodsFor: 'private' stamp: 'dkh 6/10/2009 10:56'! pragmaKeywords ^super pragmaKeywords, #(projectPackage:attribute: packages:attribute: repositories:attribute: )! ! MetacelloProjectSpec subclass: #MetacelloMCProjectSpec instanceVariableNames: 'projectPackage' classVariableNames: '' poolDictionaries: '' category: 'Metacello-MC-Specs'! !MetacelloMCProjectSpec methodsFor: 'accessing' stamp: 'dkh 7/20/2011 11:51'! className: aString super className: aString. (projectPackage ~~ nil and: [ projectPackage getFile == nil ]) ifTrue: [ projectPackage name: aString; file: aString ]! ! !MetacelloMCProjectSpec methodsFor: 'accessing' stamp: 'dkh 7/20/2011 11:54'! file: aString self projectPackage name ifNil: [ self projectPackage name: aString ]. self projectPackage file: aString! ! !MetacelloMCProjectSpec methodsFor: 'accessing' stamp: 'DaleHenrichs 11/5/2010 15:57'! 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: 'accessing' stamp: 'DaleHenrichs 11/5/2010 15:57'! 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: 'accessing' stamp: 'dkh 10/4/2009 11:44'! packageFileSpecFor: aMetacelloPackagesSpec ^(aMetacelloPackagesSpec project projectReferenceSpec) name: self name; projectReference: self copy; yourself. ! ! !MetacelloMCProjectSpec methodsFor: 'accessing' stamp: 'dkh 6/7/2009 09:19'! projectPackage: anObject projectPackage := anObject! ! !MetacelloMCProjectSpec methodsFor: 'accessing' stamp: 'dkh 10/7/2009 01:02'! repository: aString self projectPackage repository: aString! ! !MetacelloMCProjectSpec methodsFor: 'accessing' stamp: 'dkh 10/22/2009 09:39'! repository: aString username: username password: password self projectPackage repository: aString username: username password: password! ! !MetacelloMCProjectSpec methodsFor: 'copying' stamp: 'DaleHenrichs 11/17/2010 12:44'! postCopy super postCopy. projectPackage := projectPackage copy. ! ! !MetacelloMCProjectSpec methodsFor: 'development support' stamp: 'DaleHenrichs 11/16/2010 16:31'! 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" className := operator := loads := projectPackage := nil. sourceSpec ~~ nil ifTrue: [ versionString := sourceSpec versionString ].! ! !MetacelloMCProjectSpec methodsFor: 'development support' stamp: 'DaleHenrichs 11/5/2010 15:57'! updatePackageSpec: updatedSpecs "Add project copy to updatedSpecs if the current version of the project is different from the receiver's version" | prj currentVersion spec | self 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: 'loading' stamp: 'DaleHenrichs 11/5/2010 15:56'! 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 ]. (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 9/7/2011 14:17'! 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 and: [ vrsn blessing == #development ]) ifTrue: [ ensured ~~ #latest ifTrue: [ mcLoader ensureForDevelopment ifTrue: [ | pc | (pc := self projectClass) ~~ nil ifTrue: [ MetacelloClearStackCacheNotification signal: #(#versionConstructor)]. self projectPackage loadUsing: mcLoader ] ifFalse: [ self projectPackage fetchUsing: mcLoader ]. mcLoader ensuredMap at: self name put: #latest ]. ^self]]. ensured == nil ifTrue: [ mcLoader ensureForDevelopment ifTrue: [ | pc | (pc := self projectClass) ~~ nil ifTrue: [ MetacelloClearStackCacheNotification signal: #(#versionConstructor)]. self projectPackage loadUsing: mcLoader ] ifFalse: [ self projectPackage fetchUsing: mcLoader ]. mcLoader ensuredMap at: self name put: #present ]! ! !MetacelloMCProjectSpec methodsFor: 'loading' stamp: 'dkh 9/7/2011 14:13'! ensureProjectLoaded "Ensure that the MetacelloProject is loaded in image. projectClass == nil or requested version non-existent warrants a project package load." (self projectClass == nil or: [ self versionOrNil == nil ]) ifTrue: [ | pc | (pc := self projectClass) ~~ nil ifTrue: [ MetacelloClearStackCacheNotification signal: #(#versionConstructor)]. self projectPackage load. ^ true ]. ^ false! ! !MetacelloMCProjectSpec methodsFor: 'loading' stamp: 'DaleHenrichs 10/25/2010 15:32'! load | displayString | displayString := 'Project: ', self name. self versionString ~~ nil ifTrue: [ displayString := displayString, ' ', self versionString ]. Transcript cr; show: displayString. self ensureProjectLoaded. self loadVersion: self determineCurrentVersionForLoad! ! !MetacelloMCProjectSpec methodsFor: 'loading' stamp: 'DaleHenrichs 11/5/2010 15:57'! loadVersion: aVersionOrNil "Load the correct version of the project" | vrsn mcLoader list | vrsn := aVersionOrNil . vrsn == nil ifTrue: [ (vrsn := self versionOrNil) == nil ifTrue: [ ^(MetacelloProjectSpecLoadError projectSpec: self) signal: 'No version found for ', self versionString printString, ' of ', self className asString ]]. 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 ]]. mcLoader preLoad: self. vrsn fetchRequiredFromArray: list. mcLoader postLoad: self. ] defaultDictionary: Dictionary new. ! ! !MetacelloMCProjectSpec methodsFor: 'merging' stamp: 'dkh 10/4/2009 12:05'! mergeMap | map | map := super mergeMap. map at: #projectPackage put: projectPackage. ^map! ! !MetacelloMCProjectSpec methodsFor: 'merging' stamp: 'dkh 10/9/2009 06:28'! mergeSpec: anotherSpec | newSpec anotherProjectPackage map | newSpec := super mergeSpec: anotherSpec. map := anotherSpec mergeMap. (anotherProjectPackage := map at: #projectPackage) ~~ nil ifTrue: [ newSpec projectPackage: (newSpec projectPackage == nil ifTrue: [ anotherProjectPackage ] ifFalse: [ newSpec projectPackage mergeSpec: anotherProjectPackage ])]. ^newSpec! ! !MetacelloMCProjectSpec methodsFor: 'merging' stamp: 'dkh 10/8/2009 20:34'! nonOverridable ^super nonOverridable, #( projectPackage )! ! !MetacelloMCProjectSpec methodsFor: 'querying' stamp: 'dkh 10/24/2009 20:19'! file ^self projectPackage file! ! !MetacelloMCProjectSpec methodsFor: 'querying' stamp: 'dkh 11/12/2009 16:56'! packageRepository ^nil! ! !MetacelloMCProjectSpec methodsFor: 'querying' stamp: 'DaleHenrichs 11/11/2010 17:07'! projectClass self className == nil ifTrue: [ ^nil ]. ^Smalltalk at: self className asSymbol ifAbsent: []! ! !MetacelloMCProjectSpec methodsFor: 'querying' stamp: 'dkh 9/10/2009 13:18'! projectClassProject "indirection needed when projectClass is _not_ a subclass of MetacelloProject" ^self projectClass new project! ! !MetacelloMCProjectSpec methodsFor: 'querying' stamp: 'dkh 6/7/2009 09:19'! projectPackage ^ projectPackage! ! !MetacelloMCProjectSpec methodsFor: 'querying' stamp: 'dkh 7/8/2011 22:27'! 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 projectPackage load. vrsn := self versionOrNil. ex return: (vrsn expandToLoadableSpecNames: loadList)]. ex pass]. ^self projectClassProject currentVersionAgainst: expanded ! ! !MetacelloMCProjectSpec methodsFor: 'querying' stamp: 'dkh 1/2/2010 15:36'! repository ^self projectPackage packageRepository! ! !MetacelloMCProjectSpec methodsFor: 'querying' stamp: 'DaleHenrichs 1/13/2011 12:54'! 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: 'querying' stamp: 'DaleHenrichs 11/5/2010 15:55'! versionOrNil ^[ self version ] on: MetacelloVersionDoesNotExistError do: [:ex | ^nil ]. ! ! !MetacelloMCProjectSpec methodsFor: 'testing' stamp: 'DaleHenrichs 11/5/2010 15:55'! compareCurrentVersion: anOperator targetVersionStatus: targetVersionStatus using: anMCLoader | cv vrsn prjct | (vrsn := self versionOrNil) == nil ifTrue: [ ^false ]. prjct := self projectClassProject. prjct loader: anMCLoader. (cv := prjct currentVersion) == nil ifTrue: [ ^false ]. (targetVersionStatus includes: cv versionStatus) ifTrue: [ ^cv perform: anOperator with: vrsn ]. ^false ! ! !MetacelloMCProjectSpec methodsFor: 'testing' stamp: 'DaleHenrichs 11/5/2010 15:55'! 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: 'testing' stamp: 'DaleHenrichs 12/21/2010 13:45'! hasNonVersionStringField | hasVersionString hasOperator hasProjectPackage hasLoads hasClassName hasPreLoadDoIt hasPostLoadDoIt | hasClassName := self className ~~ nil. hasVersionString := self versionString ~~ nil. hasOperator := operator ~~ nil. hasProjectPackage := self projectPackage ~~ nil and: [ self projectPackage name ~~ nil or: [ self projectPackage packageRepository ~~ nil ] ]. hasLoads := self loads ~~ nil. hasPreLoadDoIt := self getPreLoadDoIt ~~ nil. hasPostLoadDoIt := self getPostLoadDoIt ~~ nil. ^ hasClassName | hasOperator | hasProjectPackage | hasLoads | hasPreLoadDoIt | hasPostLoadDoIt! ! !MetacelloMCProjectSpec methodsFor: 'testing' stamp: 'DaleHenrichs 11/5/2010 15:56'! 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: 'testing' stamp: 'DaleHenrichs 11/5/2010 15:56'! isPossibleBaseline | vrsn | (vrsn := self versionOrNil) == nil ifTrue: [ ^false ]. (vrsn allPackagesForSpecNamed: (self loadListForVersion: vrsn)) do: [:pkg | pkg workingCopy == nil ifTrue: [ ^false ]]. ^true! ! !MetacelloMCProjectSpec methodsFor: 'visiting' stamp: 'dkh 10/21/2009 15:53'! projectDo: projectBlock packageDo: packageBlock groupDo: groupBlock projectBlock value: self! ! !MetacelloMCProjectSpec methodsFor: 'private' stamp: 'dkh 10/21/2009 19:20'! loadListForVersion: vrsn ^ (self loads == nil or: [self loads isEmpty]) ifTrue: [vrsn spec defaultPackageNames] ifFalse: [self loads]! ! !MetacelloMCProjectSpec methodsFor: 'private' stamp: 'DaleHenrichs 11/5/2010 15:57'! resolveToAllPackagesIn: aVersionSpec visited: visited | vrsn | visited pushProject: [ visited visit: self doing: [ :spec | spec ensureProjectLoaded. (vrsn := spec versionOrNil) == nil ifTrue: [ (MetacelloVersionDoesNotExistError project: self project versionString: self versionString) signal ]. ^ vrsn allPackagesForSpecNamed: (self loadListForVersion: vrsn) ifAbsent: [ self error: 'invalid loads: spec' ] ] ]. ^ #()! ! !MetacelloMCProjectSpec methodsFor: 'private' stamp: 'dkh 11/12/2009 10:12'! resolveToLoadableSpec ^self copy! ! MetacelloVersion subclass: #MetacelloMCVersion instanceVariableNames: 'loaderPolicy' classVariableNames: '' poolDictionaries: '' category: 'Metacello-MC-Model'! !MetacelloMCVersion methodsFor: 'accessing' stamp: 'DaleHenrichs 3/29/2010 15:32'! cacheRepository: repository "by default cacheRepository is an MCDictionaryRepository" self loaderPolicy cacheRepository: repository ! ! !MetacelloMCVersion methodsFor: 'accessing' stamp: 'DaleHenrichs 3/29/2010 15:31'! ignoreImage: aBool "by default ignoreImage is false" self loaderPolicy ignoreImage: aBool ! ! !MetacelloMCVersion methodsFor: 'accessing' stamp: 'DaleHenrichs 3/6/2010 08:21'! loaderPolicy loaderPolicy == nil ifTrue: [ loaderPolicy := MetacelloLoaderPolicy new ]. ^ loaderPolicy! ! !MetacelloMCVersion methodsFor: 'accessing' stamp: 'DaleHenrichs 3/6/2010 08:20'! loaderPolicy: anObject loaderPolicy := anObject! ! !MetacelloMCVersion methodsFor: 'accessing' stamp: 'DaleHenrichs 3/7/2010 08:11'! repositoryOverrides: repositoriesCollection self loaderPolicy overrideRepositories: repositoriesCollection! ! !MetacelloMCVersion methodsFor: 'accessing' stamp: 'DaleHenrichs 3/29/2010 15:32'! silently: aBool "by default silently is false" self loaderPolicy silently: aBool! ! !MetacelloMCVersion methodsFor: 'actions' stamp: 'DaleHenrichs 3/7/2010 08:25'! fetch ^self doFetchRequiredFromArray: self spec defaultPackageNames! ! !MetacelloMCVersion methodsFor: 'actions' stamp: 'DaleHenrichs 3/7/2010 08:25'! fetch: required ^required fetchRequiredForMetacelloMCVersion: self ! ! !MetacelloMCVersion methodsFor: 'actions' stamp: 'DaleHenrichs 3/4/2010 15:37'! load ^self doLoadRequiredFromArray: self spec defaultPackageNames! ! !MetacelloMCVersion methodsFor: 'actions' stamp: 'dkh 6/15/2009 22:34'! load: required ^required loadRequiredForMetacelloMCVersion: self ! ! !MetacelloMCVersion methodsFor: 'actions' stamp: 'DaleHenrichs 3/11/2010 10:07'! record ^self doRecordRequiredFromArray: self spec defaultPackageNames! ! !MetacelloMCVersion methodsFor: 'actions' stamp: 'DaleHenrichs 3/11/2010 10:06'! record: required ^required recordRequiredForMetacelloMCVersion: self ! ! !MetacelloMCVersion methodsFor: 'querying' stamp: 'dkh 10/21/2009 19:15'! 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 10/21/2009 19:16'! 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: 'querying' stamp: 'DaleHenrichs 11/20/2010 08:14'! currentlyLoadedClassesInVersion ^self spec currentlyLoadedClassesInVersion! ! !MetacelloMCVersion methodsFor: 'querying' stamp: 'dkh 5/11/2011 14:36'! currentlyLoadedExtensionClassesInVersion ^self spec currentlyLoadedExtensionClassesInVersion! ! !MetacelloMCVersion methodsFor: 'querying' stamp: 'dkh 11/9/2010 16:41'! defaultPackageNamesToLoad "Answer the list of packages and projects to be loaded --> packages already loaded" ^ self defaultPackageNamesToLoad: self spec defaultPackageNames! ! !MetacelloMCVersion methodsFor: 'querying' stamp: 'DaleHenrichs 10/25/2010 15:32'! 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: 'querying' stamp: 'DaleHenrichs 11/8/2010 12:58'! difference: aMetacelloVersion "Return a a dictionary of additions, removals and modifications" ^self spec difference: aMetacelloVersion spec! ! !MetacelloMCVersion methodsFor: 'querying' stamp: 'DaleHenrichs 2/4/2010 10:32'! expandToLoadableSpecNames: nameList "Just like #resolveToLoadableSpecs:, but returns list of spec names instead of specs" ^self spec expandToLoadableSpecNames: nameList! ! !MetacelloMCVersion methodsFor: 'querying' stamp: 'dkh 10/21/2009 14:37'! 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 ! ! !MetacelloMCVersion methodsFor: 'querying' stamp: 'DaleHenrichs 10/25/2010 15:32'! 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: 'querying' stamp: 'dkh 10/24/2009 20:02'! packageNamed: aString ^self packageNamed: aString ifAbsent: [ ^nil ]. ! ! !MetacelloMCVersion methodsFor: 'querying' stamp: 'dkh 10/24/2009 20:04'! packageNamed: aString ifAbsent: aBlock | pkg | (pkg := self spec packageNamed: aString ifAbsent: []) == nil ifTrue: [ ^aBlock value ]. ^pkg referencedSpec! ! !MetacelloMCVersion methodsFor: 'querying' stamp: 'dkh 10/21/2009 14:37'! 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: 'querying' stamp: 'dkh 10/21/2009 15:06'! 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: [ ^#() ]! ! !MetacelloMCVersion methodsFor: 'querying' stamp: 'dkh 10/21/2009 15:20'! 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 10/24/2009 19:45'! 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 ! ! !MetacelloMCVersion methodsFor: 'querying' stamp: 'DaleHenrichs 2/3/2010 15:43'! 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! ! !MetacelloMCVersion methodsFor: 'private' stamp: 'dkh 10/21/2009 19:17'! 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: 'private' stamp: 'DaleHenrichs 4/9/2010 14:48'! 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/6/2011 10:24'! 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: 'private' stamp: 'DaleHenrichs 4/9/2010 14:48'! 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: 'DaleHenrichs 11/2/2010 16:09'! executeLoadFromArray: anArray | loader mcLoader | loader := MetacelloMCVersionSpecLoader on: self spec. loader required: anArray. loaderPolicy notNil ifTrue: [ loader loaderPolicy: loaderPolicy ]. ^loader load! ! !MetacelloMCVersion methodsFor: 'private' stamp: 'dkh 4/6/2011 22:23'! 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: 'private' stamp: 'DaleHenrichs 3/11/2010 14:06'! loadRequiredFromArray: anArray | displayString | displayString := 'Loading ', self versionNumber printString, ' of ', self spec projectLabel. MetacelloPlatform current do: [ ^self executeLoadFromArray: anArray ] displaying: displayString! ! !MetacelloMCVersion methodsFor: 'private' stamp: 'dkh 6/18/2009 10:12'! loader: aLoader self versionSpec loader: aLoader! ! Object subclass: #MetacelloMCVersionDiffReport instanceVariableNames: 'additions configuration modifications removals from to' classVariableNames: '' poolDictionaries: '' category: 'Metacello-MC-Model'! !MetacelloMCVersionDiffReport methodsFor: 'accessing' stamp: 'DaleHenrichs 1/14/2011 11:25'! additions additions ifNil: [ additions := Dictionary new ]. ^ additions! ! !MetacelloMCVersionDiffReport methodsFor: 'accessing' stamp: 'DaleHenrichs 1/14/2011 11:23'! additions: anObject additions := anObject! ! !MetacelloMCVersionDiffReport methodsFor: 'accessing' stamp: 'DaleHenrichs 1/14/2011 11:24'! configuration ^ configuration! ! !MetacelloMCVersionDiffReport methodsFor: 'accessing' stamp: 'DaleHenrichs 1/14/2011 11:24'! configuration: anObject configuration := anObject! ! !MetacelloMCVersionDiffReport methodsFor: 'accessing' stamp: 'DaleHenrichs 1/14/2011 11:26'! from ^ from! ! !MetacelloMCVersionDiffReport methodsFor: 'accessing' stamp: 'DaleHenrichs 1/14/2011 11:27'! from: anObject from := anObject! ! !MetacelloMCVersionDiffReport methodsFor: 'accessing' stamp: 'DaleHenrichs 1/14/2011 11:25'! modifications modifications ifNil: [ modifications := Dictionary new ]. ^ modifications! ! !MetacelloMCVersionDiffReport methodsFor: 'accessing' stamp: 'DaleHenrichs 1/14/2011 11:24'! modifications: anObject modifications := anObject! ! !MetacelloMCVersionDiffReport methodsFor: 'accessing' stamp: 'DaleHenrichs 1/14/2011 11:25'! removals removals ifNil: [ removals := Dictionary new ]. ^ removals! ! !MetacelloMCVersionDiffReport methodsFor: 'accessing' stamp: 'DaleHenrichs 1/14/2011 11:24'! removals: anObject removals := anObject! ! !MetacelloMCVersionDiffReport methodsFor: 'accessing' stamp: 'DaleHenrichs 1/14/2011 11:27'! to ^ to! ! !MetacelloMCVersionDiffReport methodsFor: 'accessing' stamp: 'DaleHenrichs 1/14/2011 11:27'! to: anObject to := anObject! ! !MetacelloMCVersionDiffReport methodsFor: 'printing' stamp: 'DaleHenrichs 1/14/2011 11:48'! 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! ! MetacelloVersionSpec subclass: #MetacelloMCVersionSpec instanceVariableNames: 'packages repositories' classVariableNames: '' poolDictionaries: '' category: 'Metacello-MC-Specs'! !MetacelloMCVersionSpec methodsFor: 'accessing' stamp: 'dkh 7/8/2011 20:11'! computeVersionStatus: matchBlock self computeVersionStatus: (self expandToLoadableSpecNames: #('ALL')) matchBlock: matchBlock! ! !MetacelloMCVersionSpec methodsFor: 'accessing' stamp: 'dkh 7/11/2011 15:47'! 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! ! !MetacelloMCVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/17/2009 16:05'! packages packages == nil ifTrue: [ packages := self project packagesSpec ]. ^ packages! ! !MetacelloMCVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/7/2009 08:19'! packages: anObject packages := anObject! ! !MetacelloMCVersionSpec methodsFor: 'accessing' stamp: 'dkh 9/23/2009 17:16'! packagesSpec ^self packages! ! !MetacelloMCVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/17/2009 16:05'! repositories repositories == nil ifTrue: [ repositories := self project repositoriesSpec ]. ^ repositories! ! !MetacelloMCVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/7/2009 08:20'! repositories: anObject repositories := anObject! ! !MetacelloMCVersionSpec methodsFor: 'accessing' stamp: 'dkh 9/23/2009 17:18'! repositoriesSpec ^self repositories! ! !MetacelloMCVersionSpec methodsFor: 'accessing' stamp: 'dkh 10/7/2009 16:27'! repository: aString self repositoriesSpec add: aString! ! !MetacelloMCVersionSpec methodsFor: 'accessing' stamp: 'dkh 10/22/2009 14:24'! repository: aString username: username password: password self repositoriesSpec repository: aString username: username password: password! ! !MetacelloMCVersionSpec methodsFor: 'copying' stamp: 'dkh 10/9/2009 07:34'! postCopy super postCopy. packages := packages copy. repositories := repositories copy. ! ! !MetacelloMCVersionSpec methodsFor: 'development support' stamp: 'DaleHenrichs 11/12/2010 06:30'! forceUpdatedPackageSpecs | updatedSpecs mcLoader | updatedSpecs := Dictionary new. mcLoader := self loader. self packages map valuesDo: [:pkg | pkg forceUpdatePackageSpec: updatedSpecs using: mcLoader]. ^updatedSpecs! ! !MetacelloMCVersionSpec methodsFor: 'development support' stamp: 'dkh 12/22/2009 09:56'! packagesNeedSavingVisited: visitedProjects into: aCollection self packages map valuesDo: [:pkg | pkg packagesNeedSavingVisited: visitedProjects using: self repositories map values into: aCollection ]. ! ! !MetacelloMCVersionSpec methodsFor: 'development support' stamp: 'DaleHenrichs 11/17/2010 12:02'! 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: 'development support' stamp: 'dkh 10/5/2009 16:15'! updatedPackageSpecs | updatedSpecs mcLoader | updatedSpecs := Dictionary new. mcLoader := self loader. self packages map valuesDo: [:pkg | pkg updatePackageSpec: updatedSpecs using: mcLoader]. ^updatedSpecs! ! !MetacelloMCVersionSpec methodsFor: 'enumerating' stamp: 'dkh 10/20/2009 17:16'! projectDo: projectBlock packageDo: packageBlock groupDo: groupBlock self packageSpecsInLoadOrder do: [:pkgSpec | pkgSpec projectDo: projectBlock packageDo: packageBlock groupDo: groupBlock ]! ! !MetacelloMCVersionSpec methodsFor: 'enumerating' stamp: 'DaleHenrichs 11/12/2010 15:31'! specListProjectDo: projectBlock packageDo: packageBlock groupDo: groupBlock self packages specListDo: [:pkgSpec | pkgSpec projectDo: projectBlock packageDo: packageBlock groupDo: groupBlock ]! ! !MetacelloMCVersionSpec methodsFor: 'enumerating' stamp: 'DaleHenrichs 01/20/2010 15:50'! 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: 'loading' stamp: 'dkh 10/9/2009 13:03'! 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')! ! !MetacelloMCVersionSpec methodsFor: 'loading' stamp: 'DaleHenrichs 9/24/2010 14:50'! 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 ]. ! ! !MetacelloMCVersionSpec methodsFor: 'loading' stamp: 'dkh 6/18/2009 10:13'! repositorySpecs ^self repositories map values! ! !MetacelloMCVersionSpec methodsFor: 'loading' stamp: 'DaleHenrichs 2/5/2010 22:24'! resolveToLoadableSpec: aString forMap: map packages: packageMap | package | package := self packageNamed: aString forMap: map ifAbsent: [ ^self error: 'Name not found: ' , aString ]. packageMap at: package name put: package. ^ {package}! ! !MetacelloMCVersionSpec methodsFor: 'loading' stamp: 'DaleHenrichs 2/3/2010 15:42'! 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 map: map. ^map values! ! !MetacelloMCVersionSpec methodsFor: 'loading' stamp: 'dkh 2/26/2011 10:11'! resolveToLoadableSpecs: required 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 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 ]]! ! !MetacelloMCVersionSpec methodsFor: 'merging' stamp: 'dkh 10/9/2009 07:34'! mergeMap | map | map := super mergeMap. map at: #packages put: self packages. map at: #repositories put: self repositories. ^map! ! !MetacelloMCVersionSpec methodsFor: 'merging' stamp: 'dkh 9/23/2009 11:54'! mergeSpec: anotherSpec | newSpec map anotherPackages anotherRepositories | newSpec := super mergeSpec: anotherSpec. map := anotherSpec mergeMap. (anotherPackages := map at: #packages) isEmpty not ifTrue: [ newSpec packages: (self packages isEmpty ifTrue: [ anotherPackages ] ifFalse: [ self packages mergeSpec: anotherPackages ]) ]. (anotherRepositories := map at: #repositories) isEmpty not ifTrue: [ newSpec repositories: (self repositories isEmpty ifTrue: [ anotherRepositories ] ifFalse: [ self repositories mergeSpec: anotherRepositories ]) ]. ^newSpec! ! !MetacelloMCVersionSpec methodsFor: 'merging' stamp: 'dkh 9/23/2009 11:54'! nonOverridable ^super nonOverridable, #( packages repositories)! ! !MetacelloMCVersionSpec methodsFor: 'printing' stamp: 'DaleHenrichs 12/23/2010 13:48'! configMethodOn: aStream last: last indent: indent | spec hasRepositories hasPackageSpecs | hasRepositories := (spec := self repositoriesSpec) ~~ nil and: [ spec list isEmpty not ]. 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 ] ] ]. super configMethodOn: aStream 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: 'printing' stamp: 'dkh 10/6/2009 14:26'! 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 ]]]. ! ! !MetacelloMCVersionSpec methodsFor: 'printing' stamp: 'dkh 10/9/2009 20:40'! configSpawnMethodOn: aStream indent: indent super configSpawnMethodOn: aStream indent: indent. self configPackagesSpecMethodOn: aStream indent: indent.! ! !MetacelloMCVersionSpec methodsFor: 'querying' stamp: 'DaleHenrichs 11/20/2010 08:14'! 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: wc packageInfo classes ] ] groupDo: [ :ignored | ]. ^ classes! ! !MetacelloMCVersionSpec methodsFor: 'querying' stamp: 'dkh 5/12/2011 16:31'! currentlyLoadedExtensionClassesInVersion | classes | classes := Dictionary new. self projectDo: [ :ignored | ] packageDo: [ :packageSpec | | wc | wc := [ packageSpec workingCopy ] on: Error do: [ :ex | ex return: nil ]. wc ~~ nil ifTrue: [ wc packageInfo extensionClasses do: [:cl | classes at: cl put: (wc packageInfo extensionCategoriesForClass: cl)]] ] groupDo: [ :ignored | ]. ^ classes! ! !MetacelloMCVersionSpec methodsFor: 'querying' stamp: 'DaleHenrichs 1/14/2011 11:37'! difference: otherVersionSpec "Return a a dictionary of additions, removals and modifications" | report myProjectSpecs myPackageSpecs otherProjectSpecs otherPackageSpecs | report := MetacelloMCVersionDiffReport 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: 'querying' stamp: 'dkh 10/21/2009 13:55'! packageNamed: aString ^self packageNamed: aString ifAbsent: [ nil ]! ! !MetacelloMCVersionSpec methodsFor: 'querying' stamp: 'DaleHenrichs 1/21/2010 15:52'! packageNamed: aString forMap: map ifAbsent: aBlock | package | package := map at: aString ifAbsent: []. package == nil ifTrue: [ (aString = 'default' or: [ aString = 'ALL']) ifTrue: [ package := self project groupSpec name: aString; includes: self packageNames; yourself ] ifFalse: [ ^aBlock value ]]. ^package! ! !MetacelloMCVersionSpec methodsFor: 'querying' stamp: 'DaleHenrichs 1/21/2010 15:52'! packageNamed: aString ifAbsent: aBlock ^self packageNamed: aString forMap: self packages map ifAbsent: aBlock! ! !MetacelloMCVersionSpec methodsFor: 'querying' stamp: 'dkh 7/8/2011 09:51'! packageNames packages == nil ifTrue: [ ^#() ]. ^self packages map keys asSet ! ! !MetacelloMCVersionSpec methodsFor: 'querying' stamp: 'dkh 6/17/2009 16:06'! packageSpecsInLoadOrder ^self packages packageSpecsInLoadOrder! ! !MetacelloMCVersionSpec methodsFor: 'testing' stamp: 'dkh 07/12/2011 14:08'! isAllLoadedToSpec "all projects and packages are loaded and match specification" self isPartiallyCurrent isAllLoadedToSpec: [ :ignored | ^ true ]. ^ false! ! !MetacelloMCVersionSpec methodsFor: 'testing' stamp: 'dkh 7/11/2011 16:02'! isAllLoadedToSpecAgainst: resolvedPackageAndProjectNames "all projects and packages are loaded and match specification" (self isPartiallyCurrentAgainst: resolvedPackageAndProjectNames) isAllLoadedToSpec: [ :ignored | ^ true ]. ^ false! ! !MetacelloMCVersionSpec methodsFor: 'testing' stamp: 'dkh 07/12/2011 14:08'! isLoadedMatchConstraints "all loaded projects and packages match constraints (at least one package loaded)" self isPartiallyCurrent isLoadedMatchConstraints: [ :ignored | ^ true ]. ^ false! ! !MetacelloMCVersionSpec methodsFor: 'testing' stamp: 'dkh 7/11/2011 16:06'! isLoadedMatchConstraintsAgainst: resolvedPackageAndProjectNames "all loaded projects and packages match constraints (at least one package loaded)" (self isPartiallyCurrentAgainst: resolvedPackageAndProjectNames) isLoadedMatchConstraints: [ :ignored | ^ true ]. ^ false! ! !MetacelloMCVersionSpec methodsFor: 'testing' stamp: 'dkh 07/12/2011 14:08'! isLoadedToSpec "all loaded projects and packages match specifications (at least one package loaded)" self isPartiallyCurrent isLoadedToSpec: [ :ignored | ^ true ]. ^ false! ! !MetacelloMCVersionSpec methodsFor: 'testing' stamp: 'dkh 07/12/2011 14:07'! isLoadedToSpecAgainst: resolvedPackageAndProjectNames "all loaded projects and packages match specifications (at least one package loaded)" (self isPartiallyCurrentAgainst: resolvedPackageAndProjectNames) isLoadedToSpec: [ :ignored | ^ true ]. ^ false! ! !MetacelloMCVersionSpec methodsFor: 'testing' stamp: 'dkh 7/8/2011 14:45'! isPartiallyCurrent ^self isPartiallyCurrentAgainst: (self expandToLoadableSpecNames: #('ALL'))! ! !MetacelloMCVersionSpec methodsFor: 'testing' stamp: 'dkh 7/11/2011 15:43'! 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: 'DaleHenrichs 1/21/2010 13:26'! isPossibleBaseline self projectDo: [:prj | prj isPossibleBaseline ifFalse: [ ^false ]] packageDo: [:pkg | pkg isPackageLoaded ifFalse: [ ^false ]] groupDo: [:ignored | ]. ^true! ! !MetacelloMCVersionSpec methodsFor: 'testing' stamp: 'dkh 07/12/2011 14:08'! isSomethingLoaded "at least one package loaded" self isPartiallyCurrent isSomethingLoaded: [ :ignored | ^ true ]. ^ false! ! !MetacelloMCVersionSpec methodsFor: 'testing' stamp: 'dkh 07/12/2011 14:07'! isSomethingLoadedAgainst: resolvedPackageAndProjectNames "at least one package loaded" (self isPartiallyCurrentAgainst: resolvedPackageAndProjectNames) isSomethingLoaded: [ :ignored | ^ true ]. ^ false ! ! !MetacelloMCVersionSpec methodsFor: 'private' stamp: 'dkh 10/7/2009 14:45'! versionClass ^MetacelloMCVersion! ! Object subclass: #MetacelloMCVersionSpecLoader instanceVariableNames: 'versionSpec required packages loader loaderPolicy' classVariableNames: '' poolDictionaries: '' category: 'Metacello-MC-Loaders'! !MetacelloMCVersionSpecLoader methodsFor: 'accessing' stamp: 'DaleHenrichs 3/10/2010 11:19'! label ^self versionSpec label! ! !MetacelloMCVersionSpecLoader methodsFor: 'accessing' stamp: 'DaleHenrichs 3/6/2010 08:41'! loader loader == nil ifTrue: [ loader := self versionSpec loader copy. loader spec: self. loaderPolicy notNil ifTrue: [ loader loaderPolicy: loaderPolicy] ]. ^loader! ! !MetacelloMCVersionSpecLoader methodsFor: 'accessing' stamp: 'DaleHenrichs 3/6/2010 08:41'! loaderPolicy ^ loaderPolicy! ! !MetacelloMCVersionSpecLoader methodsFor: 'accessing' stamp: 'DaleHenrichs 3/6/2010 08:41'! loaderPolicy: anObject loaderPolicy := anObject! ! !MetacelloMCVersionSpecLoader methodsFor: 'accessing' stamp: 'dkh 07/03/2009 10:12'! name ^self versionSpec name! ! !MetacelloMCVersionSpecLoader methodsFor: 'accessing' stamp: 'dkh 08/10/2009 15:13'! operator ^self loader operator! ! !MetacelloMCVersionSpecLoader methodsFor: 'accessing' stamp: 'DaleHenrichs 3/11/2010 23:46'! packages ^packages! ! !MetacelloMCVersionSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/12/2009 14:20'! project ^self versionSpec project! ! !MetacelloMCVersionSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/9/2009 11:13'! required required == nil ifTrue: [ ^#() ]. ^ required! ! !MetacelloMCVersionSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2009 16:57'! required: anObject required := anObject! ! !MetacelloMCVersionSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2009 16:55'! versionSpec ^ versionSpec! ! !MetacelloMCVersionSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/8/2009 16:55'! versionSpec: anObject versionSpec := anObject! ! !MetacelloMCVersionSpecLoader methodsFor: 'loading' stamp: 'DaleHenrichs 10/25/2010 15:32'! 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: 'loading' stamp: 'dkh 6/18/2009 11:04'! repositories ^self repositorySpecs! ! !MetacelloMCVersionSpecLoader methodsFor: 'loading' stamp: 'dkh 10/3/2009 19:54'! resolvePackageNames packages := Dictionary new. self resolveToLoadableSpecs. ^packages values collect: [:pkg | pkg name ]! ! !MetacelloMCVersionSpecLoader methodsFor: 'spec compatibility' stamp: 'dkh 8/13/2009 00:37'! packageSpecsInLoadOrder | loadOrder packageNames | loadOrder := self versionSpec packages ~~ nil ifTrue: [ self versionSpec packages packageSpecsInLoadOrder ] ifFalse: [ OrderedCollection new ]. packageNames := packages values collect: [:pkg | pkg name ]. ^loadOrder select: [:pkg | packageNames includes: pkg name ]! ! !MetacelloMCVersionSpecLoader methodsFor: 'spec compatibility' stamp: 'dkh 1/12/2010 17:25'! repositorySpecs | repositoryMap | repositoryMap := self versionSpec repositories ~~ nil ifTrue: [ self versionSpec repositories map ] ifFalse: [ Dictionary new ]. ^repositoryMap values.! ! !MetacelloMCVersionSpecLoader methodsFor: 'spec compatibility' stamp: 'DaleHenrichs 3/11/2010 17:49'! versionString ^self versionSpec versionString! ! !MetacelloMCVersionSpecLoader methodsFor: 'private' stamp: 'DaleHenrichs 1/19/2010 11:57'! resolveToLoadableSpecs self versionSpec resolveToLoadableSpecs: required map: packages! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MetacelloMCVersionSpecLoader class instanceVariableNames: ''! !MetacelloMCVersionSpecLoader class methodsFor: 'instance creation' stamp: 'dkh 6/18/2009 09:53'! on: aVersionSpec ^(self new) versionSpec: aVersionSpec; yourself! ! MetacelloVersionValidator subclass: #MetacelloMCVersionValidator instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Metacello-MC-Validation'! !MetacelloMCVersionValidator commentStamp: '' prior: 0! 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] #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: 'loading' stamp: 'DaleHenrichs 12/7/2010 02:49'! 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: 'loading' stamp: 'DaleHenrichs 12/7/2010 02:55'! 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: 'DaleHenrichs 12/17/2010 14:39'! 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: 'DaleHenrichs 12/7/2010 02:54'! 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: 'loading' stamp: 'DaleHenrichs 12/5/2010 10:08'! 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: 'validation' stamp: 'DaleHenrichs 12/4/2010 08:45'! 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 or: [ projectSpec resolveProjectSpec repository == nil ]) ifTrue: [ self recordValidationError: 'Missing required fields (className: and/or repository:) for project reference ' , projectSpec name printString , ' in version ' , versionSpec versionString printString versionString: versionSpec versionString callSite: #validateBaselineVersionSpec: reasonCode: #incompleteProjectSpec ] ifFalse: [ (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) ] ] ]. 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: 'private' stamp: 'DaleHenrichs 11/30/2010 11:46'! criticalWarningReasonCodes ^ super criticalWarningReasonCodes , #(#noLoadableVersions #noTests #testDeprecation #loadDeprecation #noVersionSpecified)! ! !MetacelloMCVersionValidator methodsFor: 'private' stamp: 'DaleHenrichs 11/20/2010 07:25'! errorReasonCodes ^ super errorReasonCodes, #(#loadError #testFailures )! ! !MetacelloMCVersionValidator methodsFor: 'private' stamp: 'dkh 07/21/2011 15:40'! 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. referencedProjectSpec projectPackage == nil ifTrue: [ 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 ] ifFalse: [ (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 ]. referencedProjectSpec ensureProjectLoaded. [ 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: 'private' stamp: 'DaleHenrichs 11/30/2010 13:52'! 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 methodsFor: 'private' stamp: 'DaleHenrichs 12/4/2010 10:32'! warningReasonCodes ^ super warningReasonCodes, #(#loadWarning #notDevelopmentVersion #stableDevelopmentVersion)! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MetacelloMCVersionValidator class instanceVariableNames: ''! !MetacelloMCVersionValidator class methodsFor: 'instance creation' stamp: 'DaleHenrichs 11/19/2010 14:17'! validateConfigurationLoad: configurationClass ^ ((self new) configurationClass: configurationClass; yourself) validateProjectLoad! ! !MetacelloMCVersionValidator class methodsFor: 'instance creation' stamp: 'DaleHenrichs 12/7/2010 02:48'! validateConfigurationLoad: configurationClass version: versionString ^self validateConfigurationLoad: configurationClass version: versionString loads: #() ! ! !MetacelloMCVersionValidator class methodsFor: 'instance creation' stamp: 'DaleHenrichs 12/7/2010 02:45'! validateConfigurationLoad: configurationClass version: versionString loads: loadList ^ ((self new) configurationClass: configurationClass; yourself) validateProjectVersionLoad: versionString loads: loadList! ! !MetacelloMCVersionValidator class methodsFor: 'private' stamp: 'DaleHenrichs 1/24/2011 12:41'! populateReasonCodeDescriptions | dict | dict := super populateReasonCodeDescriptions. "Warnings" dict at: #notDevelopmentVersion put: 'the symbolic version #development refers to a non-development literal version.'. dict at: #loadWarning put: 'Warning signalled during load [load validation].'. dict at: #stableDevelopmentVersion put: 'a version whose blessing is #development has been declared as a #stable version.'. "Critical Warnings" dict at: #loadDeprecation put: 'deprecation warning signalled while loading configuration [load validation].'. dict at: #noLoadableVersions put: 'no non #baseline versions defined in configuration.'. dict at: #noTests put: 'no test cases defined in loaded configuration [load validation].'. dict 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.'. dict at: #testDeprecation put: 'deprecation warning signalled while running configuration tests [load validation].'. "Errors" dict at: #loadError put: 'error occured while loading configuration [load validation].'. dict at: #testFailures put: 'test failures while running tests [load validation].'. ^dict! ! MetacelloSpec subclass: #MetacelloMemberListSpec instanceVariableNames: 'list memberMap' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Members'! !MetacelloMemberListSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! list list == nil ifTrue: [ list := OrderedCollection new ]. ^list! ! !MetacelloMemberListSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! list: aCollection list := aCollection. self clearMemberMap! ! !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: 'actions' stamp: 'dkh 6/5/2012 19:01:24'! add: aSpec self subclassResponsibility! ! !MetacelloMemberListSpec methodsFor: 'actions' stamp: 'dkh 6/5/2012 19:01:24'! copy: aMemberSpec self addMember: aMemberSpec! ! !MetacelloMemberListSpec methodsFor: 'actions' stamp: 'dkh 6/5/2012 19:01:24'! copy: specNamed to: aSpec self subclassResponsibility! ! !MetacelloMemberListSpec methodsFor: 'actions' stamp: 'dkh 6/5/2012 19:01:24'! merge: aSpec self subclassResponsibility! ! !MetacelloMemberListSpec methodsFor: 'actions' stamp: 'dkh 6/5/2012 19:01:24'! remove: aSpec self subclassResponsibility! ! !MetacelloMemberListSpec methodsFor: 'adding' stamp: 'dkh 6/5/2012 19:01:24'! addMember: aMember self list add: aMember. self clearMemberMap ! ! !MetacelloMemberListSpec methodsFor: 'copying' stamp: 'dkh 6/5/2012 19:01:24'! postCopy super postCopy. list := list copy. self clearMemberMap! ! !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'! 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: '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'! do: aBlock self map values do: aBlock! ! !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'! 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.' ]! ! !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: '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: 'testing' stamp: 'dkh 6/5/2012 19:01:24'! isEmpty ^self list isEmpty! ! !MetacelloMemberListSpec methodsFor: 'testing' stamp: 'dkh 6/5/2012 19:01:24'! notEmpty ^self list notEmpty! ! !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'! clearMemberMap memberMap := nil.! ! !MetacelloMemberListSpec methodsFor: 'private' stamp: 'dkh 6/5/2012 19:01:24'! mapAdd: aMemberSpec into: map map at: aMemberSpec name put: aMemberSpec spec! ! !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: [ map at: aMemberSpec name put: (spec copy mergeSpec: aMemberSpec spec copy)]! ! !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: 'private' stamp: 'dkh 6/5/2012 19:01:24'! mapRemove: aMemberSpec into: map map removeKey: aMemberSpec name ifAbsent: []! ! MetacelloSpec subclass: #MetacelloMemberSpec instanceVariableNames: 'name spec' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Members'! !MetacelloMemberSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/7/2009 18:14'! addToMetacelloPackages: aMetacelloPackagesSpec aMetacelloPackagesSpec addMember: self! ! !MetacelloMemberSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/7/2009 20:40'! addToMetacelloRepositories: aMetacelloRepositoriesSpec aMetacelloRepositoriesSpec addMember: self! ! !MetacelloMemberSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/7/2009 18:31'! mergeIntoMetacelloPackages: aMetacelloPackagesSpec aMetacelloPackagesSpec addMember: self! ! !MetacelloMemberSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/7/2009 20:41'! mergeIntoMetacelloRepositories: aMetacelloRepositoriesSpec aMetacelloRepositoriesSpec addMember: self ! ! !MetacelloMemberSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/7/2009 18:18'! removeFromMetacelloPackages: aMetacelloPackagesSpec aMetacelloPackagesSpec addMember: self! ! !MetacelloMemberSpec methodsFor: '*metacello-mc' stamp: 'dkh 6/7/2009 20:41'! removeFromMetacelloRepositories: aMetacelloRepositoriesSpec aMetacelloRepositoriesSpec addMember: self ! ! !MetacelloMemberSpec methodsFor: 'accessing' stamp: 'dkh 6/15/2009 10:27'! methodUpdateSelector ^self subclassResponsibility! ! !MetacelloMemberSpec methodsFor: 'accessing' stamp: 'dkh 06/02/2009 16:36'! name ^name! ! !MetacelloMemberSpec methodsFor: 'accessing' stamp: 'dkh 06/02/2009 16:36'! name: aString name := aString! ! !MetacelloMemberSpec methodsFor: 'accessing' stamp: 'dkh 10/4/2009 10:35'! sourceName ^self name! ! !MetacelloMemberSpec methodsFor: 'accessing' stamp: 'dkh 06/02/2009 16:50'! spec ^spec! ! !MetacelloMemberSpec methodsFor: 'accessing' stamp: 'dkh 06/02/2009 16:50'! spec: aMetacelloSpec spec := aMetacelloSpec! ! !MetacelloMemberSpec methodsFor: 'actions' stamp: 'dkh 10/4/2009 10:15'! applyAdd: addBlock copy: copyBlock merge: mergeBlock remove: removeBlock self subclassResponsibility ! ! !MetacelloMemberSpec methodsFor: 'actions' stamp: 'dkh 06/02/2009 18:25'! applyToList: aListSpec self subclassResponsibility! ! !MetacelloMemberSpec methodsFor: 'printing' stamp: 'dkh 10/5/2009 12:39'! configMethodCascadeOn: aStream last: lastCascade indent: indent self spec configMethodCascadeOn: aStream member: self last: lastCascade indent: indent! ! !MetacelloMemberSpec methodsFor: 'printing' stamp: 'dkh 10/26/2009 13:34'! configMethodOn: aStream indent: indent aStream nextPutAll: self class name asString, ' member: ('. self spec configMethodOn: aStream indent: indent. aStream nextPutAll: ')'.! ! MetacelloMemberSpec subclass: #MetacelloMergeMemberSpec instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Members'! !MetacelloMergeMemberSpec methodsFor: 'accessing' stamp: 'dkh 10/9/2009 11:43'! methodUpdateSelector ^#with:! ! !MetacelloMergeMemberSpec methodsFor: 'actions' stamp: 'dkh 10/4/2009 10:16'! applyAdd: addBlock copy: copyBlock merge: mergeBlock remove: removeBlock mergeBlock value: self ! ! !MetacelloMergeMemberSpec methodsFor: 'actions' stamp: 'dkh 6/5/2009 16:06'! applyToList: aListSpec aListSpec merge: self! ! Object subclass: #MetacelloMethodSection instanceVariableNames: 'attributes' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Constructors'! !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 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: 'accessing' stamp: 'dkh 9/7/2012 06:42'! attributes attributes ifNil: [ attributes := OrderedCollection new ]. ^ attributes! ! !MetacelloMethodSection methodsFor: 'accessing' stamp: 'dkh 9/8/2012 05:41'! attributes: aCollectionOrSymbol attributes := aCollectionOrSymbol asMetacelloAttributeList! ! !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: 'testing' stamp: 'dkh 9/13/2012 19:12'! includesAttributeFrom: attributeCollection ^ (attributeCollection asSet intersection: self attributes asSet) notEmpty! ! Array variableSubclass: #MetacelloMethodSectionPath instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Constructors'! !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! ! Object subclass: #MetacelloMethodSpec instanceVariableNames: 'project selector category versionString methodSections' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Constructors'! !MetacelloMethodSpec methodsFor: 'accessing' stamp: 'DaleHenrichs 11/14/2010 01:21'! category ^ category! ! !MetacelloMethodSpec methodsFor: 'accessing' stamp: 'DaleHenrichs 11/14/2010 01:21'! category: anObject category := anObject! ! !MetacelloMethodSpec methodsFor: 'accessing' stamp: 'DaleHenrichs 11/14/2010 01:36'! methodSections methodSections == nil ifTrue: [ methodSections := OrderedCollection new ]. ^ methodSections! ! !MetacelloMethodSpec methodsFor: 'accessing' stamp: 'DaleHenrichs 11/14/2010 01:35'! methodSections: anObject methodSections := anObject! ! !MetacelloMethodSpec methodsFor: 'accessing' stamp: 'DaleHenrichs 11/14/2010 01:51'! project ^ project! ! !MetacelloMethodSpec methodsFor: 'accessing' stamp: 'DaleHenrichs 11/14/2010 01:51'! project: anObject project := anObject! ! !MetacelloMethodSpec methodsFor: 'accessing' stamp: 'DaleHenrichs 11/14/2010 00:45'! selector ^ selector! ! !MetacelloMethodSpec methodsFor: 'accessing' stamp: 'DaleHenrichs 11/14/2010 00:45'! selector: anObject selector := anObject! ! !MetacelloMethodSpec methodsFor: 'accessing' stamp: 'DaleHenrichs 11/14/2010 00:46'! versionString ^ versionString! ! !MetacelloMethodSpec methodsFor: 'accessing' stamp: 'DaleHenrichs 11/19/2010 10:36'! versionString: aStringOrSymbol versionString := aStringOrSymbol! ! !MetacelloMethodSpec methodsFor: 'method generation' stamp: 'DaleHenrichs 11/14/2010 01:47'! compileMethod (project configuration class compile: self methodSource classified: self category) == nil ifTrue: [ self error: 'Error compiling the method' ]! ! !MetacelloMethodSpec methodsFor: 'method generation' stamp: 'DaleHenrichs 11/14/2010 01:44'! methodSource self subclassResponsibility! ! MetacelloFetchingMCSpecLoader subclass: #MetacelloNullRecordingMCSpecLoader instanceVariableNames: 'afterLoads beforeLoads evalDoits' classVariableNames: '' poolDictionaries: '' category: 'Metacello-MC-Loaders'! !MetacelloNullRecordingMCSpecLoader methodsFor: 'accessing' stamp: 'DaleHenrichs 3/11/2010 16:33'! actionLabel ^'Recording '! ! !MetacelloNullRecordingMCSpecLoader methodsFor: 'accessing' stamp: 'DaleHenrichs 3/10/2010 14:50'! afterLoads afterLoads == nil ifTrue: [ afterLoads := OrderedCollection new ]. ^afterLoads! ! !MetacelloNullRecordingMCSpecLoader methodsFor: 'accessing' stamp: 'DaleHenrichs 3/10/2010 14:50'! beforeLoads beforeLoads == nil ifTrue: [ beforeLoads := OrderedCollection new ]. ^beforeLoads! ! !MetacelloNullRecordingMCSpecLoader methodsFor: 'accessing' stamp: 'DaleHenrichs 3/10/2010 15:43'! evalDoits evalDoits == nil ifTrue: [ evalDoits := false ]. ^evalDoits ! ! !MetacelloNullRecordingMCSpecLoader methodsFor: 'accessing' stamp: 'DaleHenrichs 3/10/2010 14:46'! evalDoits: aBool evalDoits := aBool! ! !MetacelloNullRecordingMCSpecLoader methodsFor: 'accessing' stamp: 'DaleHenrichs 3/11/2010 13:45'! loadedPackages | packages | packages := OrderedCollection new. self loadDirective packageDirectivesDo: [:directive | packages add: directive file ]. ^packages! ! !MetacelloNullRecordingMCSpecLoader methodsFor: 'accessing' stamp: 'DaleHenrichs 4/21/2010 11:56'! loadedRepositories | repos | repos := OrderedCollection new. self repositoryMap values collect: [:coll | repos addAll: coll ]. ^repos! ! !MetacelloNullRecordingMCSpecLoader methodsFor: 'accessing' stamp: 'DaleHenrichs 4/9/2010 12:23'! loadingSpecLoader ^self! ! !MetacelloNullRecordingMCSpecLoader methodsFor: 'accessing' stamp: 'DaleHenrichs 3/11/2010 13:46'! packages | packages | packages := OrderedCollection new. self loadDirective packageDirectivesDo: [:directive | packages add: directive spec ]. ^packages! ! !MetacelloNullRecordingMCSpecLoader methodsFor: 'accessing' stamp: 'DaleHenrichs 3/11/2010 10:01'! recordingSpecLoader ^self! ! !MetacelloNullRecordingMCSpecLoader methodsFor: 'actions' stamp: 'DaleHenrichs 3/10/2010 14:46'! doingLoads: aBlock "escape mechanism for recording and null loaders to skip doing loaderlike things" ! ! !MetacelloNullRecordingMCSpecLoader methodsFor: 'actions' stamp: 'DaleHenrichs 4/9/2010 12:33'! 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: 'actions' stamp: 'DaleHenrichs 4/9/2010 12:08'! loadPackageDirective: aPackageLoadDirective gofer: aGofer "Noop"! ! !MetacelloNullRecordingMCSpecLoader methodsFor: 'actions' stamp: 'DaleHenrichs 4/9/2010 12:12'! loadPackageDirectives: pkgLoads gofer: aGofer "Noop"! ! !MetacelloNullRecordingMCSpecLoader methodsFor: 'doits' stamp: 'DaleHenrichs 4/8/2010 16:11'! postLoad: packageOrVersionSpec self evalDoits ifFalse: [ ^self ]. packageOrVersionSpec postLoadDoItBlock ~~ nil ifTrue: [ self afterLoads add: packageOrVersionSpec name, ' load' ]. super postLoad: packageOrVersionSpec! ! !MetacelloNullRecordingMCSpecLoader methodsFor: 'doits' stamp: 'DaleHenrichs 4/8/2010 16:10'! preLoad: packageOrVersionSpec self evalDoits ifFalse: [ ^self ]. packageOrVersionSpec preLoadDoItBlock ~~ nil ifTrue: [ self beforeLoads add: packageOrVersionSpec name, ' load' ]. super preLoad: packageOrVersionSpec! ! !MetacelloNullRecordingMCSpecLoader methodsFor: 'testing' stamp: 'DaleHenrichs 3/11/2010 17:18'! ensureForDevelopment ^false! ! !MetacelloNullRecordingMCSpecLoader methodsFor: 'versionInfo' stamp: 'dkh 08/10/2009 16:39'! currentVersionInfoFor: packageSpec ^self loadData currentVersionInfoFor: packageSpec ifAbsent: [ nil ] ! ! !MetacelloNullRecordingMCSpecLoader methodsFor: 'private' stamp: 'dkh 4/6/2011 22:35'! 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: 'private' stamp: 'DaleHenrichs 03/12/2010 15:01'! 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! ! MetacelloDirective subclass: #MetacelloPackageLoadDirective instanceVariableNames: 'resolvedReference externalReference' classVariableNames: '' poolDictionaries: '' category: 'Metacello-MC-Directives'! !MetacelloPackageLoadDirective methodsFor: 'accessing' stamp: 'DaleHenrichs 3/9/2010 16:42'! externalReference ^ externalReference! ! !MetacelloPackageLoadDirective methodsFor: 'accessing' stamp: 'DaleHenrichs 3/9/2010 16:39'! file ^self externalReference name! ! !MetacelloPackageLoadDirective methodsFor: 'accessing' stamp: 'DaleHenrichs 3/12/2010 09:29'! packageName ^self externalReference packageName! ! !MetacelloPackageLoadDirective methodsFor: 'accessing' stamp: 'DaleHenrichs 3/9/2010 16:39'! repository ^self externalReference repository! ! !MetacelloPackageLoadDirective methodsFor: 'accessing' stamp: 'DaleHenrichs 3/9/2010 15:24'! resolvedReference ^ resolvedReference! ! !MetacelloPackageLoadDirective methodsFor: 'accessing' stamp: 'DaleHenrichs 3/9/2010 15:24'! resolvedReference: anObject resolvedReference := anObject! ! !MetacelloPackageLoadDirective methodsFor: 'accessing' stamp: 'DaleHenrichs 3/9/2010 16:35'! title ^'load'! ! !MetacelloPackageLoadDirective methodsFor: 'actions' stamp: 'DaleHenrichs 3/9/2010 14:58'! loadUsing: aLoaderDirective gofer: aGofer aLoaderDirective loadPackageDirective: self gofer: aGofer! ! !MetacelloPackageLoadDirective methodsFor: 'enumerating' stamp: 'DaleHenrichs 3/11/2010 21:09'! packageDirectivesDo: aBlock aBlock value: self! ! !MetacelloPackageLoadDirective methodsFor: 'enumerating' stamp: 'DaleHenrichs 3/11/2010 13:55'! packageDo: aBlock aBlock value: self! ! !MetacelloPackageLoadDirective methodsFor: 'initialize-release' stamp: 'DaleHenrichs 3/9/2010 16:41'! spec: aPackageSpec externalReference: anExternalReference loader: aLoader super spec: aPackageSpec loader: aLoader. externalReference := anExternalReference! ! !MetacelloPackageLoadDirective methodsFor: 'printing' stamp: 'DaleHenrichs 3/9/2010 16:36'! label ^self file! ! MetacelloAbstractPackageSpec subclass: #MetacelloPackageSpec instanceVariableNames: 'file repositories goferPackage preLoadDoIt postLoadDoIt' classVariableNames: '' poolDictionaries: '' category: 'Metacello-MC-Specs'! !MetacelloPackageSpec methodsFor: 'accessing' stamp: 'dkh 06/03/2009 12:11'! file: aString file := aString! ! !MetacelloPackageSpec methodsFor: 'accessing' stamp: 'dkh 10/30/2009 10:37'! getFile "raw access to iv" ^file! ! !MetacelloPackageSpec methodsFor: 'accessing' stamp: 'dkh 1/13/2010 17:04'! goferLoaderReference ^file == nil ifTrue: [ GoferPackageReference name: self name ] ifFalse: [ "does Monticello-style #versionInfoFromVersionNamed: matching" MetacelloGoferPackage name: self name packageFilename: self file ]! ! !MetacelloPackageSpec methodsFor: 'accessing' stamp: 'dkh 12/15/2009 10:32'! goferPackage goferPackage == nil ifTrue: [ goferPackage := MetacelloGoferPackage name: self name packageFilename: self file ]. ^goferPackage! ! !MetacelloPackageSpec methodsFor: 'accessing' stamp: 'dkh 1/6/2010 17:58'! info "test compatibility method" ^self! ! !MetacelloPackageSpec methodsFor: 'accessing' stamp: 'DaleHenrichs 12/21/2010 13:57'! postLoadDoIt: anObject anObject setPostLoadDoItInMetacelloSpec: self! ! !MetacelloPackageSpec methodsFor: 'accessing' stamp: 'DaleHenrichs 12/21/2010 13:57'! preLoadDoIt: anObject anObject setPreLoadDoItInMetacelloSpec: self! ! !MetacelloPackageSpec methodsFor: 'accessing' stamp: 'dkh 1/2/2010 15:44'! repository: aStringOrMetacelloRepositorySpec self repositories repository: aStringOrMetacelloRepositorySpec! ! !MetacelloPackageSpec methodsFor: 'accessing' stamp: 'dkh 1/2/2010 15:47'! repository: aString username: username password: password self repositories repository: aString username: username password: password! ! !MetacelloPackageSpec methodsFor: 'accessing' stamp: 'DaleHenrichs 12/21/2010 13:53'! setPostLoadDoIt: aSymbol postLoadDoIt := aSymbol! ! !MetacelloPackageSpec methodsFor: 'accessing' stamp: 'DaleHenrichs 12/21/2010 13:53'! setPreLoadDoIt: aSymbol preLoadDoIt := aSymbol! ! !MetacelloPackageSpec methodsFor: 'copying' stamp: 'dkh 1/2/2010 15:46'! postCopy super postCopy. goferPackage := nil. repositories := repositories copy. ! ! !MetacelloPackageSpec methodsFor: 'development support' stamp: 'DaleHenrichs 12/6/2010 13:14'! 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: 'DaleHenrichs 11/12/2010 06:33'! forceUpdatePackageSpec: updatedSpecs using: anMCLoader self updatePackageSpec: updatedSpecs force: true using: anMCLoader! ! !MetacelloPackageSpec methodsFor: 'development support' stamp: 'dkh 4/17/2011 14:41'! 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: 'DaleHenrichs 3/15/2010 11:38'! 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: 'development support' stamp: 'dkh 12/22/2009 10:17'! packagesNeedSavingVisited: visitedProjects using: repos into: aCollection ^self loader packagesNeedSavingUsing: repos into: aCollection! ! !MetacelloPackageSpec methodsFor: 'development support' stamp: 'DaleHenrichs 3/15/2010 11:35'! 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: 'development support' stamp: 'DaleHenrichs 11/16/2010 16:31'! 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: 'development support' stamp: 'dkh 01/14/2010 12:57'! 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 11/01/2009 11:15'! 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: 'development support' stamp: 'DaleHenrichs 11/12/2010 14:56'! 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: 'development support' stamp: 'DaleHenrichs 11/12/2010 06:33'! 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: 'gofer' stamp: 'dkh 3/20/2011 17:45'! ancestors ^self goferPackage ancestors! ! !MetacelloPackageSpec methodsFor: 'gofer' stamp: 'dkh 9/25/2009 11:26'! currentVersionInfo ^self goferPackage currentVersionInfo! ! !MetacelloPackageSpec methodsFor: 'gofer' stamp: 'dkh 9/25/2009 10:53'! workingCopy ^self goferPackage workingCopy! ! !MetacelloPackageSpec methodsFor: 'gofer' stamp: 'dkh 11/05/2009 13:58'! workingCopyName | wc | (wc := self workingCopy) == nil ifTrue: [ ^nil ]. wc ancestry ancestors isEmpty not ifTrue: [ ^wc ancestry ancestors first name ]. ^nil! ! !MetacelloPackageSpec methodsFor: 'gofer' stamp: 'dkh 9/25/2009 10:52'! workingCopyNameFor: anMCLoader | vi | (vi := anMCLoader currentVersionInfoFor: self) == nil ifTrue: [ ^nil ]. ^vi name! ! !MetacelloPackageSpec methodsFor: 'loading' stamp: 'DaleHenrichs 3/5/2010 19:05'! ensureLoadedForDevelopmentUsing: mcLoader "noop" ^true! ! !MetacelloPackageSpec methodsFor: 'loading' stamp: 'dkh 11/16/2011 14:13'! 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: 'loading' stamp: 'DaleHenrichs 3/7/2010 09:36'! fetch self fetchUsing: self loader! ! !MetacelloPackageSpec methodsFor: 'loading' stamp: 'DaleHenrichs 4/12/2010 13:57'! fetchPackage: aLoaderPolicy self fetchUsing: (self loader loaderPolicy: aLoaderPolicy; yourself)! ! !MetacelloPackageSpec methodsFor: 'loading' stamp: 'DaleHenrichs 3/7/2010 09:38'! fetchUsing: mcLoader | fetchingSpecLoader | fetchingSpecLoader := mcLoader fetchingSpecLoader. fetchingSpecLoader linearLoadPackageSpecs: (Array with: self) repositories: (fetchingSpecLoader repositoriesFrom: self repositorySpecs). ! ! !MetacelloPackageSpec methodsFor: 'loading' stamp: 'DaleHenrichs 3/6/2010 10:28'! load self explicitLoadUsing: self loader! ! !MetacelloPackageSpec methodsFor: 'loading' stamp: 'DaleHenrichs 3/10/2010 12:32'! loadUsing: mcLoader self loader doingLoads: [ self explicitLoadUsing: mcLoader ] ! ! !MetacelloPackageSpec methodsFor: 'loading' stamp: 'DaleHenrichs 4/9/2010 12:29'! loadUsing: aLoader gofer: gofer ^aLoader linearLoadPackageSpec: self gofer: gofer! ! !MetacelloPackageSpec methodsFor: 'loading' stamp: 'dkh 6/8/2009 16:16'! packageSpecsInLoadOrder ^{ self. }! ! !MetacelloPackageSpec methodsFor: 'loading' stamp: 'dkh 1/2/2010 15:43'! repositorySpecs ^self repositories map values ! ! !MetacelloPackageSpec methodsFor: 'merging' stamp: 'DaleHenrichs 1/21/2010 20:37'! 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: 'merging' stamp: 'Dalehenrichs 02/10/2010 10:54'! 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: 'merging' stamp: 'dkh 1/2/2010 16:29'! nonOverridable ^super nonOverridable, #( repositories)! ! !MetacelloPackageSpec methodsFor: 'printing' stamp: 'DaleHenrichs 1/14/2011 15:02'! 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: 'printing' stamp: 'dkh 10/7/2009 09:36'! 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: 'printing' stamp: 'DaleHenrichs 12/21/2010 13:46'! 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 ]! ! !MetacelloPackageSpec methodsFor: 'printing' stamp: 'DaleHenrichs 12/21/2010 13:46'! 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 10/6/2009 15:12'! file file == nil ifTrue: [ ^self name ]. ^file ! ! !MetacelloPackageSpec methodsFor: 'querying' stamp: 'DaleHenrichs 12/21/2010 13:44'! getPostLoadDoIt ^postLoadDoIt! ! !MetacelloPackageSpec methodsFor: 'querying' stamp: 'DaleHenrichs 12/21/2010 13:44'! getPreLoadDoIt ^preLoadDoIt! ! !MetacelloPackageSpec methodsFor: 'querying' stamp: 'dkh 5/14/2010 15:50'! isPackageLoaded ^self isPackageLoaded: self loader! ! !MetacelloPackageSpec methodsFor: 'querying' stamp: 'dkh 5/14/2010 15:50'! isPackageLoaded: aLoader ^(self workingCopyNameFor: aLoader) ~~ nil! ! !MetacelloPackageSpec methodsFor: 'querying' stamp: 'dkh 06/03/2009 12:13'! name name == nil ifTrue: [ name := self extractNameFromFile ]. ^name! ! !MetacelloPackageSpec methodsFor: 'querying' stamp: 'dkh 1/2/2010 15:35'! packageRepository self repositorySpecs isEmpty ifTrue: [ ^nil ]. ^self repositorySpecs first! ! !MetacelloPackageSpec methodsFor: 'querying' stamp: 'DaleHenrichs 1/21/2010 20:40'! postLoadDoIt ^postLoadDoIt! ! !MetacelloPackageSpec methodsFor: 'querying' stamp: 'DaleHenrichs 1/21/2010 20:40'! preLoadDoIt ^preLoadDoIt! ! !MetacelloPackageSpec methodsFor: 'querying' stamp: 'dkh 1/2/2010 15:41'! repositories repositories == nil ifTrue: [ repositories := self project repositoriesSpec ]. ^ repositories! ! !MetacelloPackageSpec methodsFor: 'querying' stamp: 'dkh 1/2/2010 15:41'! repositories: anObject repositories := anObject! ! !MetacelloPackageSpec methodsFor: 'querying' stamp: 'dkh 1/2/2010 15:46'! repository self deprecated: 'Use repositories or repositorySpecs'. ^self packageRepository! ! !MetacelloPackageSpec methodsFor: 'testing' stamp: 'DaleHenrichs 2/5/2010 11:36'! compareCurrentVersion: anOperator targetVersionStatus: statusIgnored using: anMCLoader self currentPackageLoaded: [:bool | ^bool ] comparing: anOperator notLoaded: [:ignored | ^false ] using: anMCLoader ! ! !MetacelloPackageSpec methodsFor: 'testing' stamp: 'DaleHenrichs 2/5/2010 14:03'! compareRelativeCurrentVersion: anOperator targetVersionStatus: statusIgnored using: anMCLoader ^self compareCurrentVersion: anOperator targetVersionStatus: statusIgnored using: anMCLoader ! ! !MetacelloPackageSpec methodsFor: 'testing' stamp: 'dkh 3/3/2011 07:56'! compareWorkingCopyNamed: wcName using: comarisonOperator | fileRef wcRef | fileRef := GoferResolvedReference name: self file. wcRef := GoferResolvedReference name: wcName. ^ wcRef compare: fileRef using: comarisonOperator! ! !MetacelloPackageSpec methodsFor: 'testing' stamp: 'dkh 3/20/2011 17:56'! 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 := GoferResolvedReference name: self file. wcRef := GoferResolvedReference name: wcName. (wcRef compare: fileRef using: comarisonOperator) ifTrue: [ ^ loadedBlock value: true ] ]. ^ loadedBlock value: false ]. ^ notLoadedBlock value: true! ! !MetacelloPackageSpec methodsFor: 'testing' stamp: 'dkh 7/8/2011 21:40'! 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: 'visiting' stamp: 'dkh 10/5/2009 09:39'! projectDo: projectBlock packageDo: packageBlock groupDo: groupBlock packageBlock value: self! ! !MetacelloPackageSpec methodsFor: 'visiting' stamp: 'dkh 10/21/2009 15:51'! visitingWithPackages: packages packages at: self name put: self! ! !MetacelloPackageSpec methodsFor: 'private' stamp: 'dkh 10/7/2009 01:09'! extractNameFromFile file == nil ifTrue: [ ^nil ]. ^(self loader nameComponentsFrom: self file) first! ! !MetacelloPackageSpec methodsFor: 'private' stamp: 'dkh 10/10/2009 11:00'! includesForPackageOrdering ^self includes! ! !MetacelloPackageSpec methodsFor: 'private' stamp: 'dkh 10/21/2009 15:22'! resolveToPackagesIn: aVersionSpec visited: visited ^{ self } ! ! MetacelloMemberListSpec subclass: #MetacelloPackagesSpec instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Specs'! !MetacelloPackagesSpec methodsFor: 'accessing' stamp: 'DaleHenrichs 7/23/2010 13: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: 'accessing' stamp: 'dkh 10/9/2009 13:01'! packageNamed: aString ifAbsent: aBlock ^self map at: aString ifAbsent: aBlock! ! !MetacelloPackagesSpec methodsFor: 'accessing' stamp: 'dkh 9/5/2012 05:46'! 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: 'DaleHenrichs 7/23/2010 13:27'! 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 ! ! !MetacelloPackagesSpec methodsFor: 'actions' stamp: 'dkh 10/4/2009 11:23'! add: aSpec aSpec addToMetacelloPackages: self! ! !MetacelloPackagesSpec methodsFor: 'actions' stamp: 'dkh 10/4/2009 11:22'! copy: specNamed to: spec self addMember: (self copyMember name: spec name; sourceName: specNamed; spec: spec; yourself) ! ! !MetacelloPackagesSpec methodsFor: 'actions' stamp: 'dkh 10/4/2009 11:23'! merge: aSpec aSpec mergeIntoMetacelloPackages: self! ! !MetacelloPackagesSpec methodsFor: 'actions' stamp: 'dkh 10/4/2009 11:23'! remove: aSpec aSpec removeFromMetacelloPackages: self! ! !MetacelloPackagesSpec methodsFor: 'printing' stamp: 'dkh 10/22/2009 10:33'! 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: 'private' stamp: 'dkh 10/10/2009 10:14'! 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! ! MetacelloPlatform subclass: #MetacelloPharoPlatform instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Platform'! !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: '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: 'notification' stamp: 'SeanDeNigris 6/27/2012 13:57'! do: aBlock displaying: aString self bypassProgressBars ifTrue: [ ^super do: aBlock displaying: aString ]. aString displayProgressFrom: 0 to: 2 during: [ :bar | bar current: 1. aBlock value. bar current: 2 ]! ! !MetacelloPharoPlatform methodsFor: 'reflection' stamp: 'DaleHenrichs 1/5/2011 16:26'! 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 := Compiler evaluate: newDefinition logged: true. 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: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: 'repository creation' stamp: 'dkh 12/7/2009 14:07'! extractTypeFromDescription: description (description beginsWith: 'ftp://') ifTrue: [ ^'ftp' ]. ^super extractTypeFromDescription: description! ! !MetacelloPharoPlatform methodsFor: 'utilities' stamp: 'dkh 10/7/2009 10:54'! authorName ^Author fullName! ! !MetacelloPharoPlatform methodsFor: 'utilities' stamp: 'DaleHenrichs 1/5/2011 16:59'! authorName: aString Author fullName: aString! ! !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 class instanceVariableNames: ''! !MetacelloPharoPlatform class methodsFor: 'initialize-release' stamp: 'dkh 8/20/2009 15:33'! initialize "implmented to force initialize on load" super initialize! ! Object subclass: #MetacelloPlatform instanceVariableNames: 'bypassProgressBars bypassGoferLoadUpdateCategories' classVariableNames: 'Current' poolDictionaries: '' category: 'Metacello-Core-Model'! !MetacelloPlatform methodsFor: 'accessing' stamp: 'DaleHenrichs 12/18/2010 13:37'! bypassGoferLoadUpdateCategories bypassGoferLoadUpdateCategories == nil ifTrue: [ bypassGoferLoadUpdateCategories := false ]. ^ bypassGoferLoadUpdateCategories! ! !MetacelloPlatform methodsFor: 'accessing' stamp: 'DaleHenrichs 12/18/2010 13:37'! bypassGoferLoadUpdateCategories: anObject bypassGoferLoadUpdateCategories := anObject! ! !MetacelloPlatform methodsFor: 'accessing' stamp: 'DaleHenrichs 3/11/2010 19:24'! bypassProgressBars bypassProgressBars == nil ifTrue: [ bypassProgressBars := false ]. ^ bypassProgressBars! ! !MetacelloPlatform methodsFor: 'accessing' stamp: 'DaleHenrichs 3/11/2010 19:24'! bypassProgressBars: anObject bypassProgressBars := anObject! ! !MetacelloPlatform methodsFor: 'attributes' stamp: 'dkh 9/8/2011 13:47'! 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" (versionString includesSubString: 'Pharo') ifTrue: [ ^ #(#squeakCommon #pharo ) ]. (versionString includesSubString: 'Squeak') ifTrue: [^ #(#squeakCommon #squeak )]. self error: 'Unrecognized version of Squeak/Pharo: ', versionString ]. ^ #(#gemstone )! ! !MetacelloPlatform methodsFor: 'caching' stamp: 'dkh 4/6/2011 23:14'! clearCurrentVersionCache MetacelloClearStackCacheNotification signal: #(#currentVersion #currentVersionAgainst: #currentVersionInfo)! ! !MetacelloPlatform methodsFor: 'caching' stamp: 'DaleHenrichs 9/22/2010 14:58'! 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: 'caching' stamp: 'DaleHenrichs 9/22/2010 14:26'! primeStackCacheWith: aDictionary doing: noArgBlock self useStackCacheDuring: [:dict | ^noArgBlock value ] defaultDictionary: aDictionary! ! !MetacelloPlatform methodsFor: 'caching' stamp: 'dkh 4/6/2011 22:44'! stackCacheFor: cacheName at: key doing: aBlock ^self stackCacheFor: cacheName cacheClass: Dictionary at: key doing: aBlock! ! !MetacelloPlatform methodsFor: 'caching' stamp: 'dkh 4/6/2011 22:41'! 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 4/6/2011 23: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: 'notification' stamp: 'DaleHenrichs 3/11/2010 19:26'! collection: aCollection do: aBlock displaying: aString aCollection do: aBlock! ! !MetacelloPlatform methodsFor: 'notification' stamp: 'DaleHenrichs 03/08/2010 13:31'! do: aBlock displaying: aString aBlock value! ! !MetacelloPlatform methodsFor: 'reflection' stamp: 'DaleHenrichs 11/18/2010 16:14'! copyClass: oldClass as: newName inCategory: newCategoryName self subclassResponsibility! ! !MetacelloPlatform methodsFor: 'reflection' stamp: 'dkh 1/16/2011 11:08'! globalNamed: globalName ^Smalltalk at: globalName! ! !MetacelloPlatform methodsFor: 'reflection' stamp: 'dkh 1/16/2011 11:08'! globalNamed: globalName ifAbsent: absentBlock ^Smalltalk at: globalName ifAbsent: absentBlock! ! !MetacelloPlatform methodsFor: 'repository creation' stamp: 'CamilloBruni 10/20/2012 22:59'! 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: aRepositorySpec description asFileReference ]. 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 ]]. ^ nil! ! !MetacelloPlatform methodsFor: 'repository creation' stamp: 'tbn 6/9/2010 13:56'! extractTypeFromDescription: description description == nil ifTrue: [ ^nil ]. ((description beginsWith: '/') or: [ description second = $:]) ifTrue: [ ^'directory' ]. (description beginsWith: 'dictionary://') ifTrue: [ ^'dictionary' ]. ^'http'! ! !MetacelloPlatform methodsFor: 'tests' stamp: 'dkh 6/7/2011 15:58'! defaultTimeout "squeak compatability" ^60! ! !MetacelloPlatform methodsFor: 'transactions' stamp: 'dkh 10/23/2009 11:59'! 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: 'user interaction' stamp: 'dkh 8/12/2009 17:51'! 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: 'utilities' stamp: 'dkh 10/28/2009 10:53'! authorName Smalltalk at: #Author ifPresent: [:cl | ^cl perform: #initials ]. ^'no developer initials'! ! !MetacelloPlatform methodsFor: 'utilities' stamp: 'dkh 1/5/2011 16:47'! authorName: aString "Primarily used for testing" self subclassResponsibility! ! !MetacelloPlatform methodsFor: 'utilities' stamp: 'dkh 10/7/2009 10:51'! timestamp ^DateAndTime now printString! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MetacelloPlatform class instanceVariableNames: ''! !MetacelloPlatform class methodsFor: 'accessing' stamp: 'dkh 7/24/2009 15:21'! current Current ifNil: [Current := MetacelloPlatform new]. ^ Current! ! !MetacelloPlatform class methodsFor: 'initialize-release' stamp: 'dkh 7/24/2009 15:29'! initialize "MetacelloPlatform initialize" "MetacelloGemStonePlatform initialize" "MetacelloPharoPlatform initialize" "MetacelloSqueakPlatform initialize" Current := self new! ! MetacelloPrePostLoadDirective subclass: #MetacelloPostLoadDirective instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Metacello-MC-Directives'! !MetacelloPostLoadDirective methodsFor: 'accessing' stamp: 'DaleHenrichs 3/9/2010 16:35'! title ^'postload'! ! !MetacelloPostLoadDirective methodsFor: 'actions' stamp: 'DaleHenrichs 12/21/2010 11:46'! addTo: aLoaderDirective spec postLoadDoIt value ~~ nil ifTrue: [ aLoaderDirective add: self ]! ! !MetacelloPostLoadDirective methodsFor: 'actions' stamp: 'DaleHenrichs 4/14/2010 14:30'! loadUsing: aLoaderDirective gofer: aGofer aLoaderDirective loadPostloadDirective: self. ! ! !MetacelloPostLoadDirective methodsFor: 'actions' stamp: 'DaleHenrichs 4/8/2010 16:15'! postLoadDo: aBlock aBlock value: self! ! !MetacelloPostLoadDirective methodsFor: 'printing' stamp: 'DaleHenrichs 12/21/2010 11:47'! label ^super label, ' >> ', self spec postLoadDoIt value asString! ! MetacelloPrePostLoadDirective subclass: #MetacelloPreLoadDirective instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Metacello-MC-Directives'! !MetacelloPreLoadDirective methodsFor: 'accessing' stamp: 'DaleHenrichs 3/9/2010 16:35'! title ^'preload'! ! !MetacelloPreLoadDirective methodsFor: 'actions' stamp: 'DaleHenrichs 12/21/2010 11:48'! addTo: aLoaderDirective spec preLoadDoIt value ~~ nil ifTrue: [ aLoaderDirective add: self ]! ! !MetacelloPreLoadDirective methodsFor: 'actions' stamp: 'DaleHenrichs 4/14/2010 14:30'! loadUsing: aLoaderDirective gofer: aGofer aLoaderDirective loadPreloadDirective: self. ! ! !MetacelloPreLoadDirective methodsFor: 'actions' stamp: 'DaleHenrichs 4/8/2010 16:16'! preLoadDo: aBlock aBlock value: self! ! !MetacelloPreLoadDirective methodsFor: 'printing' stamp: 'DaleHenrichs 12/21/2010 11:49'! label ^super label, ' >> ', self spec preLoadDoIt value asString! ! MetacelloDirective subclass: #MetacelloPrePostLoadDirective instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Metacello-MC-Directives'! !MetacelloPrePostLoadDirective methodsFor: 'actions' stamp: 'DaleHenrichs 4/9/2010 12:45'! evaluateSupplyingAnswers: loadBlock | answers | (answers := self spec answers) notEmpty ifTrue: [ loadBlock valueSupplyingMetacelloAnswers: answers ] ifFalse: [ loadBlock value]! ! !MetacelloPrePostLoadDirective methodsFor: 'enumerating' stamp: 'DaleHenrichs 4/8/2010 16:22'! prepostLoadDirectivesDo: aBlock aBlock value: self! ! !MetacelloPrePostLoadDirective methodsFor: 'enumerating' stamp: 'DaleHenrichs 4/8/2010 16:23'! prepostLoadDo: aBlock aBlock value: self! ! Object subclass: #MetacelloProject instanceVariableNames: 'versionMap symbolicVersionMap loader loaderClass loadType configuration projectAttributes' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Model'! !MetacelloProject methodsFor: 'accessing' stamp: 'tg 8/30/2009 17:48'! configuration ^ configuration! ! !MetacelloProject methodsFor: 'accessing' stamp: 'tg 8/30/2009 17:48'! configuration: anObject configuration := anObject! ! !MetacelloProject methodsFor: 'accessing' stamp: 'dkh 6/18/2009 12:52'! defaultBlessing ^#release! ! !MetacelloProject methodsFor: 'accessing' stamp: 'dkh 9/10/2009 15:14'! label ^self configuration class name! ! !MetacelloProject methodsFor: 'accessing' stamp: 'dkh 9/10/2009 13:27'! loadType "#atomic or #linear" loadType == nil ifTrue: [ ^#atomic ]. ^loadType! ! !MetacelloProject methodsFor: 'accessing' stamp: 'dkh 9/10/2009 13:27'! loadType: aSymbol "#atomic or #linear" loadType := aSymbol! ! !MetacelloProject methodsFor: 'accessing' stamp: 'dkh 6/24/2011 15:58'! map versionMap ifNil: [ ^ Dictionary new ]. ^ versionMap! ! !MetacelloProject methodsFor: 'accessing' stamp: 'dkh 10/3/2009 17:31'! map: aDictionary versionMap := aDictionary! ! !MetacelloProject methodsFor: 'accessing' stamp: 'dkh 9/2/2009 06:02'! project ^self! ! !MetacelloProject methodsFor: 'accessing' stamp: 'DaleHenrichs 9/23/2010 15:26'! symbolicVersionMap ^symbolicVersionMap ! ! !MetacelloProject methodsFor: 'accessing' stamp: 'DaleHenrichs 9/23/2010 15:26'! symbolicVersionMap: aDictionary symbolicVersionMap := aDictionary ! ! !MetacelloProject methodsFor: 'loading' stamp: 'dkh 9/10/2009 15:09'! load: aVersionString ^(self version: aVersionString) load ! ! !MetacelloProject methodsFor: 'printing' stamp: 'DaleHenrichs 12/7/2010 02:54'! 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: 'spec classes' stamp: 'dkh 6/9/2009 16:03'! defaultLoaderClass ^MetacelloSpecLoader! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'dkh 10/4/2009 12:17'! groupSpec ^self groupSpecClass for: self! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'dkh 10/4/2009 12:18'! groupSpecClass ^MetacelloGroupSpec! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'dkh 6/18/2009 10:10'! loader ^loader! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'dkh 6/18/2009 10:10'! loader: aLoader loader := aLoader! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'dkh 6/9/2009 16:04'! loaderClass loaderClass == nil ifTrue: [ loaderClass := self defaultLoaderClass ]. ^loaderClass! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'dkh 6/9/2009 16:05'! loaderClass: aMetacelloSpecLoader loaderClass := aMetacelloSpecLoader! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'dkh 10/4/2009 12:18'! packagesSpec ^self packagesSpecClass for: self! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'dkh 10/4/2009 12:18'! packagesSpecClass ^MetacelloPackagesSpec! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'dkh 10/4/2009 12:18'! projectReferenceSpec ^self projectReferenceSpecClass for: self! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'dkh 10/4/2009 12:18'! projectReferenceSpecClass ^MetacelloProjectReferenceSpec! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'dkh 06/01/2009 14:54'! projectSpec ^self projectSpecClass for: self! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'DaleHenrichs 10/27/2010 11:15'! projectSpecClass ^self subclassResponsibility! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'dkh 6/5/2009 11:47'! valueHolderSpec ^self valueHolderSpecClass for: self! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'dkh 6/5/2009 11:47'! valueHolderSpecClass ^MetacelloValueHolderSpec! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'dkh 06/01/2009 11:00'! versionSpec ^self versionSpecClass for: self! ! !MetacelloProject methodsFor: 'spec classes' stamp: 'dkh 6/4/2009 18:51'! versionSpecClass ^MetacelloVersionSpec! ! !MetacelloProject methodsFor: 'versions' stamp: 'DaleHenrichs 11/2/2010 13:20'! bleedingEdge ^self version: #bleedingEdge! ! !MetacelloProject methodsFor: 'versions' stamp: 'dkh 7/8/2011 19:56'! 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: 'versions' stamp: 'dkh 7/11/2011 16:19'! 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: 'DaleHenrichs 11/2/2010 16:58'! development ^self version: #development! ! !MetacelloProject methodsFor: 'versions' stamp: 'DaleHenrichs 11/12/2010 06:43'! hasVersion: versionString self version: versionString ifAbsent: [ ^false ]. ^true! ! !MetacelloProject methodsFor: 'versions' stamp: 'DaleHenrichs 01/24/2011 13:33'! lastVersion | coll | coll := (self map values asArray sort: [:a :b | a <= b ]) asOrderedCollection. coll isEmpty ifTrue: [ ^nil ]. ^coll last! ! !MetacelloProject methodsFor: 'versions' stamp: 'DaleHenrichs 11/2/2010 13:27'! 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 8/26/2009 10:07'! latestVersion: blessing ^(self map values select: [:version | blessing = version blessing ]) detectMax: [:version | version ]! ! !MetacelloProject methodsFor: 'versions' stamp: 'dkh 1/5/2010 10:43'! 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: 'versions' stamp: 'dkh 12/21/2009 14:04'! latestVersionMatching: versionPatternString excludedBlessings: excluded ^self latestVersionMatching: versionPatternString includedBlessings: #() excludedBlessings: excluded ! ! !MetacelloProject methodsFor: 'versions' stamp: 'dkh 12/21/2009 13:59'! latestVersionMatching: versionPatternString includedBlessings: included ^self latestVersionMatching: versionPatternString includedBlessings: included excludedBlessings: self excludeFromLatestVersion ! ! !MetacelloProject methodsFor: 'versions' stamp: 'dkh 12/21/2009 14:41'! 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: 'versions' stamp: 'DaleHenrichs 1/17/2011 11:23'! stableVersion ^self version: #stable! ! !MetacelloProject methodsFor: 'versions' stamp: 'DaleHenrichs 01/24/2011 13:33'! symbolicVersionSymbols ^self symbolicVersionMap keys asArray sort: [:a :b | a <= b ]! ! !MetacelloProject methodsFor: 'versions' stamp: 'DaleHenrichs 11/18/2010 15:58'! 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 map at: symbolicVersionString ifAbsent: [ (MetacelloSymbolicVersionDoesNotExistError project: self project versionString: symbolicVersionString) signal ] ]. ^ self map at: aVersionString ifAbsent: [ (MetacelloVersionDoesNotExistError project: self project versionString: aVersionString) signal ]! ! !MetacelloProject methodsFor: 'versions' stamp: 'DaleHenrichs 11/2/2010 17:13'! version: aVersionString ifAbsent: aBlock ^[ self version: aVersionString ] on: MetacelloVersionDoesNotExistError do: [:ex | aBlock value ].! ! !MetacelloProject methodsFor: 'versions' stamp: 'DaleHenrichs 11/10/2010 16:13'! versions ^self map values asArray sort: [:a :b | a <= b ]! ! !MetacelloProject methodsFor: 'private' stamp: 'dkh 10/14/2009 16:33'! attributes ^(OrderedCollection with: #common) addAll: self platformAttributes; yourself ! ! !MetacelloProject methodsFor: 'private' stamp: 'dkh 7/24/2009 15:37'! defaultPlatformAttributes ^ MetacelloPlatform current defaultPlatformAttributes! ! !MetacelloProject methodsFor: 'private' stamp: 'dkh 10/7/2009 10:05'! excludeFromLatestVersion ^#(development broken baseline)! ! !MetacelloProject methodsFor: 'private' stamp: 'dkh 10/17/2009 09:32'! platformAttributes ^self projectPlatformAttributes! ! !MetacelloProject methodsFor: 'private' stamp: 'dkh 7/28/2009 16:42'! pragmaKeywords ^#(version:attribute: blessing:attribute: description:attribute: required:attribute: groups:attribute: doits:attribute:)! ! !MetacelloProject methodsFor: 'private' stamp: 'dkh 9/2/2009 08:31'! projectAttributes projectAttributes ~~ nil ifTrue: [ ^projectAttributes ]. ^#()! ! !MetacelloProject methodsFor: 'private' stamp: 'dkh 9/2/2009 08:31'! projectAttributes: aList projectAttributes := aList! ! !MetacelloProject methodsFor: 'private' stamp: 'dkh 9/2/2009 07:38'! projectPlatformAttributes | list aBlock | list := OrderedCollection new. (aBlock := self projectAttributes) ~~ nil ifTrue: [ list addAll: aBlock value ]. ^self defaultPlatformAttributes, list! ! !MetacelloProject methodsFor: 'private' stamp: 'DaleHenrichs 11/10/2010 16:13'! sortedAndFilteredVersions ^(self map values asArray sort: [:a :b | a >= b ]) select: [:vrsn | (#(broken baseline) includes: vrsn blessing) not ]. ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MetacelloProject class instanceVariableNames: ''! !MetacelloProject class methodsFor: 'instance creation' stamp: 'dkh 9/4/2009 01:43'! new | inst | inst := self basicNew. ^inst configuration: inst; yourself! ! !MetacelloProject class methodsFor: 'instance creation' stamp: 'dkh 9/4/2009 01:43'! on: aConfig ^self basicNew configuration: aConfig; yourself! ! MetacelloAbstractPackageSpec subclass: #MetacelloProjectReferenceSpec instanceVariableNames: 'projectReference' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Specs'! !MetacelloProjectReferenceSpec methodsFor: '*metacello-mc' stamp: 'DaleHenrichs 3/5/2010 09:46'! loadUsing: aLoader gofer: ignored | required | required := self resolveToLoadableSpec. required loader: aLoader. ^required load! ! !MetacelloProjectReferenceSpec methodsFor: '*metacello-mc' stamp: 'DaleHenrichs 11/5/2010 15:58'! 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 9/13/2012 11:26'! repository: aStringOrMetacelloRepositorySpec ^ self projectReference repository: aStringOrMetacelloRepositorySpec! ! !MetacelloProjectReferenceSpec methodsFor: '*metacello-mc' stamp: 'dkh 10/3/2009 19:14'! resolveProjectSpec ^self projectReference! ! !MetacelloProjectReferenceSpec methodsFor: '*metacello-mc' stamp: 'dkh 10/21/2009 15:48'! 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 11/10/2009 09:48'! resolveToLoadableSpec ^self resolveProjectSpec resolveToLoadableSpec! ! !MetacelloProjectReferenceSpec methodsFor: '*metacello-mc' stamp: 'dkh 10/21/2009 15:22'! resolveToPackagesIn: aVersionSpec visited: visited ^#()! ! !MetacelloProjectReferenceSpec methodsFor: '*metacello-mc' stamp: 'DaleHenrichs 11/16/2010 16:31'! 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: '*metacello-mc' stamp: 'dkh 10/23/2009 10:20'! 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: '*metacello-mc' stamp: 'dkh 12/7/2009 16:24'! versionString ^self projectReference versionString! ! !MetacelloProjectReferenceSpec methodsFor: 'accessing' stamp: 'dkh 1/4/2010 19:02'! answers: aListOfPairs self shouldNotImplement! ! !MetacelloProjectReferenceSpec methodsFor: 'accessing' stamp: 'dkh 10/5/2009 10:13'! includes: aCollection self shouldNotImplement! ! !MetacelloProjectReferenceSpec methodsFor: 'accessing' stamp: 'dkh 9/23/2009 10:51'! projectName ^self projectReference name! ! !MetacelloProjectReferenceSpec methodsFor: 'accessing' stamp: 'dkh 9/23/2009 10:51'! projectReference: anObject projectReference := anObject! ! !MetacelloProjectReferenceSpec methodsFor: 'accessing' stamp: 'dkh 10/24/2009 19:42'! referencedSpec ^self projectReference! ! !MetacelloProjectReferenceSpec methodsFor: 'accessing' stamp: 'dkh 10/4/2009 11:40'! requires: aCollection self shouldNotImplement! ! !MetacelloProjectReferenceSpec methodsFor: 'copying' stamp: 'DaleHenrichs 11/17/2010 12:43'! postCopy super postCopy. projectReference := projectReference copy. ! ! !MetacelloProjectReferenceSpec methodsFor: 'merging' stamp: 'dkh 10/5/2009 11:31'! mergeMap | map | map := super mergeMap. map at: #projectReference put: projectReference. ^map! ! !MetacelloProjectReferenceSpec methodsFor: 'merging' stamp: 'DaleHenrichs 1/21/2010 20:00'! 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: 'merging' stamp: 'dkh 10/8/2009 20:32'! nonOverridable ^super nonOverridable, #( projectReference )! ! !MetacelloProjectReferenceSpec methodsFor: 'printing' stamp: 'DaleHenrichs 11/16/2010 13:52'! 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: 'project: ' , 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: 'printing' stamp: 'dkh 6/25/2011 19:25'! 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: 'querying' stamp: 'dkh 9/23/2009 10:51'! projectReference ^ projectReference! ! !MetacelloProjectReferenceSpec methodsFor: 'querying' stamp: 'DaleHenrichs 2/5/2010 13:42'! relativeCurrentVersion ^self projectReference relativeCurrentVersion! ! !MetacelloProjectReferenceSpec methodsFor: 'querying' stamp: 'dkh 10/24/2009 10:38'! version ^self projectReference version! ! !MetacelloProjectReferenceSpec methodsFor: 'querying' stamp: 'DaleHenrichs 11/5/2010 16:00'! versionOrNil ^self projectReference versionOrNil! ! !MetacelloProjectReferenceSpec methodsFor: 'querying' stamp: 'DaleHenrichs 11/16/2010 12:41'! versionString: aString ^self projectReference versionString: aString! ! !MetacelloProjectReferenceSpec methodsFor: 'visiting' stamp: 'dkh 10/24/2009 19:43'! projectDo: projectBlock packageDo: packageBlock groupDo: groupBlock projectBlock value: self! ! MetacelloSpec subclass: #MetacelloProjectSpec instanceVariableNames: 'name className versionString operator loads preLoadDoIt postLoadDoIt' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Specs'! !MetacelloProjectSpec methodsFor: 'accessing' stamp: 'dkh 06/02/2009 20:31'! className: aString className := aString! ! !MetacelloProjectSpec methodsFor: 'accessing' stamp: 'dkh 10/4/2009 12:05'! loads: aCollection aCollection setLoadsInMetacelloProject: self! ! !MetacelloProjectSpec methodsFor: 'accessing' stamp: 'dkh 06/02/2009 20:32'! name: aString name := aString! ! !MetacelloProjectSpec methodsFor: 'accessing' stamp: 'dkh 6/14/2009 13:37'! operator: anObject " #= #~= #> #< #>= #<= #~> " operator := anObject! ! !MetacelloProjectSpec methodsFor: 'accessing' stamp: 'DaleHenrichs 12/21/2010 13:56'! postLoadDoIt: anObject anObject setPostLoadDoItInMetacelloSpec: self! ! !MetacelloProjectSpec methodsFor: 'accessing' stamp: 'DaleHenrichs 12/21/2010 13:56'! preLoadDoIt: anObject anObject setPreLoadDoItInMetacelloSpec: self! ! !MetacelloProjectSpec methodsFor: 'accessing' stamp: 'DaleHenrichs 12/21/2010 13:52'! setPostLoadDoIt: aSymbol postLoadDoIt := aSymbol! ! !MetacelloProjectSpec methodsFor: 'accessing' stamp: 'DaleHenrichs 12/21/2010 13:53'! setPreLoadDoIt: aSymbol preLoadDoIt := aSymbol! ! !MetacelloProjectSpec methodsFor: 'accessing' stamp: 'dkh 6/7/2009 09:20'! versionString: anObject versionString := anObject! ! !MetacelloProjectSpec methodsFor: 'adding' stamp: 'dkh 10/4/2009 11:51'! 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: 'loading' stamp: 'dkh 6/9/2009 10:16'! load self subclassResponsibility! ! !MetacelloProjectSpec methodsFor: 'merging' stamp: 'DaleHenrichs 1/21/2010 19:34'! 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: 'printing' stamp: 'DaleHenrichs 01/16/2011 13:54'! configMethodBodyOn: aStream indent: indent | hasVersionString hasOperator hasProjectPackage hasLoads hasClassName hasPreLoadDoIt hasPostLoadDoIt | hasClassName := self className ~~ nil. hasVersionString := self versionString ~~ nil. hasOperator := operator ~~ nil. hasProjectPackage := self projectPackage ~~ nil and: [ self projectPackage packageRepository ~~ nil or: [ self projectPackage name ~= self className ] ]. 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 | hasProjectPackage | hasLoads 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 | hasName := self projectPackage name ~= self className. hasRepo := self projectPackage packageRepository ~~ nil. hasName ifTrue: [ hasClassName | hasVersionString | hasOperator | hasLoads | hasPreLoadDoIt | hasPostLoadDoIt ifTrue: [ aStream cr; tab: indent + 1 ] ifFalse: [ aStream space ]. aStream nextPutAll: 'file: ' , self projectPackage name printString. hasRepo ifTrue: [ aStream nextPut: $; ] ]. hasRepo ifTrue: [ | repos | repos := self projectPackage repositories. repos map values size = 1 ifTrue: [ hasClassName | hasVersionString | hasOperator | hasLoads | hasPreLoadDoIt | hasPostLoadDoIt ifTrue: [ aStream cr; tab: indent + 1 ] ifFalse: [ aStream space ]. self projectPackage packageRepository configMethodCascadeOn: aStream lastCascade: true ] ifFalse: [ aStream cr. self projectPackage repositories configMethodCascadeOn: aStream indent: indent ] ] ]! ! !MetacelloProjectSpec methodsFor: 'printing' stamp: 'dkh 10/24/2009 19:56'! 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: 'printing' stamp: 'DaleHenrichs 1/12/2011 12:28'! configShortCutMethodOn: aStream member: aMember indent: indent | hasVersionString hasOperator hasProjectPackage hasLoads hasClassName hasPreLoadDoIt hasPostLoadDoIt | hasClassName := self className ~~ nil. hasVersionString := self versionString ~~ nil. hasOperator := operator ~~ nil. hasProjectPackage := self projectPackage ~~ nil and: [ self projectPackage name ~~ nil or: [ self projectPackage packageRepository ~~ nil ] ]. 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: 'printing' stamp: 'DaleHenrichs 3/9/2010 16:33'! label ^self name! ! !MetacelloProjectSpec methodsFor: 'querying' stamp: 'dkh 06/02/2009 20:27'! className ^className! ! !MetacelloProjectSpec methodsFor: 'querying' stamp: 'DaleHenrichs 12/21/2010 13:44'! getPostLoadDoIt ^postLoadDoIt! ! !MetacelloProjectSpec methodsFor: 'querying' stamp: 'DaleHenrichs 12/21/2010 13:44'! getPreLoadDoIt ^preLoadDoIt! ! !MetacelloProjectSpec methodsFor: 'querying' stamp: 'dkh 10/4/2009 12:04'! loads ^ loads! ! !MetacelloProjectSpec methodsFor: 'querying' stamp: 'dkh 06/02/2009 20:32'! name ^name! ! !MetacelloProjectSpec methodsFor: 'querying' stamp: 'dkh 10/6/2009 15:39'! operator operator == nil ifTrue: [ ^#>= ]. ^ operator! ! !MetacelloProjectSpec methodsFor: 'querying' stamp: 'DaleHenrichs 1/21/2010 18:15'! postLoadDoIt ^postLoadDoIt! ! !MetacelloProjectSpec methodsFor: 'querying' stamp: 'DaleHenrichs 12/21/2010 13:56'! preLoadDoIt ^preLoadDoIt! ! !MetacelloProjectSpec methodsFor: 'querying' stamp: 'dkh 10/5/2009 11:47'! projectPackage ^nil! ! !MetacelloProjectSpec methodsFor: 'querying' stamp: 'DaleHenrichs 9/22/2010 13:52'! versionKey "suitable for using as a unique key for the receiver's version in a dictionary" ^ self version versionKey! ! !MetacelloProjectSpec methodsFor: 'querying' stamp: 'dkh 6/7/2009 09:20'! versionString ^ versionString! ! !MetacelloProjectSpec methodsFor: 'private' stamp: 'dkh 10/4/2009 12:04'! setLoads: aCollection loads := aCollection! ! MetacelloProjectSpecLoadError subclass: #MetacelloProjectSpecLoadConflict instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Exceptions'! !MetacelloProjectSpecLoadConflict methodsFor: 'private' stamp: 'DaleHenrichs 2/5/2010 16:16'! isResumable "Determine whether an exception is resumable." ^ true! ! Error subclass: #MetacelloProjectSpecLoadError instanceVariableNames: 'projectSpec' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Exceptions'! !MetacelloProjectSpecLoadError methodsFor: 'accessing' stamp: 'DaleHenrichs 1/19/2010 11:29'! projectSpec ^projectSpec! ! !MetacelloProjectSpecLoadError methodsFor: 'accessing' stamp: 'DaleHenrichs 1/19/2010 11:29'! projectSpec: aMetacelloMCProjectSpec projectSpec := aMetacelloMCProjectSpec! ! !MetacelloProjectSpecLoadError methodsFor: 'private' stamp: 'DaleHenrichs 2/5/2010 16:18'! isResumable "Determine whether an exception is resumable." ^ false! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MetacelloProjectSpecLoadError class instanceVariableNames: ''! !MetacelloProjectSpecLoadError class methodsFor: 'instance creation' stamp: 'DaleHenrichs 1/19/2010 11:28'! projectSpec: aMetacelloMCProjectSpec ^self new projectSpec: aMetacelloMCProjectSpec; yourself! ! MetacelloMemberSpec subclass: #MetacelloRemoveMemberSpec instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Members'! !MetacelloRemoveMemberSpec methodsFor: 'accessing' stamp: 'dkh 6/15/2009 10:27'! methodUpdateSelector ^#remove:! ! !MetacelloRemoveMemberSpec methodsFor: 'actions' stamp: 'dkh 10/4/2009 10:16'! applyAdd: addBlock copy: copyBlock merge: mergeBlock remove: removeBlock removeBlock value: self ! ! !MetacelloRemoveMemberSpec methodsFor: 'actions' stamp: 'dkh 06/02/2009 18:27'! applyToList: aListSpec aListSpec remove: self! ! MetacelloMemberListSpec subclass: #MetacelloRepositoriesSpec instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Metacello-MC-Specs'! !MetacelloRepositoriesSpec methodsFor: 'actions' stamp: 'dkh 10/3/2009 16:52'! add: aStringOrSpec aStringOrSpec addToMetacelloRepositories: self! ! !MetacelloRepositoriesSpec methodsFor: 'actions' stamp: 'dkh 6/7/2009 10:18'! add: description type: type | spec | spec := (self project repositorySpec) description: description; type: type; yourself. self addMember: (self addMember name: spec name; spec: spec; yourself)! ! !MetacelloRepositoriesSpec methodsFor: 'actions' stamp: 'dkh 6/7/2009 10:18'! merge: aRepositorySpec aRepositorySpec mergeIntoMetacelloRepositories: self! ! !MetacelloRepositoriesSpec methodsFor: 'actions' stamp: 'dkh 6/7/2009 20:50'! merge: description type: type | spec | spec := (self project repositorySpec) description: description; type: type; yourself. self addMember: (self mergeMember name: spec name; spec: spec; yourself)! ! !MetacelloRepositoriesSpec methodsFor: 'actions' stamp: 'dkh 6/7/2009 10:22'! remove: aRepositorySpec aRepositorySpec removeFromMetacelloRepositories: self! ! !MetacelloRepositoriesSpec methodsFor: 'actions' stamp: 'dkh 10/6/2009 23:59'! repository: aStringOrSpec aStringOrSpec addToMetacelloRepositories: self! ! !MetacelloRepositoriesSpec methodsFor: 'actions' stamp: 'dkh 10/22/2009 09:01'! 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: 'printing' stamp: 'DaleHenrichs 11/10/2010 16:13'! 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: 'printing' stamp: 'dkh 1/2/2010 17:11'! configMethodOn: aStream indent: indent aStream tab: indent; nextPutAll: 'spec'; cr. self configMethodCascadeOn: aStream indent: indent! ! MetacelloSpec subclass: #MetacelloRepositorySpec instanceVariableNames: 'description username password type' classVariableNames: '' poolDictionaries: '' category: 'Metacello-MC-Specs'! !MetacelloRepositorySpec methodsFor: 'accessing' stamp: 'dkh 06/03/2009 12:15'! description: aString description := aString! ! !MetacelloRepositorySpec methodsFor: 'accessing' stamp: 'dkh 10/22/2009 08:49'! password: aString password := aString! ! !MetacelloRepositorySpec methodsFor: 'accessing' stamp: 'dkh 06/03/2009 12:15'! type: aString type := aString! ! !MetacelloRepositorySpec methodsFor: 'accessing' stamp: 'dkh 10/22/2009 08:49'! username: aString username := aString! ! !MetacelloRepositorySpec methodsFor: 'adding' stamp: 'dkh 6/7/2009 10:13'! addToMetacelloRepositories: aMetacelloRepositoriesSpec aMetacelloRepositoriesSpec addMember: (aMetacelloRepositoriesSpec addMember name: self name; spec: self; yourself)! ! !MetacelloRepositorySpec methodsFor: 'mc support' stamp: 'dkh 10/22/2009 08:52'! createRepository ^self project createRepository: self ! ! !MetacelloRepositorySpec methodsFor: 'merging' stamp: 'dkh 10/22/2009 09:11'! mergeMap | map | map := super mergeMap. map at: #description put: description. map at: #type put: type. map at: #username put: username. map at: #password put: password. ^map! ! !MetacelloRepositorySpec methodsFor: 'printing' stamp: 'dkh 10/22/2009 09:54'! 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: 'printing' stamp: 'dkh 10/22/2009 09:54'! configMethodOn: aStream indent: indent aStream tab: indent; nextPutAll: 'spec '. self configMethodCascadeOn: aStream lastCascade: true! ! !MetacelloRepositorySpec methodsFor: 'querying' stamp: 'dkh 06/03/2009 12:16'! description ^description! ! !MetacelloRepositorySpec methodsFor: 'querying' stamp: 'dkh 6/7/2009 10:33'! name ^self description! ! !MetacelloRepositorySpec methodsFor: 'querying' stamp: 'dkh 10/22/2009 08:49'! password password == nil ifTrue: [ password := '' ]. ^password! ! !MetacelloRepositorySpec methodsFor: 'querying' stamp: 'dkh 06/03/2009 12:16'! type type == nil ifTrue: [ type := self extractTypeFromDescription ]. ^type! ! !MetacelloRepositorySpec methodsFor: 'querying' stamp: 'dkh 10/22/2009 08:49'! username username == nil ifTrue: [ username := '' ]. ^username! ! !MetacelloRepositorySpec methodsFor: 'private' stamp: 'TestRunner 12/7/2009 14:30'! extractTypeFromDescription ^MetacelloPlatform current extractTypeFromDescription: self description! ! !MetacelloRepositorySpec methodsFor: 'private' stamp: 'dkh 6/7/2009 10:21'! mergeIntoMetacelloRepositories: aMetacelloRepositoriesSpec aMetacelloRepositoriesSpec addMember: (aMetacelloRepositoriesSpec mergeMember name: self name; spec: self; yourself)! ! !MetacelloRepositorySpec methodsFor: 'private' stamp: 'dkh 6/7/2009 10:24'! removeFromMetacelloRepositories: aMetacelloRepositoriesSpec aMetacelloRepositoriesSpec addMember: (aMetacelloRepositoriesSpec removeMember name: self name; spec: self; yourself)! ! MetacelloLoader subclass: #MetacelloScriptLoader instanceVariableNames: 'repository inboxRepository repository39 repositorySqueakTrunk repository310 repositoryTaskForces repositoryMC repositoryTreated' classVariableNames: 'CheckImageInSyncWithUpdate CurrentMajorVersionNumber CurrentScriptVersionNumber CurrentUpdateVersionNumber CurrentlyIntegratingChanges LogStream Repository' poolDictionaries: 'TextConstants' category: 'ScriptLoader20'! !MetacelloScriptLoader commentStamp: '' prior: 0! self releaseMenu Pharo Process Description --- Here is the pharo process. General points ----------------------- An enhancement - should be added to the bug tracker - announced to the mailing-list - asked for feedback - results should be added to the BT entry Fixed tag means ready for integration Closed tag means integrated A bug detected - discuss via the mailing-list - should be added to the bug tracker - fix are considered as enh (see point above) When a fix is fixed it should be either post as cs to the BT entry or in the PharoInbox as a Slice (a slice is an emtpy package that has as requirement other package composing the fix). We have three projects: Pharo PharoInbox PharoTreatedInbox A fix goes either from inbox to treatedInbox or to Pharo. If a fix does not work it is moved to the TreatedInbox. If a fix works it is integrated as follow - it will be moved from the Inbox to the TreatedInbox and integrated and published in the Pharo project To help browsing multiple repositories: ScriptLoader new addExtraRepositories +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Now the integration works in 4 main steps which can be steered by the following expression ScriptLoader releaseMenu or via the menu that can be shown/hidden using ScriptLoader showIntegrationMenu ScriptLoader hideIntegrationMenu 1.) Start up a recent and clean image ScriptLoader new prepareNewUpdate This step will - load the latest updates - load the latest ScriptLoader package from the Pharo repository. Indeed when we work on improving the ScriptLoader it may not be published in the update stream. New versions can be available on the server but not part of the latest updates. Therefore the process always loads the latest version of scriptloader from the pharo repository. This point is important because when an integration failed, you have to check and optionally remove the scriptloader package from the pharo repository. - check that the update.list (which contains the cs to load the packages) is in sync with the image current version. You have to download the latest version using a script like this one. Pay attention to update it so that it reflects the right version (ie 1.0, 1.1, 1.2...) scp -p LOGIN@scm.gforge.inria.fr:/home/groups/pharo/htdocs/updates/pharo1.1/updates.list . - snapshot the package version to detect dirty or changed but non dirty packages. 2.) Apply changes ScriptLoader new doneApplyingChanges This step will - create an update method with can trigger the load of the packages and some pre/post actions - create a script method with describes all the package versions and it used by the update methods - save all the packages that are different (except some filtered packages) into a local folder named package-to-be-tested. ScriptLoader, SLICE*.... and a couple of other packages are not considered to be included in the script method (check method packagesNotToSavePatternNames) 3.) Verify changes ==> in a ***new*** image (in the current folder) execute: ScriptLoader new verifyNewUpdate This step will - load in any order (so may break) the package previously saved in the packages to be tested. - this step is important because you may get simple changes with unexpected side effects and that may break the load. 4.) If there are problems go to 2.) to fix them, else: ScriptLoader new publishChanges This step will - generate a new cs file whose purpose is to load the given version of the scriptloader and trigger the correct update method. - add the name of the cs file to the end of the updates.list file local to the disc - copy all the package from the local directory to the Pharo After the updates.list and the cs file should be manually uploaded to the ftp (see below) scp "$1" LOGIN@scm.gforge.inria.fr:/home/groups/pharo/htdocs/updates/pharo1.1/ 5) in case of problems. Think that if you pass the step 4 you may have a scriptLoader version that got published and that is reloaded during the first step. CurrentMajorVersionNumber should contains a string '1.0', '1.1'.... This string will determine on which folder on the server the updates.list should be loaded. i.e., updates/pharo1.0, updates/pharo1.1 .... --- Not to forget --- To change the release stream add a new method for each releaseStream ScriptLoader toPharoOne ScriptLoader toPharoOneDotOne ! !MetacelloScriptLoader methodsFor: 'accessing' stamp: 'EstebanLorenzano 5/8/2012 12:17'! gofer ^ Smalltalk globals at: #Gofer ifAbsent: [ self installGofer; gofer ]! ! !MetacelloScriptLoader methodsFor: 'accessing' stamp: 'EstebanLorenzano 5/8/2012 12:17'! inboxRepository ^ inboxRepository ifNil: [inboxRepository := self inboxRepositoryDefault] ! ! !MetacelloScriptLoader methodsFor: 'accessing' stamp: 'EstebanLorenzano 5/8/2012 12:17'! repository ^ repository ifNil: [ repository := MCHttpRepository new location: self homeRepositoryUrlString ; user: ''; password: '']! ! !MetacelloScriptLoader methodsFor: 'accessing' stamp: 'SeanDeNigris 8/26/2012 15:52'! repository310 ^ repository310 ifNil: [ repository310 := MCHttpRepository location: 'http://source.squeakfoundation.org/310']! ! !MetacelloScriptLoader methodsFor: 'accessing' stamp: 'SeanDeNigris 8/26/2012 15:53'! repository39 ^ repository39 ifNil: [ repository39 := MCHttpRepository location: 'http://source.squeakfoundation.org/39a']! ! !MetacelloScriptLoader methodsFor: 'accessing' stamp: 'EstebanLorenzano 5/8/2012 12:17'! repository: aRepository repository := aRepository! ! !MetacelloScriptLoader methodsFor: 'accessing' stamp: 'SeanDeNigris 8/26/2012 15:53'! repositoryMC ^ repositoryMC ifNil: [ repositoryMC := MCHttpRepository location: 'http://source.wiresong.ca/mc']! ! !MetacelloScriptLoader methodsFor: 'accessing' stamp: 'SeanDeNigris 8/26/2012 15:53'! repositorySqueakTrunk ^ repositorySqueakTrunk ifNil: [ repositorySqueakTrunk := MCHttpRepository location: 'http://source.squeakfoundation.org/trunk']! ! !MetacelloScriptLoader methodsFor: 'accessing' stamp: 'SeanDeNigris 8/26/2012 15:53'! repositoryTaskForces ^ repositoryTaskForces ifNil: [ repositoryTaskForces := MCHttpRepository location: self taskForcesRepositoryUrlString]! ! !MetacelloScriptLoader methodsFor: 'accessing' stamp: 'SeanDeNigris 8/26/2012 15:54'! repositoryTreated ^ repositoryTreated ifNil: [ repositoryTreated := MCHttpRepository location: 'http://www.squeaksource.com/PharoTreatedInbox']! ! !MetacelloScriptLoader methodsFor: 'accessing' stamp: 'EstebanLorenzano 5/8/2012 12:17'! theScriptLoaderPackageName ^'ScriptLoader', CurrentMajorVersionNumber asString copyWithout: $. ! ! !MetacelloScriptLoader methodsFor: 'as yet unclassified' stamp: 'StephaneDucasse 5/26/2012 21:59'! allManagers ^ MCWorkingCopy allManagers! ! !MetacelloScriptLoader methodsFor: 'as yet unclassified' stamp: 'SeanDeNigris 8/26/2012 15:51'! inboxRepositoryDefault ^ MCHttpRepository location: self inboxRepositoryUrlString.! ! !MetacelloScriptLoader methodsFor: 'ci' stamp: 'CamilloBruni 5/10/2012 15:56'! checkImageIsUptodateSilently | last number | self class checkImageInSyncWithUpdate ifFalse: [^ true]. self updatesListFile writeStreamDo: [ :stream | stream contents linesDo: [ :each | last := each ]]. last isNil ifTrue: [^ false]. "in case the file is empty" (last copyUpTo: $-) isAllDigits ifFalse: [^ true]. "for cases where we have #Pharo1.1rc1 starting the line" number := (last copyUpTo: $-) asNumber. ^ number = self getLatestUpdateNumber. ! ! !MetacelloScriptLoader methodsFor: 'ci' stamp: 'EstebanLorenzano 5/8/2012 12:17'! compileNewUpdateMethodSilentlyPreLoad: preload postLoad: postLoad "Use me to create a new update method with the next update number" "self new compileNewUpdateMethod" self class compile: (self newGenerateNewUpdateMethodSilentlyPreLoad: preload postLoad: postLoad) classified: 'pharo - updates' ! ! !MetacelloScriptLoader methodsFor: 'ci' stamp: 'MarcusDenker 7/10/2012 10:36'! doneApplyingChangesSilentlyComment: providedComment preLoad: preload postLoad: postLoad | comment commentQuoted st | Smalltalk image saveSession. self saveAsNewImageWithCurrentReleaseNameToPublish. comment := providedComment trimBoth. commentQuoted := comment copyReplaceAll: (String with: $') with: (String with: $' with: $'). st := String new writeStream. st nextPutAll: 'commentForCurrentUpdate'; cr. st nextPutAll: ' ^ '. st nextPut: $'. st nextPutAll: commentQuoted. st nextPut: $'. self class compile: (st contents) classified: 'public'. self class waitingCacheFolder deleteAllChildren. self saveChangedPackagesIntoWaitingFolder. self generateScriptAndUpdateMethodForNewVersionSilentlyPreLoad: preload postLoad: postLoad. self saveLatestScriptLoaderToWaitingFolder.! ! !MetacelloScriptLoader methodsFor: 'ci' stamp: 'MarcusDenker 7/10/2012 10:36'! doneApplyingChangesSilentlyIssues: issuesToIntegrate preLoad: preload postLoad: postLoad | comment commentQuoted st | Smalltalk image saveSession. "now you can reopen prior to publishing to fix :)" self saveAsNewImageWithCurrentReleaseNameToPublish. comment := String streamContents: [:stream | issuesToIntegrate do: [:each | stream << each name << 'Thanks to ' << each content author email ; lf;lf. stream << each url;lf;lf;lf.]]. comment := comment trimBoth. "comment := UIManager default multiLineRequest: 'Comment for this update.' initialAnswer: self commentForCurrentUpdate answerHeight: 200. comment ifNil: [^ self]." commentQuoted := comment copyReplaceAll: (String with: $') with: (String with: $' with: $'). st := String new writeStream. st nextPutAll: 'commentForCurrentUpdate'; cr. st nextPutAll: ' ^ '. st nextPut: $'. st nextPutAll: commentQuoted. st nextPut: $'. self class compile: (st contents) classified: 'public'. self class waitingCacheFolder deleteAllChildren. self saveChangedPackagesIntoWaitingFolder. self generateScriptAndUpdateMethodForNewVersionSilentlyPreLoad: preload postLoad: postLoad. self saveLatestScriptLoaderToWaitingFolder. ! ! !MetacelloScriptLoader methodsFor: 'ci' stamp: 'EstebanLorenzano 5/8/2012 12:17'! generateScriptAndUpdateMethodForNewVersionSilentlyPreLoad: preload postLoad: postLoad "Use me to generate the script and update method" "self new generateScriptAndUpdateMethodForNewVersion" self compileScriptMethodWithCurrentPackages: self currentScriptVersionNumber. self compileNewUpdateMethodSilentlyPreLoad: preload postLoad: postLoad. ! ! !MetacelloScriptLoader methodsFor: 'ci' stamp: 'EstebanLorenzano 5/8/2012 12:17'! launchUpdateSilently ^ UpdateStreamer new updateFromServerSilently ! ! !MetacelloScriptLoader methodsFor: 'ci' stamp: 'CamilloBruni 5/9/2012 13:13'! loadLatestUpdateListSilently "fetch the latest version of the update.list on the server" | result listToUse lastUpdate | (result := ZnEasy get: UpdateStreamer new updateFolderURL, self updatesListFileName) isSuccess ifFalse: [ self error: 'Cannot access update server' ]. listToUse := result contents. listToUse linesDo: [:each | lastUpdate := each]. (lastUpdate beginsWith: self getLatestUpdateNumber asString) ifTrue: ["Write this file as our current updates.list" self updatesListFileName delete writeStreamDo: [:stream | stream nextPutAll: listToUse]] ifFalse: [ self inform: 'Image update version did not match automatically fetched update.list!! Proceed after downloading using the script ./getUpdatesList instead' ]. ! ! !MetacelloScriptLoader methodsFor: 'ci' stamp: 'EstebanLorenzano 5/8/2012 12:17'! newGenerateNewUpdateMethodSilentlyPreLoad: preload postLoad: postLoad "ScriptLoader new newGenerateNewUpdateMethod" | str mthName preamble postscript | str := ReadWriteStream on: (String new: 1000). mthName := 'update', self currentUpdateVersionNumber asString. str nextPutAll: mthName ; cr ; tab. str nextPutAll: '"self new ', mthName, '"'; crtab. preamble := preload reset contents asString. preamble isEmptyOrNil ifFalse: [str nextPutAll: preamble; ensureEndsWith: $.; crtab ]. str nextPutAll: 'self withUpdateLog: ' ; nextPut: $'; nextPutAll: self commentForCurrentUpdate ; nextPut: $'; nextPut: $. . str crtab. str nextPutAll: 'self loadTogether: '. str nextPutAll: 'self script' , self currentScriptVersionNumber asString, ' merge: false.'. str crtab. postscript := postLoad reset contents asString. postscript isEmptyOrNil ifFalse: [str nextPutAll: postscript; ensureEndsWith: $.; crtab ]. str nextPutAll: 'self flushCaches.'; cr. ^ str contents! ! !MetacelloScriptLoader methodsFor: 'ci' stamp: 'EstebanLorenzano 5/8/2012 12:17'! prepareNewUpdateSilently "Return nil on error" self launchUpdateSilently ifFalse: [ ^ nil ]. [ self loadLatestScriptloader ] on: Warning do: [:warning | ^ nil ]. self markPackagesBeforeNewCodeIsLoaded. self checkImageIsUptodateSilently ifFalse: [ self loadLatestUpdateListSilently ]. self checkImageIsUptodate ifFalse: [ ^ nil ]. self setUpdateAndScriptVersionNumbers. self saveAsNewImageWithCurrentReleaseName. ^ self currentUpdateVersionNumber! ! !MetacelloScriptLoader methodsFor: 'cleaning' stamp: 'EstebanLorenzano 5/8/2012 12:17'! flushCaches MCFileBasedRepository flushAllCaches. MCDefinition clearInstances. Smalltalk garbageCollect.! ! !MetacelloScriptLoader methodsFor: 'elementary steps' stamp: 'SeanDeNigris 7/12/2012 08:44'! CSForLastUpdate: aString "ScriptLoader new CSForLastUpdate: 'cleanUpMethods'" | str updateNumber filename| updateNumber := self getLatestUpdateNumber. filename := updateNumber asString, '-Pha-', aString, '.cs'. filename asFileReference delete; writeStreamDo: [ :stream| self generateCS: self latestScriptLoaderPackageIdentificationString fromUpdate: updateNumber on: stream]. ^ filename! ! !MetacelloScriptLoader methodsFor: 'elementary steps' stamp: 'EstebanLorenzano 5/8/2012 12:17'! CSForLastUpdateAndPatchUpdatesList: aString "ScriptLoader new CSForLastUpdateAndPatchUpdatesList: 'cleanUpMethods'" | filename | filename := self CSForLastUpdate: aString. self updateUpdatesList: aString. ^ filename ! ! !MetacelloScriptLoader methodsFor: 'elementary steps' stamp: 'EstebanLorenzano 5/8/2012 12:17'! copyPackagesFromWaitingFolderToHomeRepository "self defaultMCWaitingFolder allFileNames" "self new copyPackageFromWaitingFolderToHomeRepository" self waitingFolderMCZFiles do: [:name | | version | version := self class defaultMCWaitingFolder versionFromFileNamed: name. self repository storeVersion: version]! ! !MetacelloScriptLoader methodsFor: 'elementary steps' stamp: 'EstebanLorenzano 5/8/2012 15:17'! generateScriptAndUpdateMethodForNewVersion "Use me to generate the script and update method" "self new generateScriptAndUpdateMethodForNewVersion" self compileScriptMethodWithCurrentPackages: self currentUpdateVersionNumber. self compileNewUpdateMethod.! ! !MetacelloScriptLoader methodsFor: 'elementary steps' stamp: 'EstebanLorenzano 5/8/2012 12:17'! loadLatestScriptloader "self new loadLatestScriptloader" self class loadLatestPackage: 'ScriptLoader', self currentMajorVersionNumberWithoutDot fromSqueaksource: 'Pharo20' ! ! !MetacelloScriptLoader methodsFor: 'elementary steps' stamp: 'EstebanLorenzano 5/8/2012 12:17'! loadPackageFromWaitingFolder "self defaultMCWaitingFolder allFileNames" "self new loadPackageFromWaitingFolder" self waitingFolderMCZFiles do: [:name | | version | version := self class defaultMCWaitingFolder versionFromFileNamed: name. version load]! ! !MetacelloScriptLoader methodsFor: 'elementary steps' stamp: 'EstebanLorenzano 5/8/2012 12:17'! mergePackageFromWaitingFolder "self defaultMCWaitingFolder allFileNames" "self new loadPackageFromWaitingFolder" self waitingFolderMCZFiles do: [ :name | | version | version := self class defaultMCWaitingFolder versionFromFileNamed: name. version merge. ]! ! !MetacelloScriptLoader methodsFor: 'elementary steps' stamp: 'EstebanLorenzano 5/8/2012 12:17'! saveChangedPackagesIntoWaitingFolder self currentChangedPackages do: [:each | self saveInToReloadCachePackage: each with: self commentForCurrentUpdate]! ! !MetacelloScriptLoader methodsFor: 'elementary steps' stamp: 'StephaneDucasse 5/26/2012 22:04'! saveLatestScriptLoaderToHome "self new saveLatestScriptLoaderToHome" | man r | man := self allManagers. r := man select: [:each | 'ScriptLoader*' match: each package name]. self repository storeVersion: r first newVersion.! ! !MetacelloScriptLoader methodsFor: 'elementary steps' stamp: 'StephaneDucasse 5/26/2012 22:05'! saveLatestScriptLoaderToWaitingFolder "self new saveLatestScriptLoaderToWaitingFolder" | man r | man := self allManagers. r := man select: [:each | 'ScriptLoader', self currentMajorVersionNumberWithoutDot, '*' match: each package name]. self saveInToReloadCachePackage: r first with: self commentForCurrentUpdate! ! !MetacelloScriptLoader methodsFor: 'elementary steps' stamp: 'SeanDeNigris 7/12/2012 08:44'! updateUpdatesList: aString "ScriptLoader new updateUpdatesList: 'cleanUpMethods'" self updatesListFileName asFileReference writeStreamDo: [ :str| str setToEnd; cr; nextPutAll: self currentUpdateVersionNumber asString; nextPutAll: '-Pha-', aString, '.cs' ]! ! !MetacelloScriptLoader methodsFor: 'fixing stream' stamp: 'EstebanLorenzano 5/8/2012 12:17'! installVersionInfo "self new installVersionInfo" | highestUpdate newVersion | highestUpdate := SystemVersion current highestUpdate. (self confirm: 'Reset highest update (' , highestUpdate printString , ')?') ifTrue: [SystemVersion current highestUpdate: 0]. newVersion := UIManager default request: 'New version designation:' translated initialAnswer: '3.9' , highestUpdate printString. SystemVersion newVersion: newVersion. ! ! !MetacelloScriptLoader methodsFor: 'fixing stream' stamp: 'EstebanLorenzano 5/8/2012 12:17'! unloadPackageNamed: aString "self new workingCopyFromPackageName: 'CollectionExtensions' " ^ (self workingCopyFromPackageName: aString) unload ! ! !MetacelloScriptLoader methodsFor: 'fixing stream' stamp: 'EstebanLorenzano 5/8/2012 12:17'! workingCopyFromPackageName: aString "self new workingCopyFromPackageName: '39Deprecated' " |pa| pa := MCPackage named: aString. ^ pa workingCopy ! ! !MetacelloScriptLoader methodsFor: 'generate scripts/methods' stamp: 'EstebanLorenzano 5/8/2012 12:17'! compileNewUpdateMethod "Use me to create a new update method with the next update number" "self new compileNewUpdateMethod" self class compile: (self newGenerateNewUpdateMethod) classified: 'pharo - updates'! ! !MetacelloScriptLoader methodsFor: 'generate scripts/methods' stamp: 'EstebanLorenzano 5/16/2012 10:41'! compileScriptMethodWithCurrentPackages: aNumber "self new compileScriptMethodWithCurrentPackages: 9999" | preamble postscript | preamble := UIManager default multiLineRequest: 'Preamble expression' initialAnswer: '' answerHeight: 200. postscript := UIManager default multiLineRequest: 'Postscript expression' initialAnswer: '' answerHeight: 200. ConfigurationOfPharo20 new newVersion: aNumber asString description: self commentForCurrentUpdate preLoad: preamble postLoad: postscript.! ! !MetacelloScriptLoader methodsFor: 'generate scripts/methods' stamp: 'EstebanLorenzano 5/8/2012 12:17'! currentScriptVersionNumber ^ CurrentScriptVersionNumber! ! !MetacelloScriptLoader methodsFor: 'generate scripts/methods' stamp: 'EstebanLorenzano 5/8/2012 12:17'! currentUpdateVersionNumber ^ CurrentUpdateVersionNumber ifNil: [SystemVersion current highestUpdate]! ! !MetacelloScriptLoader methodsFor: 'generate scripts/methods' stamp: 'EstebanLorenzano 5/16/2012 13:44'! generateCS: packageInfo fromUpdate: updateNumber on: st st nextPutAll: '"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." |repository| repository := MCHttpRepository location: ''', self homeRepositoryUrlString, ''' user: '''' password: ''''. (repository loadVersionFromFileNamed:' . st nextPut: $' ; nextPutAll: packageInfo, '.mcz'') load.'; cr. st nextPutAll: 'MetacelloScriptLoader new update', (updateNumber) asString; nextPutAll: '.' ; cr. st nextPutAll: '!!'. ^ st contents ! ! !MetacelloScriptLoader methodsFor: 'generate scripts/methods' stamp: 'EstebanLorenzano 5/8/2012 12:17'! generateNewUpdateMethod "ScriptLoader new generateNewUpdateMethod" | str mthName preamble postscript | str := ReadWriteStream on: (String new: 1000). mthName := 'update', self currentUpdateVersionNumber asString. str nextPutAll: mthName ; cr ; tab. str nextPutAll: '"self new ', mthName, '"'; crtab. preamble := UIManager default multiLineRequest: 'Preamble expression' initialAnswer: '' answerHeight: 100. preamble isEmptyOrNil ifFalse: [str nextPutAll: preamble; ensureEndsWith: $.; crtab]. str nextPutAll: 'self withUpdateLog: ' ; nextPut: $'; nextPutAll: self commentForCurrentUpdate ; nextPut: $'; nextPut: $. . str crtab. str nextPutAll: 'self script' , self currentScriptVersionNumber asString, '.'. str crtab. postscript := UIManager default multiLineRequest: 'Postscript expression' initialAnswer: '' answerHeight: 100. postscript isEmptyOrNil ifFalse: [str nextPutAll: postscript; ensureEndsWith: $.; crtab]. str nextPutAll: 'self flushCaches.'; cr. ^ str contents! ! !MetacelloScriptLoader methodsFor: 'generate scripts/methods' stamp: 'EstebanLorenzano 5/8/2012 12:17'! generateScriptTemplateWithAllCurrentPackages "ScriptLoader new generateScriptTemplateWithAllCurrentPackages" | str | str := ReadWriteStream on: (String new: 1000). str nextPutAll: 'scriptXXX' ; cr ; cr ; tab. str nextPutAll: '| names|'; cr. str nextPutAll: 'names := '. str nextPut: $'. self currentVersionsToBeSaved do: [:each | str nextPutAll: each ; nextPutAll: '.mcz'] separatedBy: [str nextPut: Character cr]. str nextPut: $'; nextPut: Character cr. str nextPutAll: 'findTokens: String lf , String cr. self loadTogether: names merge: false.'. ^ str contents! ! !MetacelloScriptLoader methodsFor: 'generate scripts/methods' stamp: 'EstebanLorenzano 5/8/2012 12:17'! generateScriptTemplateWithCurrentPackages: aNumber "ScriptLoader new generateScriptTemplateWithCurrentPackages" | str withoutScriptLoader | str := ReadWriteStream on: (String new: 1000). str nextPutAll: 'script', aNumber asString ; cr ; cr ; tab. str nextPutAll: '| names |'; cr. str nextPutAll: 'names := '. str nextPut: $'. withoutScriptLoader := self currentVersionsToBeSaved. withoutScriptLoader do: [ :each | str nextPutAll: each ; nextPutAll: '.mcz'] separatedBy: [str nextPut: Character cr]. str nextPut: $'; nextPut: Character cr. str nextPutAll: 'findTokens: String lf , String cr. self loadTogether: names merge: false.'. ^ str contents! ! !MetacelloScriptLoader methodsFor: 'generate scripts/methods' stamp: 'EstebanLorenzano 5/8/2012 12:17'! getLatestScriptNumber "self new getLatestScriptNumber" | upfroms | upfroms := self class selectors select: [:each | 'script*' match: each ]. upfroms := upfroms collect: [:each | (each asString allButFirst: 6)]. upfroms := upfroms reject: [:each | '*Log*' match: each ]. upfroms := upfroms reject: [:each | '*XXX*' match: each ]. upfroms := upfroms collect: [:each | each asNumber]. ^ upfroms asSortedCollection last ! ! !MetacelloScriptLoader methodsFor: 'generate scripts/methods' stamp: 'EstebanLorenzano 5/8/2012 12:17'! getLatestUpdateNumber "self new getLatestUpdateNumber" | upfroms | upfroms := self class selectors select: [:each | 'update*' match: each ]. upfroms := upfroms collect: [:each | [(each asString last: 5) asNumber] on: Error do: [0]]. ^ upfroms asSortedCollection last! ! !MetacelloScriptLoader methodsFor: 'generate scripts/methods' stamp: 'EstebanLorenzano 5/8/2012 12:17'! homeRepositoryUrlString ^ self rootURLString, 'Pharo20'! ! !MetacelloScriptLoader methodsFor: 'generate scripts/methods' stamp: 'EstebanLorenzano 5/8/2012 12:17'! inboxRepositoryUrlString ^ self rootURLString, 'PharoInbox'! ! !MetacelloScriptLoader methodsFor: 'generate scripts/methods' stamp: 'EstebanLorenzano 5/8/2012 12:17'! rootURLString ^ self class rootURLString! ! !MetacelloScriptLoader methodsFor: 'generate scripts/methods' stamp: 'EstebanLorenzano 5/16/2012 11:31'! setUpdateAndScriptVersionNumbers CurrentUpdateVersionNumber := self getLatestUpdateNumber + 1. "CurrentScriptVersionNumber := self getLatestScriptNumber + 1."! ! !MetacelloScriptLoader methodsFor: 'generate scripts/methods' stamp: 'EstebanLorenzano 5/8/2012 12:17'! taskForcesRepositoryUrlString ^ self rootURLString , 'PharoTaskForces'! ! !MetacelloScriptLoader methodsFor: 'generate scripts/methods' stamp: 'EstebanLorenzano 5/8/2012 12:17'! writeCS: extensionAndNumber forUpdate: updateNumber "ScriptLoader new writeCS: '-sd.210' forUpdate: 7037" self writeCS: extensionAndNumber forUpdate: updateNumber withName: 'changeMe'! ! !MetacelloScriptLoader methodsFor: 'generate scripts/methods' stamp: 'SeanDeNigris 7/12/2012 08:44'! writeCS: extensionAndNumber forUpdate: updateNumber withName: aSt "ScriptLoader new writeCS: '-md.2929' forUpdate: 7049 withName: 'cleanUpMethods'" (updateNumber asString, 'update', aSt, '.cs') asFileReference delete writeStreamDo: [ :stream | self generateCS: extensionAndNumber fromUpdate: updateNumber on: stream]. ! ! !MetacelloScriptLoader methodsFor: 'load primitives' stamp: 'EstebanLorenzano 5/8/2012 12:17'! loadOneAfterTheOther: aCollection merge: aBoolean (self newerVersionsIn: aCollection) do: [:fn | | loader | loader := aBoolean ifTrue: [ MCVersionMerger new ] ifFalse: [ MCVersionLoader new]. loader addVersion: (self repository loadVersionFromFileNamed: fn). aBoolean ifTrue: [[loader merge] on: MCMergeResolutionRequest do: [:request | request merger conflicts isEmpty ifTrue: [request resume: true] ifFalse: [request pass]]] ifFalse: [loader load]]. ! ! !MetacelloScriptLoader methodsFor: 'load primitives' stamp: 'EstebanLorenzano 5/8/2012 12:17'! loadTogether: aCollection merge: aBoolean | loader | loader := aBoolean ifTrue: [ MCVersionMerger new ] ifFalse: [ MCVersionLoader new]. (self newerVersionsIn: aCollection) do: [:fn | loader addVersion: (self loadVersionFromFileNamed: fn)] displayingProgress: 'Adding versions...'. aBoolean ifTrue: [[loader merge] on: MCMergeResolutionRequest do: [:request | request merger conflicts isEmpty ifTrue: [request resume: true] ifFalse: [request pass]]] ifFalse: [loader hasVersions ifTrue: [loader load]] ! ! !MetacelloScriptLoader methodsFor: 'load primitives' stamp: 'StephaneDucasse 5/26/2012 22:04'! newerVersionsIn: aCollection ^aCollection reject: [:each | self allManagers anySatisfy: [:workingcopy | workingcopy ancestry ancestorString , '.mcz' = each]].! ! !MetacelloScriptLoader methodsFor: 'log' stamp: 'EstebanLorenzano 5/8/2012 12:17'! log: aString self logStream cr; nextPutAll: aString ; cr.! ! !MetacelloScriptLoader methodsFor: 'log' stamp: 'EstebanLorenzano 5/8/2012 12:17'! logContents ^ self logStream contents! ! !MetacelloScriptLoader methodsFor: 'log' stamp: 'EstebanLorenzano 5/8/2012 12:17'! logStream ^ LogStream ifNil: [ LogStream := ReadWriteStream on: (String new: 1000)]! ! !MetacelloScriptLoader methodsFor: 'log' stamp: 'EstebanLorenzano 5/8/2012 12:17'! withUpdateLog: aString self logStream nextPutAll: ' ------------------------------------------------------' ; cr. self logStream nextPutAll: thisContext sender selector asString. self logStream cr; nextPutAll: aString ; cr.! ! !MetacelloScriptLoader methodsFor: 'mc public utils' stamp: 'EstebanLorenzano 5/8/2012 12:17'! addExtraRepositories "self new addExtraRepositories" self addRepository39ToAllPackages. self addRepository310ToAllPackages. self addRepositoryTaskForcesToAllPackages. self addRepositorySqueakTrunkToAllPackages. self addRepositoryMCToAllPackages. self addRepositoryTreatedToAllPackages.! ! !MetacelloScriptLoader methodsFor: 'mc public utils' stamp: 'StephaneDucasse 5/26/2012 22:04'! deletePackage: aString | toRemove | toRemove := (self allManagers asSortedCollection: [ :a :b | a package name <= b package name ]) detect: [:each | each package name = aString]. MCWorkingCopy registry removeKey: toRemove package.! ! !MetacelloScriptLoader methodsFor: 'mc public utils' stamp: 'StephaneDucasse 5/26/2012 22:05'! unloadPackage: aString "self new unloadPackage: 'Sixx'" | toRemove | toRemove := (self allManagers asSortedCollection: [ :a :b | a package name <= b package name ]) detect: [:each | each package name = aString]. toRemove unload.! ! !MetacelloScriptLoader methodsFor: 'mc related utils' stamp: 'StephaneDucasse 5/26/2012 22:03'! addHomeRepositoryToAllPackages "self new addHomeRepositoryToAllPackages" self allManagers do: [:each | each repositoryGroup addRepository: self repository; addRepository: self inboxRepository; addRepository: self repositoryTreated ]. MCRepositoryGroup default addRepository: self repository; addRepository: self inboxRepository; addRepository: self repositoryTreated. ! ! !MetacelloScriptLoader methodsFor: 'mc related utils' stamp: 'EstebanLorenzano 5/8/2012 12:17'! addHomeRepositoryToPackageNamed: aString |pa| pa := MCPackage named: aString. pa workingCopy repositoryGroup addRepository: self repository. ! ! !MetacelloScriptLoader methodsFor: 'mc related utils' stamp: 'EstebanLorenzano 5/8/2012 12:17'! addPackage: aString "to be tested" | workingCopy | PackageInfo registerPackageName: aString. workingCopy := MCWorkingCopy forPackage: (MCPackage new name: aString)! ! !MetacelloScriptLoader methodsFor: 'mc related utils' stamp: 'StephaneDucasse 5/26/2012 22:03'! addRepositoryMCToAllPackages "self new addRepositoryMCToAllPackages" self allManagers do: [:each | each repositoryGroup addRepository: self repositoryMC ]. ! ! !MetacelloScriptLoader methodsFor: 'mc related utils' stamp: 'StephaneDucasse 5/26/2012 22:03'! addRepositorySqueakTrunkToAllPackages "self new removeAllRepositories: #('http://www.squeaksource.com/Sapphire/' 'http://www.squeaksource.com/SapphireInbox/')" "self new addRepositorySqueakTrunkToAllPackages" self allManagers do: [:each | each repositoryGroup addRepository: self repositorySqueakTrunk ]. ! ! !MetacelloScriptLoader methodsFor: 'mc related utils' stamp: 'StephaneDucasse 5/26/2012 22:03'! addRepositoryTaskForcesToAllPackages "self new addRepositoryTaskForcesToAllPackages" self allManagers do: [:each | each repositoryGroup addRepository: self repositoryTaskForces ]. ! ! !MetacelloScriptLoader methodsFor: 'mc related utils' stamp: 'EstebanLorenzano 5/8/2012 12:17'! addRepositoryToPackageNamed: aString |pa| pa := MCPackage named: aString. pa workingCopy repositoryGroup addRepository: self repository. ! ! !MetacelloScriptLoader methodsFor: 'mc related utils' stamp: 'StephaneDucasse 5/26/2012 22:03'! addRepositoryTreatedToAllPackages "self new addRepositoryTreatedToAllPackages" self allManagers do: [:each | each repositoryGroup addRepository: self repositoryTreated ]. ! ! !MetacelloScriptLoader methodsFor: 'mc related utils' stamp: 'EstebanLorenzano 5/8/2012 12:17'! allCurrentDirtyPackages "ScriptLoader new allCurrentDirtyPackages" "return all the current dirty packages even the ones that we do not want to save" ^ self allCurrentPackages select: [:each | each needsSaving]. ! ! !MetacelloScriptLoader methodsFor: 'mc related utils' stamp: 'StephaneDucasse 5/26/2012 22:04'! allCurrentPackages "ScriptLoader new allCurrentPackages" | copies | copies := self allManagers asSortedCollection: [ :a :b | a package name <= b package name ]. ^ copies! ! !MetacelloScriptLoader methodsFor: 'mc related utils' stamp: 'StephaneDucasse 5/26/2012 22:04'! currentPackages "self new currentPackages" | copies | copies := self allManagers asSortedCollection: [ :a :b | a package name <= b package name ]. ^ copies reject: [:each | self packagesNotToSavePatternNames anySatisfy: [:p | p match: each package name]]. ! ! !MetacelloScriptLoader methodsFor: 'mc related utils' stamp: 'StephaneDucasse 5/26/2012 22:04'! currentVersions "ScriptLoader new currentVersions" | copies | copies := self allManagers asSortedCollection: [ :a :b | a package name <= b package name ]. ^ copies collect: [:ea | ea ancestry ancestorString ]! ! !MetacelloScriptLoader methodsFor: 'mc related utils' stamp: 'SeanDeNigris 8/26/2012 15:51'! installRepository: aString for: packageName (self allManagers select: [:each | each package name = packageName]) first repositoryGroup addRepository: (MCHttpRepository location: aString) ! ! !MetacelloScriptLoader methodsFor: 'mc related utils' stamp: 'EstebanLorenzano 5/8/2012 12:17'! latestScriptLoaderPackageIdentificationString "ScriptLoader new latestScriptLoaderPackageIdentificationString" ^ self allCurrentVersions detect: [:each | 'ScriptLoader*' match: each ] ! ! !MetacelloScriptLoader methodsFor: 'mc related utils' stamp: 'StephaneDucasse 5/26/2012 22:04'! removeAllHTTPRepositories: aColl "self new removeAllRepositories: #('http://source.squeakfoundation.org/inbox/' 'http://source.squeakfoundation.org/39a/' 'http://source.squeakfoundation.org/Balloon/' 'http://source.squeakfoundation.org/Compression/' 'http://source.squeakfoundation.org/Graphics/' 'http://source.wiresong.ca/mc/')" self allManagers do: [:each | aColl do: [:location | each repositoryGroup removeHTTPRepositoryLocationNamed: location]]. ! ! !MetacelloScriptLoader methodsFor: 'mc related utils' stamp: 'StephaneDucasse 5/26/2012 22:04'! removeAllRepositories "self new removeAllRepositories" self allManagers do: [:each | each repositoryGroup initialize]. MCRepositoryGroup default initialize. ! ! !MetacelloScriptLoader methodsFor: 'mc related utils' stamp: 'EstebanLorenzano 5/8/2012 12:17'! saveInToReloadCachePackage: aWorkingCopy with: aMessageString self savePackage: aWorkingCopy in: self class defaultMCWaitingFolder with: aMessageString! ! !MetacelloScriptLoader methodsFor: 'mc related utils' stamp: 'SeanDeNigris 7/17/2012 15:50'! savePackage: aWorkingCopy in: aRepository with: aMessageString " | sc | sc := self new. sc savePackage: (self new workingCopyFromPackageName: 'ScriptLoader11') in: MCCacheRepository uniqueInstance with: 'this is test to automate dirty package saving in cache'" aRepository storeVersion: (aWorkingCopy newVersionWithName: aWorkingCopy uniqueVersionName message: aMessageString)! ! !MetacelloScriptLoader methodsFor: 'menu integration actions' stamp: 'CamilloBruni 5/10/2012 15:58'! checkImageIsUptodate ^ self checkImageIsUptodateSilently ! ! !MetacelloScriptLoader methodsFor: 'menu integration actions' stamp: 'MarcusDenker 7/10/2012 10:35'! doneApplyingChanges | comment commentQuoted st | Smalltalk image saveSession. "now you can reopen prior to publishing to fix :)" self saveAsNewImageWithCurrentReleaseNameToPublish. comment := UIManager default multiLineRequest: 'Comment for this update.' initialAnswer: self commentForCurrentUpdate answerHeight: 200. comment ifNil: [^ self]. commentQuoted := comment copyReplaceAll: (String with: $') with: (String with: $' with: $'). st := String new writeStream. st nextPutAll: 'commentForCurrentUpdate'; cr. st nextPutAll: ' ^ '. st nextPut: $'. st nextPutAll: commentQuoted. st nextPut: $'. self class compile: (st contents) classified: 'public'. self class waitingCacheFolder deleteAllChildren. self saveChangedPackagesIntoWaitingFolder. self generateScriptAndUpdateMethodForNewVersion. self saveLatestScriptLoaderToWaitingFolder. self inform: 'Update prepared and ready to be verified.'! ! !MetacelloScriptLoader methodsFor: 'menu integration actions' stamp: 'EstebanLorenzano 5/8/2012 12:17'! launchUpdate UpdateStreamer new updateFromServer! ! !MetacelloScriptLoader methodsFor: 'menu integration actions' stamp: 'CamilloBruni 5/9/2012 13:00'! prepareNewUpdate self launchUpdate. self loadLatestScriptloader. self markPackagesBeforeNewCodeIsLoaded. self checkImageIsUptodate ifFalse: [self loadLatestUpdateList]. self checkImageIsUptodate ifFalse: [ ^ self inform: 'Your update.list and your image are not in sync!! Please use a fresh image and download the latest update.list and start over. May be you are doing a rollback and you should remove the bogus ScriptLoader version from the Pharo repository' ]. self setUpdateAndScriptVersionNumbers. self saveAsNewImageWithCurrentReleaseName. self inform: 'The new version number is ' , self currentUpdateVersionNumber asString , '. Ready to apply changes now.', String cr, 'You are now running in image ', (Smalltalk imageFile basename).! ! !MetacelloScriptLoader methodsFor: 'menu integration actions' stamp: 'EstebanLorenzano 5/8/2012 12:17'! publishChanges | username password changescriptname changesetFilename str strings| (FileStream isAFileNamed: 'PharoPass.txt') ifTrue: [ str := FileStream fileNamed: 'PharoPass.txt'. strings := str contents substrings. username := strings first. password := strings second] ifFalse: [ username := UIManager default request: 'Pharo repository login'. password := UIManager default requestPassword: 'Pharo repository password'.]. self setToRepositoriesPassword: password to: username. changescriptname := UIManager default request: 'Changeset name (no space)' initialAnswer: 'WhatAsChanged'. changesetFilename := self CSForLastUpdateAndPatchUpdatesList: changescriptname. self copyPackagesFromWaitingFolderToHomeRepository. self announceOnMailingList. self inform: 'All packages have been uploaded to the Pharo repository. Remaining manual steps: 1) ./upFilesXX ',changesetFilename,' 2) ./upFilesXX updatesXX.list 3) Announce new update on mailing list'! ! !MetacelloScriptLoader methodsFor: 'menu integration actions' stamp: 'MarcusDenker 7/10/2012 10:36'! saveImageForRunningTests | comment commentQuoted st resuming | resuming := false. Smalltalk image saveSession ifFalse: [ resuming := true]. resuming ifTrue: [ self saveAsImageAsTestImage. self inform: 'Now you can use this image named ''Test'' to run the tests and come back to fix problems in the \ previous one and eventually freeze it by selecting the next step, in either one.' withCRs]! ! !MetacelloScriptLoader methodsFor: 'menu integration actions' stamp: 'EstebanLorenzano 5/8/2012 12:17'! verifyNewUpdate self repository: self class defaultMCWaitingFolder. self class loadLatestPackage: 'ScriptLoader' fromRepository: self repository. self perform: ('update' , self getLatestUpdateNumber asString) asSymbol. (self confirm: 'Completed loading the new update. Run all test now?') ifTrue: [ Author fullName: 'tester'. Smalltalk globals at: #TestRunner ifPresent: [ :class | class open model runAll ] ]! ! !MetacelloScriptLoader methodsFor: 'new script-update format' stamp: 'EstebanLorenzano 5/16/2012 13:10'! newGenerateNewUpdateMethod "self new newGenerateNewUpdateMethod" ^'update{1} (ConfigurationOfPharo20 project version: ''{1}'') load. self postUpdate. ' format: {self currentUpdateVersionNumber}. ! ! !MetacelloScriptLoader methodsFor: 'new script-update format' stamp: 'EstebanLorenzano 5/8/2012 12:17'! newGenerateScriptTemplateWithCurrentPackages: aNumber "ScriptLoader new generateScriptTemplateWithCurrentPackages" "this version change the script to only " | str withoutScriptLoader | str := ReadWriteStream on: (String new: 1000). str nextPutAll: 'script', aNumber asString ; cr ; cr ; tab. str nextPutAll: '^ '. str nextPut: $'. withoutScriptLoader := self currentVersionsToBeSaved. withoutScriptLoader do: [ :each | str nextPutAll: each ; nextPutAll: '.mcz'] separatedBy: [str nextPut: Character cr]. str nextPut: $'; nextPut: Character cr. str nextPutAll: 'findTokens: String lf , String cr'. ^ str contents! ! !MetacelloScriptLoader methodsFor: 'pharo - updates' stamp: 'EstebanLorenzano 5/11/2012 14:31'! update20067 ! ! !MetacelloScriptLoader methodsFor: 'pharo - updates' stamp: 'EstebanLorenzano 5/16/2012 11:30'! update20074! ! !MetacelloScriptLoader methodsFor: 'pharo - updates' stamp: 'EstebanLorenzano 5/16/2012 14:17'! update20075 (ConfigurationOfPharo20 project version: '20075') load. self postUpdate. ! ! !MetacelloScriptLoader methodsFor: 'public' stamp: 'EstebanLorenzano 5/16/2012 14:14'! commentForCurrentUpdate ^ 'Issue 5906: Better comment for Class>>#copy http://code.google.com/p/pharo/issues/detail?id=5906 Issue 5898: Fixing version browsing and ring historical behavior http://code.google.com/p/pharo/issues/detail?id=5898 Issue 5895: Change History separator in nautilus history http://code.google.com/p/pharo/issues/detail?id=5895 Issue 5894: Mini improvement in MethodWidget API http://code.google.com/p/pharo/issues/detail?id=5894 '! ! !MetacelloScriptLoader methodsFor: 'utils' stamp: 'EstebanLorenzano 5/8/2012 12:18'! generateCompleteFixList "generateCompleteFixList" | stream | stream := (FileStream newFileNamed: 'changes-log.txt'). [ stream nextPutAll: ScriptLoader new logStream contents ] ensure: [ stream close ]! ! !MetacelloScriptLoader methodsFor: 'utils' stamp: 'EstebanLorenzano 5/8/2012 12:18'! openWindow: contents label: aLabel StringHolder new contents: contents ; openLabel: aLabel! ! !MetacelloScriptLoader methodsFor: 'utils' stamp: 'EstebanLorenzano 5/8/2012 12:18'! removeScriptMethods "self new removeScriptMethods" ((ScriptLoader organization listAtCategoryNamed: 'pharo - scripts') asSortedCollection allButLast) do: [:each | ScriptLoader removeSelector: each].! ! !MetacelloScriptLoader methodsFor: 'utils' stamp: 'EstebanLorenzano 5/8/2012 12:18'! removeUpdateMethods ((ScriptLoader organization listAtCategoryNamed: 'pharo - updates') asSortedCollection allButLast) do: [:each | ScriptLoader removeSelector: each].! ! !MetacelloScriptLoader methodsFor: 'utils' stamp: 'StephaneDucasse 6/17/2012 22:47'! shortImageName "should be removed when the version will be integrated in SmalltalkImage" ^ Smalltalk shortImageName copyUpToLast: $. ! ! !MetacelloScriptLoader methodsFor: 'private' stamp: 'StephaneDucasse 5/26/2012 22:03'! addRepository310ToAllPackages "self new addRepository310ToAllPackages" self allManagers do: [:each | each repositoryGroup addRepository: self repository310 ]. ! ! !MetacelloScriptLoader methodsFor: 'private' stamp: 'StephaneDucasse 5/26/2012 22:03'! addRepository39ToAllPackages "self new removeAllRepositories: #('http://www.squeaksource.com/Sapphire/' 'http://www.squeaksource.com/SapphireInbox/')" "self new addRepository39ToAllPackages" self allManagers do: [:each | each repositoryGroup addRepository: self repository39 ]. ! ! !MetacelloScriptLoader methodsFor: 'private' stamp: 'StephaneDucasse 10/16/2012 11:42'! announceOnMailingList "self new announceOnMailingList" | title contents | title := '[update ', self currentMajorVersionNumber asString , '] #', self currentUpdateVersionNumber asString. contents := String streamContents: [:str | str nextPutAll: title; cr ; nextPutAll: self currentUpdateVersionNumber asString; nextPutAll: ' ----- '; nextPutAll: self commentForCurrentUpdate. self produceDiffLinksForPackages do: [:each | ] str contents ]. UIManager default edit: contents label: title.! ! !MetacelloScriptLoader methodsFor: 'private' stamp: 'EstebanLorenzano 5/8/2012 12:18'! buildConfigurationMapFor: packageNames | configurationMap | configurationMap := MCConfiguration new. configurationMap repositories add: self repository; add: self inboxRepository. packageNames do: [:packageName | | version depArray | version := self loadVersionFromFileNamed: packageName. depArray := { version package name. version info name. version info id asString. }. configurationMap dependencies add: (MCConfiguration dependencyFromArray: depArray)]. ^configurationMap! ! !MetacelloScriptLoader methodsFor: 'private' stamp: 'CamilloBruni 10/1/2012 12:53'! loadLatestUpdateList "fetch the latest version of the update.list on the server" | result listToUse lastUpdate | result := ZnClient new systemPolicy; beOneShot; setAcceptEncodingGzip; accept: ZnMimeType text; url: (UpdateStreamer new updateFolderURL, self updatesListFileName); ifFail: [ :exception | self error: 'Cannot access update server: ' , exception printString ]; get. (listToUse := result lines) isEmpty ifTrue: [ self error: 'Update list is empty' ]. lastUpdate := listToUse last. (lastUpdate beginsWith: self getLatestUpdateNumber asString) ifTrue: ["Write this file as our current updates.list" self updatesListFileName asFileReference delete; writeStreamDo: [:stream | stream nextPutAll: result ] ] ifFalse: [ self inform: 'Image update version did not match automatically fetched update.list!! Proceed after downloading using the script ./getUpdatesList instead' ]. ! ! !MetacelloScriptLoader methodsFor: 'private' stamp: 'EstebanLorenzano 5/8/2012 12:18'! loadVersionFromFileNamed: fn | version | version := self repository loadVersionFromFileNamed: fn. ^version ifNil: [self inboxRepository loadVersionFromFileNamed: fn]! ! !MetacelloScriptLoader methodsFor: 'private' stamp: 'EstebanLorenzano 5/8/2012 12:25'! packagesNotToSavePatternNames ^ #( 'ScriptLoader*' 'Metacello*' 'SLICE*' 'Slice*' 'slice*' 'ConfigurationOf*' ).! ! !MetacelloScriptLoader methodsFor: 'private' stamp: 'StephaneDucasse 5/26/2012 22:04'! postUpdate "Post update processing" "Flush caches" self flushCaches. "Remove metacello" Smalltalk globals at: #ConfigurationOfMetacello ifPresent: [ :c | c unloadMetacello ]. "Remove configurations" (self allManagers select: [ :each | 'ConfigurationOf*' match: each packageName ]) do: #unload. "Remove extra repositories" (MCRepositoryGroup default repositories select: [ :each | '*metacello*' match: each description ]) do: [ :each | MCRepositoryGroup default removeRepository: each ]. "Rehash symbols" Symbol rehash.! ! !MetacelloScriptLoader methodsFor: 'private' stamp: 'MarcusDenker 7/10/2012 10:36'! saveAsImageAsTestImage "Now you can run tests and see and go back to the previous image and do that go and back.... then after you can decide to freeze" | file | file := FileSystem workingDirectory / (self shortImageName, '-imageForTests') , Smalltalk imageSuffix. Smalltalk image saveAs: file nextVersion basename.! ! !MetacelloScriptLoader methodsFor: 'private' stamp: 'MarcusDenker 7/10/2012 10:36'! saveAsNewImageWithCurrentReleaseName | file | file := FileSystem workingDirectory / (('Pharo-', self currentUpdateVersionNumber asString), '-Release'), Smalltalk imageSuffix. Smalltalk image saveAs: (file nextVersion basename copyUpToLast: Path extensionDelimiter). ! ! !MetacelloScriptLoader methodsFor: 'private' stamp: 'MarcusDenker 7/10/2012 10:36'! saveAsNewImageWithCurrentReleaseNameToPublish "If the reload failed and you do not want to lose time reload all the cs and packages... you can now restart from the image saved now" | file | file := FileSystem workingDirectory / (self shortImageName, '-releasePharoToPublish'), Smalltalk imageSuffix. Smalltalk image saveAs: file nextVersion basename.! ! !MetacelloScriptLoader methodsFor: 'private' stamp: 'EstebanLorenzano 5/8/2012 12:18'! setToRepositoriesPassword: aPassword to: aUser "self new setToRepositoriesPassword: 'sd' to: 'zork'" MCRepositoryGroup instVarNamed: 'default' put: nil. self removeAllHTTPRepositories: {self repository locationWithTrailingSlash . self inboxRepository locationWithTrailingSlash}. self repository password: aPassword. self repository user: aUser. self inboxRepository password: aPassword. self inboxRepository user: aUser. self addHomeRepositoryToAllPackages! ! !MetacelloScriptLoader methodsFor: 'private' stamp: 'SeanDeNigris 7/12/2012 08:44'! updatesListFile ^ self updatesListFileName asFileReference! ! !MetacelloScriptLoader methodsFor: 'private' stamp: 'EstebanLorenzano 5/8/2012 12:18'! updatesListFileName ^ 'updates', (SystemVersion current majorMinor:''), '.list'! ! !MetacelloScriptLoader methodsFor: 'private' stamp: 'EstebanLorenzano 5/8/2012 12:18'! waitingFolderMCZFiles ^ self class defaultMCWaitingFolder allFileNames reject: [:each | each = '.DS_Store']! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MetacelloScriptLoader class instanceVariableNames: ''! !MetacelloScriptLoader class methodsFor: 'loadscripts' stamp: 'EstebanLorenzano 5/8/2012 12:18'! gofer ^ Smalltalk globals at: #Gofer ifAbsent: [ (self new) installGofer; gofer ]! ! !MetacelloScriptLoader class methodsFor: 'loadscripts' stamp: 'EstebanLorenzano 5/8/2012 12:18'! initialize self flag: #shouldRemoveNumber. CurrentMajorVersionNumber := 2.0! ! !MetacelloScriptLoader class methodsFor: 'menu' stamp: 'EstebanLorenzano 5/8/2012 12:18'! currentlyIntegratingChanges CurrentlyIntegratingChanges isNil ifTrue: [self hideIntegrationMenu]. ^ CurrentlyIntegratingChanges! ! !MetacelloScriptLoader class methodsFor: 'menu' stamp: 'EstebanLorenzano 5/8/2012 12:18'! hideIntegrationMenu CurrentlyIntegratingChanges := false.! ! !MetacelloScriptLoader class methodsFor: 'menu' stamp: 'EstebanLorenzano 5/16/2012 16:47'! menuCommandOn: aBuilder "" (aBuilder item: #'Integrator Menu') order: 1.5; precondition: [ self currentlyIntegratingChanges ]; parent: #System; icon: self theme smallAuthoringToolsIcon; action: [ self releaseMenu ]! ! !MetacelloScriptLoader class methodsFor: 'menu' stamp: 'EstebanLorenzano 5/8/2012 12:18'! showIntegrationMenu CurrentlyIntegratingChanges := true.! ! !MetacelloScriptLoader class methodsFor: 'menu' stamp: 'EstebanLorenzano 5/8/2012 12:18'! theme ^ UITheme current ! ! !MetacelloScriptLoader class methodsFor: 'public' stamp: 'EstebanLorenzano 5/8/2012 12:18'! checkImageInSyncWithUpdate "most of the time you want to make sure that your image is in sync with the latest item of the update.list but in some cases you do not to get forced to have this behavior." ^ CheckImageInSyncWithUpdate ifNil: [CheckImageInSyncWithUpdate := true]! ! !MetacelloScriptLoader class methodsFor: 'public' stamp: 'EstebanLorenzano 5/8/2012 12:18'! checkImageInSyncWithUpdate: aBoolean CheckImageInSyncWithUpdate := aBoolean! ! !MetacelloScriptLoader class methodsFor: 'public' stamp: 'EstebanLorenzano 5/8/2012 12:18'! currentMajorVersionNumber ^ CurrentMajorVersionNumber ! ! !MetacelloScriptLoader class methodsFor: 'public' stamp: 'EstebanLorenzano 5/8/2012 12:18'! currentMajorVersionNumber: aNumber CurrentMajorVersionNumber := aNumber! ! !MetacelloScriptLoader class methodsFor: 'public' stamp: 'EstebanLorenzano 5/16/2012 13:44'! releaseMenu "self releaseMenu" |symbol| symbol := UIManager default chooseFrom: #( '1- Prepare new update' '2- Save new image for testing (optional)' '3- Freeze changes: packages will be saved (required)' '4- Verify new update (open the mother image in the same folder) (optional)' '5- Publish changes') values: #( prepareNewUpdate saveImageForRunningTests doneApplyingChanges verifyNewUpdate publishChanges). symbol ifNotNil: [ self new perform: symbol ]! ! !MetacelloScriptLoader class methodsFor: 'public' stamp: 'EstebanLorenzano 5/8/2012 12:18'! resetLogStream LogStream := nil! ! !MetacelloScriptLoader class methodsFor: 'source' stamp: 'EstebanLorenzano 5/8/2012 12:18'! latestSource: packageName location: location | contents versionName zip | versionName := location, '/', (self latestVersionOf: packageName location: location). contents := ZnClient new systemPolicy; beOneShot; url: versionName; ifFail: [ :exception | self error: 'Cannot access latest source: ' , exception printString ]; get. zip := ZipArchive new. zip readFrom: contents readStream. ^ (zip memberNamed: 'snapshot/source.st') contents.! ! !MetacelloScriptLoader class methodsFor: 'source' stamp: 'SeanDeNigris 8/26/2012 11:58'! latestVersionOf: packageName location: location | repository sortMczs fileToLoad | repository := MCHttpRepository location: location. sortMczs := [:a :b | [(a findBetweenSubStrs: #($.)) allButLast last asInteger > (b findBetweenSubStrs: #($.)) allButLast last asInteger] on: Error do: [:ex | false]]. fileToLoad := (repository readableFileNames asSortedCollection: sortMczs) detect: [:file | file beginsWith: (packageName, '-')]. ^ fileToLoad! ! !MetacelloScriptLoader class methodsFor: 'private' stamp: 'EstebanLorenzano 5/8/2012 12:18'! defaultMCWaitingFolder "self defaultMCWaitingFolder" ^ MCDirectoryRepository new directory: self waitingCacheFolder! ! !MetacelloScriptLoader class methodsFor: 'private' stamp: 'SeanDeNigris 8/26/2012 11:58'! loadLatestPackage: aString from: aPath | repository | repository := MCHttpRepository location: aPath. self loadLatestPackage: aString fromRepository: repository! ! !MetacelloScriptLoader class methodsFor: 'private' stamp: 'EstebanLorenzano 5/8/2012 12:18'! loadLatestPackage: aString fromRepository: aRepository | versionsBlock versions tries | versionsBlock := [ (aRepository allVersionNames select: [ :each | each beginsWith: aString ]) asSortedCollection: [ :a :b | (a copyAfterLast: $.) asNumber <= (b copyAfterLast: $.) asNumber]]. versions := versionsBlock value. tries := 0. [ versions isEmpty and: [ tries < 3 ] ] whileTrue: [ versions := versionsBlock value. tries := tries + 1 ]. versions isEmpty ifTrue: [ self error: 'problems when accessing squeaksource' ]. aRepository versionReaderForFileNamed: (versions last , '.mcz') do: [:reader | | version | version := reader version. version load. version workingCopy repositoryGroup addRepository: aRepository]! ! !MetacelloScriptLoader class methodsFor: 'private' stamp: 'EstebanLorenzano 5/8/2012 12:18'! loadLatestPackage: aString fromSqueaksource: aDirectoryName " self loadLatestPackage: 'ScriptLoader' fromSqueaksource: 'Pharo' " self loadLatestPackage: aString from: self rootURLString, aDirectoryName ! ! !MetacelloScriptLoader class methodsFor: 'private' stamp: 'EstebanLorenzano 5/8/2012 12:18'! rootURLString ^ 'http://ss3.gemstone.com/ss/'! ! Notification subclass: #MetacelloSkipDirtyPackageLoad instanceVariableNames: 'packageSpec' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Exceptions'! !MetacelloSkipDirtyPackageLoad methodsFor: 'accessing' stamp: 'dkh 11/16/2011 10:13'! defaultAction "Default action is to skip the load of a dirty package" ^true! ! !MetacelloSkipDirtyPackageLoad methodsFor: 'accessing' stamp: 'dkh 11/16/2011 10:10'! packageSpec ^packageSpec! ! !MetacelloSkipDirtyPackageLoad methodsFor: 'accessing' stamp: 'dkh 11/16/2011 10:10'! packageSpec: aMetacelloPackageSpec packageSpec := aMetacelloPackageSpec! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MetacelloSkipDirtyPackageLoad class instanceVariableNames: ''! !MetacelloSkipDirtyPackageLoad class methodsFor: 'signalling' stamp: 'dkh 11/16/2011 10:12'! signal: aMetacelloPackageSpec ^(self new packageSpec: aMetacelloPackageSpec) signal! ! Object subclass: #MetacelloSpec instanceVariableNames: 'project loader' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Specs'! !MetacelloSpec methodsFor: 'accessing' stamp: 'dkh 6/18/2009 10:30'! 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: 'accessing' stamp: 'dkh 6/18/2009 09:46'! loader: aLoader "We're interested in propogating the loader state, _except_ for the spec" loader := aLoader copy. loader spec: self! ! !MetacelloSpec methodsFor: 'copying' stamp: 'dkh 10/4/2009 18:56'! postCopy super postCopy. loader ~~ nil ifTrue: [ self loader: loader ]! ! !MetacelloSpec methodsFor: 'doits' stamp: 'dkh 12/30/2009 13:17'! 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: 'doits' stamp: 'dkh 12/30/2009 13:20'! postLoadDoIt "noop unless non-nil value returned" ^nil! ! !MetacelloSpec methodsFor: 'doits' stamp: 'DaleHenrichs 12/21/2010 11:47'! postLoadDoItBlock ^self doItBlock: self postLoadDoIt value ! ! !MetacelloSpec methodsFor: 'doits' stamp: 'dkh 12/30/2009 13:20'! preLoadDoIt "noop unless non-nil value returned" ^nil! ! !MetacelloSpec methodsFor: 'doits' stamp: 'DaleHenrichs 12/21/2010 11:49'! preLoadDoItBlock ^self doItBlock: self preLoadDoIt value ! ! !MetacelloSpec methodsFor: 'initialization' stamp: 'dkh 06/02/2009 18:05'! for: aProject project := aProject! ! !MetacelloSpec methodsFor: 'merging' stamp: 'dkh 06/04/2009 14:40'! mergeMap ^Dictionary new. ! ! !MetacelloSpec methodsFor: 'merging' stamp: 'DaleHenrichs 11/27/2010 12:16'! mergeSpec: aSpec | newSpec nonOverridable | aSpec class = self class ifFalse: [ self error: 'The project spec ', self name printString, ' in project ', self project label, ' has imcompatible specs.' ]. 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: 'merging' stamp: 'dkh 9/23/2009 11:41'! nonOverridable ^#()! ! !MetacelloSpec methodsFor: 'printing' stamp: 'dkh 10/5/2009 09:14'! configMethodOn: aStream self configMethodOn: aStream indent: 0 ! ! !MetacelloSpec methodsFor: 'printing' stamp: 'dkh 10/5/2009 09:14'! configMethodOn: aStream indent: indent self subclassResponsibility ! ! !MetacelloSpec methodsFor: 'printing' stamp: 'DaleHenrichs 3/9/2010 16:33'! label ^self printString! ! !MetacelloSpec methodsFor: 'printing' stamp: 'dkh 10/5/2009 11:08'! printOn: aStream self configMethodOn: aStream indent: 0 ! ! !MetacelloSpec methodsFor: 'querying' stamp: 'DaleHenrichs 4/9/2010 12:47'! answers ^#()! ! !MetacelloSpec methodsFor: 'querying' stamp: 'dkh 06/02/2009 14:42'! project ^project! ! !MetacelloSpec methodsFor: 'spec creation' stamp: 'dkh 06/02/2009 16:54'! addMember ^MetacelloAddMemberSpec for: self project! ! !MetacelloSpec methodsFor: 'spec creation' stamp: 'dkh 10/4/2009 10:44'! copyMember ^MetacelloCopyMemberSpec for: self project! ! !MetacelloSpec methodsFor: 'spec creation' stamp: 'dkh 06/02/2009 16:54'! mergeMember ^MetacelloMergeMemberSpec for: self project! ! !MetacelloSpec methodsFor: 'spec creation' stamp: 'dkh 06/02/2009 16:54'! removeMember ^MetacelloRemoveMemberSpec for: self project! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MetacelloSpec class instanceVariableNames: ''! !MetacelloSpec class methodsFor: 'accessing' stamp: 'dkh 04/22/2009 12:22'! platformClass ^self! ! !MetacelloSpec class methodsFor: 'instance creation' stamp: 'dkh 05/01/2009 12:22'! for: aVersionMap ^(self platformClass new) for: aVersionMap; yourself! ! Object subclass: #MetacelloSpecLoader instanceVariableNames: 'spec' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Loaders'! !MetacelloSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/12/2009 14:17'! loadType "#atomic or #linear" ^self project loadType! ! !MetacelloSpecLoader methodsFor: 'accessing' stamp: 'dkh 6/12/2009 14:17'! project ^self spec project! ! !MetacelloSpecLoader methodsFor: 'accessing' stamp: 'dkh 04/23/2009 11:20'! spec ^spec! ! !MetacelloSpecLoader methodsFor: 'accessing' stamp: 'dkh 04/23/2009 11:20'! spec: aMetacelloPackagesSpec spec := aMetacelloPackagesSpec! ! !MetacelloSpecLoader methodsFor: 'actions' stamp: 'dkh 04/23/2009 11:21'! load self subclassResponsibility! ! !MetacelloSpecLoader methodsFor: 'actions' stamp: 'dkh 04/23/2009 11:48'! unload self subclassResponsibility! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MetacelloSpecLoader class instanceVariableNames: ''! !MetacelloSpecLoader class methodsFor: 'instance creation' stamp: 'dkh 04/23/2009 11:24'! on: aMetacelloPackagesSpec ^(self new) spec: aMetacelloPackagesSpec; yourself! ! Notification subclass: #MetacelloStackCacheNotification instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Exceptions'! MetacelloVersionDoesNotExistError subclass: #MetacelloSymbolicVersionDoesNotExistError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Exceptions'! !MetacelloSymbolicVersionDoesNotExistError methodsFor: 'printing' stamp: 'dkh 3/18/2011 15:00'! 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.'! ! MetacelloMethodSpec subclass: #MetacelloSymbolicVersionMethodSpec instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Constructors'! !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! ! !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: '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! ! MetacelloSymbolicVersionDoesNotExistError subclass: #MetacelloSymbolicVersionNotDefinedError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Exceptions'! !MetacelloSymbolicVersionNotDefinedError methodsFor: 'printing' stamp: 'dkh 3/18/2011 15:00'! 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.'! ! MetacelloMethodSection subclass: #MetacelloSymbolicVersionSpec instanceVariableNames: 'versionString' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Constructors'! !MetacelloSymbolicVersionSpec methodsFor: 'accessing' stamp: 'DaleHenrichs 11/14/2010 10:12'! versionString ^ versionString! ! !MetacelloSymbolicVersionSpec methodsFor: 'accessing' stamp: 'DaleHenrichs 11/14/2010 10:12'! versionString: anObject versionString := anObject! ! Object subclass: #MetacelloToolBox instanceVariableNames: 'project methodSpec' classVariableNames: '' poolDictionaries: '' category: 'Metacello-ToolBox'! !MetacelloToolBox commentStamp: '' prior: 0! 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: 'accessing' stamp: 'dkh 3/7/2012 17:08:50'! constructor | constructor | constructor := MetacelloToolBoxConstructor new. constructor configuration: project configuration class new. ^constructor! ! !MetacelloToolBox methodsFor: 'accessing' stamp: 'dkh 3/7/2012 17:08:50'! methodSpec ^methodSpec! ! !MetacelloToolBox methodsFor: 'accessing' stamp: 'dkh 3/7/2012 17:08:50'! project ^project! ! !MetacelloToolBox methodsFor: 'accessing' stamp: 'dkh 3/7/2012 17:08:50'! project: aMetacelloProject project := aMetacelloProject! ! !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: '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: '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: '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 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'! commitConfiguration: commitComment! ! !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: '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'! 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: '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 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 3/7/2012 17:08:50'! imports: importList self methodSpec imports: importList! ! !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 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 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: 'api-configuration' stamp: 'dkh 3/7/2012 17:08:50'! modifySymbolicVersionMethodFor: versionSymbol ^self modifySymbolicVersionMethodFor: versionSymbol symbolicVersionSpecsDo: [:symbolicVersionSpec | true ]. ! ! !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: '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: '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: '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: '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: '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'! createGroupSpec: baseName ^ (self project groupSpec) name: baseName; yourself! ! !MetacelloToolBox methodsFor: 'spec creation' stamp: 'dkh 3/7/2012 17:08:50'! createPackageSpec: baseName ^ (project packageSpec) name: baseName; yourself! ! !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: '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: 'spec creation' stamp: 'dkh 3/7/2012 17:08:50'! createVersionSpec: versionString | versionSpec | versionSpec := project versionSpec. versionSpec versionString: versionString. ^ versionSpec! ! !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: 'CamilloBruni 11/2/2012 16:01'! 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: '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: '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: '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: 'private' stamp: 'dkh 3/7/2012 17:08:50'! configurationNameFrom: baseName ^self class configurationNameFrom: baseName! ! !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: 'private' stamp: 'dkh 3/7/2012 17:08:50'! ensureMetacello "noop for now"! ! !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 class instanceVariableNames: ''! !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: '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: '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: '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: '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'! 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: '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: '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: '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'! 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'! 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: '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: '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: 'help' stamp: 'dkh 3/7/2012 17:08:50'! helpTopicClass ^Smalltalk at: #HelpTopic ifAbsent: []! ! !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: 'instance creation' stamp: 'dkh 3/7/2012 17:08:50'! configurationNamed: baseName ^self new configurationNamed: baseName; yourself! ! !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: '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: '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: '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'! 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: '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: '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'! 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: '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: '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: 'scripts' stamp: 'dkh 3/7/2012 17:08:50'! 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: true 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'! 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'! 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: '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: '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: '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'! 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: '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: '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'! 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: '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'! 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: '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: '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: 'tool support' stamp: 'CamilloBruni 10/31/2012 18:23'! 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: 'utility' stamp: 'dkh 3/7/2012 17:08:50'! baseNameOf: configurationClassName "Return the baseName for the given configuration class name." ^ (configurationClassName indexOfSubCollection: 'ConfigurationOf') = 0 ifTrue: [ configurationClassName ] ifFalse: [ configurationClassName copyFrom: ('ConfigurationOf' size + 1) to: configurationClassName size]! ! !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: '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: 'utility' stamp: 'CamilloBruni 11/2/2012 16:08'! configurationClasses "Return a set of the Metacello configuration classes that have been loaded into the image." self flag: 'more work needed about MetacelloProjectRegistration'. ^ Array streamContents: [ :s| SystemNavigation default allClassesDo: [ :cls| (cls name beginsWith: 'ConfigurationOf') ifTrue: [ s nextPut: cls ]]]! ! !MetacelloToolBox class methodsFor: 'utility' stamp: 'CamilloBruni 11/2/2012 16:06'! configurationNameFrom: baseName "Return the fully-qualified configuration class name." self flag: 'More work needed based on MetacelloScriptEngine'. ^ 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: '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: 'validation' stamp: 'dkh 3/7/2012 17:08:50'! descriptionForValidationReasonCode: reasonCode "Description of validation reasonCode" ^MetacelloMCVersionValidator descriptionForReasonCode: reasonCode! ! !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: '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: '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: '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: '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 ]! ! !MetacelloToolBox class methodsFor: 'private' stamp: 'dkh 3/7/2012 17:08:50'! stripVersionStringForSelector: versionString ^((versionString copyWithout: $.) copyWithout: $-) copyReplaceAll: 'baseline' with: '' ! ! MetacelloAbstractVersionConstructor subclass: #MetacelloToolBoxConstructor instanceVariableNames: 'currentSection methodSections' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Constructors'! !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/5/2012 06:26:03.064'! 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: 'api callbacks' stamp: 'dkh 9/5/2012 06:26:03.064'! setFor: attributeList version: aString "conditional symbolicVersion support" self methodSections add: (MetacelloSymbolicVersionSpec new attributes: attributeList asMetacelloAttributeList; versionString: aString; yourself)! ! !MetacelloToolBoxConstructor methodsFor: 'enumeration' stamp: 'DaleHenrichs 12/23/2010 15:10'! methodSectionsDo: aBlock self methodSection: self do: aBlock ! ! !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: '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: '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: 'initialization' stamp: 'DaleHenrichs 11/18/2010 16:40'! reset super reset. "not needed, but included for completeness" methodSections := nil! ! !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: '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: '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: 'private' stamp: 'DaleHenrichs 11/14/2010 02:08'! methodSections methodSections == nil ifTrue: [ methodSections := OrderedCollection new ]. ^methodSections! ! MetacelloValidationIssue subclass: #MetacelloValidationCriticalWarning instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Validation'! !MetacelloValidationCriticalWarning commentStamp: '' prior: 0! MetacelloValidationCriticalWarning indicates that there is a logical inconsistency that may not be intentional and that could cause incorrect loads! !MetacelloValidationCriticalWarning methodsFor: 'accessing' stamp: 'DaleHenrichs 11/4/2010 12:27'! label ^'Critical Warning'! ! !MetacelloValidationCriticalWarning methodsFor: 'testing' stamp: 'DaleHenrichs 11/4/2010 12:27'! isCriticalWarning ^true! ! MetacelloValidationIssue subclass: #MetacelloValidationError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Validation'! !MetacelloValidationError commentStamp: '' prior: 0! MetacelloValidationError indicates that errors are to be expected if an attempt to use the configuration/version is made! !MetacelloValidationError methodsFor: 'accessing' stamp: 'DaleHenrichs 11/3/2010 16:37'! label ^'Error'! ! !MetacelloValidationError methodsFor: 'testing' stamp: 'DaleHenrichs 11/3/2010 16:44'! isError ^true! ! Error subclass: #MetacelloValidationFailure instanceVariableNames: 'issues' classVariableNames: '' poolDictionaries: '' category: 'Metacello-ToolBox'! !MetacelloValidationFailure methodsFor: 'accessing' stamp: 'CamilloBruni 11/2/2012 16:04'! issues ^ issues! ! !MetacelloValidationFailure methodsFor: 'accessing' stamp: 'CamilloBruni 11/2/2012 16:04'! issues: anObject issues := anObject! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MetacelloValidationFailure class instanceVariableNames: ''! !MetacelloValidationFailure class methodsFor: 'instance creation' stamp: 'CamilloBruni 11/2/2012 16:04'! issues: issues message: aMessage ^self new issues: issues; signal: aMessage! ! Object subclass: #MetacelloValidationIssue instanceVariableNames: 'configurationClass explanation reasonCode callSite' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Validation'! !MetacelloValidationIssue methodsFor: 'accessing' stamp: 'DaleHenrichs 11/20/2010 07:23'! callSite ^ callSite! ! !MetacelloValidationIssue methodsFor: 'accessing' stamp: 'DaleHenrichs 11/20/2010 07:23'! callSite: anObject callSite := anObject! ! !MetacelloValidationIssue methodsFor: 'accessing' stamp: 'DaleHenrichs 11/5/2010 10:20'! configurationClass ^ configurationClass! ! !MetacelloValidationIssue methodsFor: 'accessing' stamp: 'DaleHenrichs 11/5/2010 10:20'! configurationClass: aClass configurationClass := aClass! ! !MetacelloValidationIssue methodsFor: 'accessing' stamp: 'DaleHenrichs 11/3/2010 13:57'! explanation ^ explanation! ! !MetacelloValidationIssue methodsFor: 'accessing' stamp: 'DaleHenrichs 11/3/2010 13:58'! explanation: aString explanation := aString! ! !MetacelloValidationIssue methodsFor: 'accessing' stamp: 'DaleHenrichs 11/3/2010 16:37'! label ^''! ! !MetacelloValidationIssue methodsFor: 'accessing' stamp: 'DaleHenrichs 11/3/2010 20:36'! reasonCode reasonCode == nil ifTrue: [ reasonCode := #none ]. ^ reasonCode! ! !MetacelloValidationIssue methodsFor: 'accessing' stamp: 'DaleHenrichs 11/3/2010 20:32'! reasonCode: anObject reasonCode := anObject! ! !MetacelloValidationIssue methodsFor: 'printing' stamp: 'DaleHenrichs 12/4/2010 10:29'! 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: 'testing' stamp: 'DaleHenrichs 11/4/2010 12:27'! isCritical ^self isError or: [ self isCriticalWarning ]! ! !MetacelloValidationIssue methodsFor: 'testing' stamp: 'DaleHenrichs 11/4/2010 12:26'! isCriticalWarning ^false! ! !MetacelloValidationIssue methodsFor: 'testing' stamp: 'DaleHenrichs 11/3/2010 16:44'! isError ^false! ! !MetacelloValidationIssue methodsFor: 'testing' stamp: 'DaleHenrichs 11/3/2010 16:44'! isWarning ^false! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MetacelloValidationIssue class instanceVariableNames: ''! !MetacelloValidationIssue class methodsFor: 'instance creation' stamp: 'DaleHenrichs 11/30/2010 13:25'! configurationClass: aClass reasonCode: aSymbol callSite: aCallSite explanation: aString ^(self new) configurationClass: aClass; reasonCode: aSymbol; callSite: aCallSite; explanation: aString; yourself! ! Notification subclass: #MetacelloValidationNotification instanceVariableNames: 'issue' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Exceptions'! !MetacelloValidationNotification methodsFor: 'accessing' stamp: 'DaleHenrichs 11/4/2010 10:01'! issue ^ issue! ! !MetacelloValidationNotification methodsFor: 'accessing' stamp: 'DaleHenrichs 11/4/2010 10:01'! issue: anObject issue := anObject! ! !MetacelloValidationNotification methodsFor: 'signaling' stamp: 'DaleHenrichs 11/4/2010 10:01'! signal: aMetacelloValidationIssue self issue: aMetacelloValidationIssue. ^ self signal! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MetacelloValidationNotification class instanceVariableNames: ''! !MetacelloValidationNotification class methodsFor: 'exceptioninstantiator' stamp: 'DaleHenrichs 11/4/2010 10:00'! signal: aMetacelloValidationIssue ^ self new signal: aMetacelloValidationIssue! ! MetacelloValidationIssue subclass: #MetacelloValidationWarning instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Validation'! !MetacelloValidationWarning commentStamp: '' prior: 0! MetacelloValidationWarning indicates that there is a logical inconsistency that is not likely to cause any functional problems! !MetacelloValidationWarning methodsFor: 'accessing' stamp: 'DaleHenrichs 11/3/2010 16:37'! label ^'Warning'! ! !MetacelloValidationWarning methodsFor: 'testing' stamp: 'DaleHenrichs 11/3/2010 16:45'! isWarning ^true! ! MetacelloSpec subclass: #MetacelloValueHolderSpec instanceVariableNames: 'value' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Specs'! !MetacelloValueHolderSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2009 11:46'! value: anObject value := anObject! ! !MetacelloValueHolderSpec methodsFor: 'merging' stamp: 'dkh 6/5/2009 11:46'! mergeMap | map | map := super mergeMap. map at: #value put: value. ^map! ! !MetacelloValueHolderSpec methodsFor: 'printing' stamp: 'dkh 10/5/2009 12:23'! configMethodOn: aStream indent: indent aStream tab: indent; nextPutAll: 'spec value: ', self value printString! ! !MetacelloValueHolderSpec methodsFor: 'querying' stamp: 'dkh 6/5/2009 11:46'! value ^ value! ! !MetacelloValueHolderSpec methodsFor: 'private' stamp: 'dkh 9/13/2009 07:46'! setAuthorInMetacelloVersion: aMetacelloVersionSpec aMetacelloVersionSpec setAuthor: self! ! !MetacelloValueHolderSpec methodsFor: 'private' stamp: 'dkh 6/5/2009 10:49'! setBlessingInMetacelloVersion: aMetacelloVersionSpec aMetacelloVersionSpec setBlessing: self! ! !MetacelloValueHolderSpec methodsFor: 'private' stamp: 'dkh 6/5/2009 11:54'! setDescriptionInMetacelloVersion: aMetacelloVersionSpec aMetacelloVersionSpec setDescription: self! ! !MetacelloValueHolderSpec methodsFor: 'private' stamp: 'DaleHenrichs 12/21/2010 13:54'! setPostLoadDoItInMetacelloSpec: aMetacelloSpec aMetacelloSpec setPostLoadDoIt: self! ! !MetacelloValueHolderSpec methodsFor: 'private' stamp: 'DaleHenrichs 12/21/2010 13:54'! setPreLoadDoItInMetacelloSpec: aMetacelloSpec aMetacelloSpec setPreLoadDoIt: self! ! !MetacelloValueHolderSpec methodsFor: 'private' stamp: 'dkh 9/13/2009 07:47'! setTimestampInMetacelloVersion: aMetacelloVersionSpec aMetacelloVersionSpec setTimestamp: self! ! Magnitude subclass: #MetacelloVersion instanceVariableNames: 'spec versionNumber importedVersions versionStatus' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Model'! !MetacelloVersion methodsFor: 'accessing' stamp: 'dkh 1/7/2010 18:48'! importedVersions importedVersions == nil ifTrue: [ importedVersions := #() ]. ^importedVersions! ! !MetacelloVersion methodsFor: 'accessing' stamp: 'dkh 1/7/2010 18:57'! importedVersions: aCollection importedVersions := aCollection! ! !MetacelloVersion methodsFor: 'accessing' stamp: 'DaleHenrichs 3/9/2010 16:32'! projectLabel ^self spec projectLabel! ! !MetacelloVersion methodsFor: 'accessing' stamp: 'dkh 05/04/2009 20:26'! spec ^spec! ! !MetacelloVersion methodsFor: 'accessing' stamp: 'dkh 05/04/2009 20:26'! spec: aMetacellVersionSpec spec := aMetacellVersionSpec! ! !MetacelloVersion methodsFor: 'accessing' stamp: 'dkh 6/14/2009 09:39'! versionNumber: aVersionNumber versionNumber := aVersionNumber! ! !MetacelloVersion methodsFor: 'accessing' stamp: 'dkh 6/15/2009 20:07'! versionSpec ^self spec! ! !MetacelloVersion methodsFor: 'accessing' stamp: 'DaleHenrichs 2/6/2010 16:49'! versionStatus versionStatus == nil ifTrue: [ versionStatus := self computeVersionStatus]. ^versionStatus! ! !MetacelloVersion methodsFor: 'accessing' stamp: 'DaleHenrichs 2/4/2010 10:10'! versionStatus: aSymbol versionStatus := aSymbol! ! !MetacelloVersion methodsFor: 'actions' stamp: 'dkh 6/8/2009 17:45'! load ^self subclassResponsibility! ! !MetacelloVersion methodsFor: 'actions' stamp: 'dkh 6/8/2009 17:45'! load: required ^self subclassResponsibility! ! !MetacelloVersion methodsFor: 'actions' stamp: 'dkh 05/04/2009 20:26'! unload ^self spec unload! ! !MetacelloVersion methodsFor: 'comparing' stamp: 'dkh 6/14/2009 09:40'! < aMetacelloVersion aMetacelloVersion species = self species ifFalse: [ ^false ]. ^self versionNumber < aMetacelloVersion versionNumber! ! !MetacelloVersion methodsFor: 'comparing' stamp: 'dkh 6/14/2009 09:41'! = aMetacelloVersion aMetacelloVersion species = self species ifFalse: [ ^false ]. ^self versionNumber = aMetacelloVersion versionNumber! ! !MetacelloVersion methodsFor: 'comparing' stamp: 'dkh 6/14/2009 09:41'! hash ^self versionNumber hash! ! !MetacelloVersion methodsFor: 'comparing' stamp: 'dkh 6/14/2009 12:42'! ~> aMetacelloVersion aMetacelloVersion species = self species ifFalse: [ ^false ]. ^self versionNumber ~> aMetacelloVersion versionNumber! ! !MetacelloVersion methodsFor: 'printing' stamp: 'DaleHenrichs 11/16/2010 11:14'! printOn: aStream | label vs | self blessing ~~ #broken ifTrue: [ (vs := self versionStatus) == #somethingLoaded ifTrue: [ aStream nextPutAll: '<>' ]. vs == #loadedMatchConstraints ifTrue: [ aStream nextPutAll: '>=' ]. vs == #loadedToSpec ifTrue: [ aStream nextPut: $~ ] ]. self versionNumber printOn: aStream. self spec ~~ nil ifTrue: [ (label := self spec projectLabel) isEmpty ifFalse: [ aStream nextPutAll: ' [' , label , ']' ] ]! ! !MetacelloVersion methodsFor: 'querying' stamp: 'dkh 10/13/2009 13:00'! author ^self spec author value! ! !MetacelloVersion methodsFor: 'querying' stamp: 'dkh 8/9/2009 11:48'! blessing ^self spec blessing value! ! !MetacelloVersion methodsFor: 'querying' stamp: 'dkh 7/31/2009 11:48'! description ^self spec description value! ! !MetacelloVersion methodsFor: 'querying' stamp: 'DaleHenrichs 10/27/2010 11:30'! loader ^self spec loader! ! !MetacelloVersion methodsFor: 'querying' stamp: 'dkh 6/8/2009 16:03'! project ^self spec project! ! !MetacelloVersion methodsFor: 'querying' stamp: 'dkh 10/13/2009 13:01'! timestamp ^self spec timestamp value! ! !MetacelloVersion methodsFor: 'querying' stamp: 'DaleHenrichs 9/22/2010 13:52'! 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 spec ~~ nil ifTrue: [(label := self spec projectLabel) isEmpty ifFalse: [aStream nextPutAll: ' [' , label , ']']] ]! ! !MetacelloVersion methodsFor: 'querying' stamp: 'dkh 6/14/2009 09:39'! versionNumber ^versionNumber! ! !MetacelloVersion methodsFor: 'querying' stamp: 'dkh 8/31/2009 05:11'! versionString ^self versionNumber versionString ! ! !MetacelloVersion methodsFor: 'testing' stamp: 'DaleHenrichs 2/5/2010 10:56'! isAllLoadedToSpec "all projects and packages are loaded and match specification" ^self spec isAllLoadedToSpec! ! !MetacelloVersion methodsFor: 'testing' stamp: 'DaleHenrichs 2/5/2010 11:08'! isLoadedMatchConstraints "all loaded projects and packages match constraints" ^self spec isLoadedMatchConstraints! ! !MetacelloVersion methodsFor: 'testing' stamp: 'DaleHenrichs 2/5/2010 11:07'! isLoadedToSpec "all loaded projects and packages match specifications" ^self spec isLoadedToSpec! ! !MetacelloVersion methodsFor: 'testing' stamp: 'DaleHenrichs 2/4/2010 10:19'! isPossibleBaseline ^self spec isPossibleBaseline! ! !MetacelloVersion methodsFor: 'testing' stamp: 'DaleHenrichs 2/5/2010 11:15'! isSomethingLoaded "at least one project or package has been loaded" ^self spec isSomethingLoaded! ! !MetacelloVersion methodsFor: 'testing' stamp: 'DaleHenrichs 2/8/2010 11:42'! name ^self versionString! ! !MetacelloVersion methodsFor: 'private' stamp: 'dkh 7/8/2011 22:26'! 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! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MetacelloVersion class instanceVariableNames: ''! !MetacelloVersion class methodsFor: 'instance creation' stamp: 'tg 8/30/2009 18:07'! fromSpec: aMetacelloVersionSpec ^(self fromString: aMetacelloVersionSpec versionString) spec: aMetacelloVersionSpec; yourself! ! !MetacelloVersion class methodsFor: 'instance creation' stamp: 'dkh 8/31/2009 05:13'! fromString: aString ^self new versionNumber: aString asMetacelloVersionNumber! ! MetacelloAbstractVersionConstructor subclass: #MetacelloVersionConstructor instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Constructors'! !MetacelloVersionConstructor methodsFor: 'deprecated' stamp: 'DaleHenrichs 11/18/2010 16:48'! 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: 'deprecated' stamp: 'DaleHenrichs 12/4/2010 09:53'! 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: 'deprecated' stamp: 'DaleHenrichs 12/4/2010 09:54'! 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: 'initialization' stamp: 'dkh 7/8/2011 18:57'! calculate: aConfig project: aProject | versionMap symbolicVersionMap executionBlock | self setProject: aProject. self configuration: aConfig. versionMap := Dictionary new. symbolicVersionMap := Dictionary new. executionBlock := self specResolverBlock. self collectAllVersionsFromVersionPragmasInto: versionMap using: executionBlock. self collectAllVersionsFromVersionImportPragmasInto: versionMap using: executionBlock satisfiedPragmas: (self versionImportPragmasVerifiedDefinedIn: versionMap). self collectAllSymbolicVersionsFromVersionPragmasInto: symbolicVersionMap using: self symbolicVersionResolverBlock. self project map: versionMap. 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 7/8/2011 18:58'! 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: 'initialization' stamp: 'dkh 7/8/2011 19:47'! 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 symbolicVersionMap: cachedProject symbolicVersionMap. aProject configuration: aConfig. self setProject: aProject! ! !MetacelloVersionConstructor methodsFor: 'validation' stamp: 'DaleHenrichs 11/30/2010 13:25'! 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: 'DaleHenrichs 11/12/2010 09:50'! 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 9/5/2012 06:03'! 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 ] ] ] ] ]. 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: 'private' stamp: 'DaleHenrichs 11/12/2010 09:50'! 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 | defined := true. executionBlock value: versionSpec value: pragma ]. defined ifTrue: [ self validateVersionString: versionString againstSpec: versionSpec. versionMap at: versionSpec versionString put: versionSpec createVersion ]. self reset ]! ! !MetacelloVersionConstructor methodsFor: 'private' stamp: 'DaleHenrichs 11/12/2010 09:50'! 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 methodsFor: 'private' stamp: 'DaleHenrichs 11/12/2010 09:50'! commonDefaultSymbolicVersionResolverBlock ^ self defaultSymbolicVersionResolverBlock: (MetacelloBaseConfiguration new project: self project) ! ! !MetacelloVersionConstructor methodsFor: 'private' stamp: 'DaleHenrichs 11/12/2010 09:50'! defaultSymbolicVersionResolverBlock ^ self defaultSymbolicVersionResolverBlock: self configuration ! ! !MetacelloVersionConstructor methodsFor: 'private' stamp: 'DaleHenrichs 11/12/2010 09:50'! 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: 'DaleHenrichs 11/12/2010 12:28'! 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: 'private' stamp: 'DaleHenrichs 11/12/2010 12:28'! 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: 'DaleHenrichs 11/12/2010 09:49'! versionImportPragmasVerifiedDefinedIn: versionMap | pragmaDict | pragmaDict := self extractVersionImportPragmas. pragmaDict 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 , ' referenced from the method: ' , pragma selector printString , ' in configuration ' , configuration class printString , ' has not been defined.']]]]]. ^ pragmaDict! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MetacelloVersionConstructor class instanceVariableNames: ''! !MetacelloVersionConstructor class methodsFor: 'deprecated' stamp: 'DaleHenrichs 11/18/2010 16:48'! 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: 'DaleHenrichs 11/18/2010 16:48'! 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! ! !MetacelloVersionConstructor class methodsFor: 'deprecated' stamp: 'DaleHenrichs 11/18/2010 16:48'! 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: 'DaleHenrichs 12/20/2010 10:05'! 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: 'instance creation' stamp: 'DaleHenrichs 11/12/2010 09:47'! on: aConfig ^(self new) on: aConfig; yourself! ! !MetacelloVersionConstructor class methodsFor: 'instance creation' stamp: 'DaleHenrichs 11/12/2010 09:47'! on: aConfig project: aProject ^(self new) on: aConfig project: aProject; yourself! ! Error subclass: #MetacelloVersionDoesNotExistError instanceVariableNames: 'project versionString' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Exceptions'! !MetacelloVersionDoesNotExistError methodsFor: 'accessing' stamp: 'DaleHenrichs 9/24/2010 11:57'! project ^ project! ! !MetacelloVersionDoesNotExistError methodsFor: 'accessing' stamp: 'DaleHenrichs 9/24/2010 11:57'! project: anObject project := anObject! ! !MetacelloVersionDoesNotExistError methodsFor: 'accessing' stamp: 'DaleHenrichs 9/24/2010 11:46'! versionString ^ versionString! ! !MetacelloVersionDoesNotExistError methodsFor: 'accessing' stamp: 'DaleHenrichs 9/24/2010 11:46'! versionString: anObject versionString := anObject! ! !MetacelloVersionDoesNotExistError methodsFor: 'printing' stamp: 'DaleHenrichs 9/24/2010 12:01'! description "Return a textual description of the exception." ^'Version ', self versionString printString, ' is not defined in ', self project label! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MetacelloVersionDoesNotExistError class instanceVariableNames: ''! !MetacelloVersionDoesNotExistError class methodsFor: 'instance creation' stamp: 'DaleHenrichs 9/24/2010 11:58'! project: aMetacelloProject versionString: aVersionString ^(self new) project: aMetacelloProject; versionString: aVersionString; yourself! ! MetacelloDirective subclass: #MetacelloVersionLoadDirective instanceVariableNames: 'loadDirectives' classVariableNames: '' poolDictionaries: '' category: 'Metacello-MC-Directives'! !MetacelloVersionLoadDirective methodsFor: 'accessing' stamp: 'DaleHenrichs 3/9/2010 12:13'! loadDirectives loadDirectives == nil ifTrue: [ loadDirectives := OrderedCollection new ]. ^ loadDirectives! ! !MetacelloVersionLoadDirective methodsFor: 'accessing' stamp: 'DaleHenrichs 3/9/2010 12:13'! loadDirectives: anObject loadDirectives := anObject! ! !MetacelloVersionLoadDirective methodsFor: 'accessing' stamp: 'DaleHenrichs 11/10/2010 16:53'! 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: 'actions' stamp: 'DaleHenrichs 3/9/2010 12:14'! add: aDirective self loadDirectives add: aDirective! ! !MetacelloVersionLoadDirective methodsFor: 'actions' stamp: 'DaleHenrichs 3/16/2010 02:08'! finalizeLoad: aGofer "nothing special for linear loads"! ! !MetacelloVersionLoadDirective methodsFor: 'actions' stamp: 'DaleHenrichs 3/21/2010 13:37'! loadAtomicLoadDirective: aLoaderDirective gofer: aGofer aLoaderDirective loadDirectives do: [:directive | directive loadUsing: aLoaderDirective gofer: aGofer ]. aLoaderDirective finalizeLoad: aGofer.! ! !MetacelloVersionLoadDirective methodsFor: 'actions' stamp: 'DaleHenrichs 3/21/2010 13:38'! loadExplicitLoadDirective: aLoaderDirective gofer: aGofer "load has already been performed, no need to load again"! ! !MetacelloVersionLoadDirective methodsFor: 'actions' stamp: 'DaleHenrichs 3/21/2010 13:39'! loadLinearLoadDirective: aLoaderDirective gofer: aGofer aLoaderDirective loadDirectives do: [:directive | directive loadUsing: aLoaderDirective gofer: aGofer ]. aLoaderDirective finalizeLoad: aGofer.! ! !MetacelloVersionLoadDirective methodsFor: 'actions' stamp: 'dkh 4/6/2011 22:36'! loadWithPolicy: aLoadPolicy | gofer | gofer := MetacelloGofer new. gofer disablePackageCache. gofer repository: aLoadPolicy cacheRepository. self loadUsing: self gofer: gofer! ! !MetacelloVersionLoadDirective methodsFor: 'enumerating' stamp: 'DaleHenrichs 4/7/2010 12:16'! directivesDo: aBlock aBlock value: self. self loadDirectives do: [:directive | directive directivesDo: aBlock ].! ! !MetacelloVersionLoadDirective methodsFor: 'enumerating' stamp: 'DaleHenrichs 3/11/2010 13:40'! packageDirectivesDo: aBlock self loadDirectives do: [:directive | directive packageDirectivesDo: aBlock ].! ! !MetacelloVersionLoadDirective methodsFor: 'enumerating' stamp: 'DaleHenrichs 3/11/2010 13:49'! packagesDo: aBlock self loadDirectives do: [:directive | directive packageDo: aBlock ].! ! !MetacelloVersionLoadDirective methodsFor: 'enumerating' stamp: 'DaleHenrichs 4/7/2010 12:26'! prepostLoadDirectivesDo: aBlock self loadDirectives do: [:directive | directive prepostLoadDirectivesDo: aBlock ].! ! !MetacelloVersionLoadDirective methodsFor: 'enumerating' stamp: 'DaleHenrichs 4/7/2010 12:28'! prepostLoadsDo: aBlock self loadDirectives do: [:directive | directive prepostLoadDo: aBlock ].! ! !MetacelloVersionLoadDirective methodsFor: 'enumerating' stamp: 'DaleHenrichs 12/7/2010 02:22'! versionDirectivesDepthFirstDo: aBlock self loadDirectives do: [:directive | directive versionDirectivesDepthFirstDo: aBlock ]. aBlock value: self. ! ! !MetacelloVersionLoadDirective methodsFor: 'enumerating' stamp: 'DaleHenrichs 3/12/2010 10:27'! versionDirectivesDo: aBlock aBlock value: self. self loadDirectives do: [:directive | directive versionDirectivesDo: aBlock ].! ! !MetacelloVersionLoadDirective methodsFor: 'enumerating' stamp: 'DaleHenrichs 4/7/2010 12:32'! versionDo: aBlock aBlock value: self. ! ! !MetacelloVersionLoadDirective methodsFor: 'enumerating' stamp: 'DaleHenrichs 4/7/2010 12:32'! versionsDo: aBlock self loadDirectives do: [:directive | directive versionDo: aBlock ].! ! !MetacelloVersionLoadDirective methodsFor: 'loading' stamp: 'DaleHenrichs 4/9/2010 12:08'! loadPackageDirective: aPackageLoadDirective gofer: aGofer aPackageLoadDirective loader loadingSpecLoader loadPackageDirective: aPackageLoadDirective gofer: aGofer! ! !MetacelloVersionLoadDirective methodsFor: 'loading' stamp: 'DaleHenrichs 12/21/2010 11:47'! 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: 'loading' stamp: 'DaleHenrichs 12/21/2010 11:49'! 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: 'printing' stamp: 'DaleHenrichs 3/10/2010 11:07'! label self spec == nil ifTrue: [ ^'' ]. ^self spec label! ! !MetacelloVersionLoadDirective methodsFor: 'printing' stamp: 'DaleHenrichs 4/9/2010 13:04'! printLoadDirectivesOn: aStream indent: indent self loadDirectives do: [:each | aStream cr. each printOn: aStream indent: indent + 1 ].! ! !MetacelloVersionLoadDirective methodsFor: 'printing' stamp: 'DaleHenrichs 4/9/2010 13:04'! printOn: aStream indent: indent super printOn: aStream indent: indent. self printLoadDirectivesOn: aStream indent: indent! ! !MetacelloVersionLoadDirective methodsFor: 'testing' stamp: 'DaleHenrichs 12/7/2010 02:24'! isExplicit ^false! ! MetacelloMethodSection subclass: #MetacelloVersionMethodSection instanceVariableNames: 'block versionSpec parent methodSections' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Constructors'! !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 6/5/2012 19:01:24'! 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'! 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'! block ^ block! ! !MetacelloVersionMethodSection methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! block: anObject block := anObject! ! !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'! parent ^ parent! ! !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'! topParent self parent == nil ifTrue: [ ^ self ]. ^ self parent topParent! ! !MetacelloVersionMethodSection methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! versionSpec ^ versionSpec! ! !MetacelloVersionMethodSection methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! versionSpec: anObject versionSpec := anObject! ! MetacelloMethodSpec subclass: #MetacelloVersionMethodSpec instanceVariableNames: 'imports' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Constructors'! !MetacelloVersionMethodSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! imports imports == nil ifTrue: [ imports := #() ]. ^ imports! ! !MetacelloVersionMethodSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2012 19:01:24'! imports: anObject imports := anObject! ! !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: 'adding' stamp: 'dkh 6/5/2012 19:01:24'! 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 ]! ! !MetacelloVersionMethodSpec methodsFor: 'adding' stamp: 'dkh 9/6/2012 10:03:17'! 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: 'method generation' stamp: 'dkh 6/5/2012 19:01:24'! 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: '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 ]! ! Magnitude variableSubclass: #MetacelloVersionNumber instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Model'! !MetacelloVersionNumber commentStamp: 'dkh 6/22/2012 12:00' prior: 0! # 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: 'accessing' stamp: 'dkh 6/14/2009 13:29'! approximateBase | base | base := self copyFrom: 1 to: self size - 1. base at: base size put: (base at: base size) + 1. ^base! ! !MetacelloVersionNumber methodsFor: 'accessing' stamp: 'dkh 6/14/2009 09:57'! versionString | strm | strm := WriteStream on: String new. self printOn: strm. ^strm contents! ! !MetacelloVersionNumber methodsFor: 'comparing' stamp: 'DaleHenrichs 10/6/2010 11:14'! < 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: 'comparing' stamp: 'DaleHenrichs 10/6/2010 11:14'! = 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: 'comparing' stamp: 'dkh 06/15/2009 14:30'! 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: 'comparing' stamp: 'dkh 12/21/2009 13:32'! 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: 'comparing' stamp: 'dkh 6/14/2009 13:30'! ~> aMetacelloVersionNumber aMetacelloVersionNumber size == 1 ifTrue: [ ^false ]. ^self >= aMetacelloVersionNumber and: [ self < aMetacelloVersionNumber approximateBase ]! ! !MetacelloVersionNumber methodsFor: 'converting' stamp: 'dkh 6/14/2009 09:29'! asMetacelloVersionNumber ^self! ! !MetacelloVersionNumber methodsFor: 'copying' stamp: 'dkh 6/14/2009 12:53'! 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/14/2009 09:37'! do: aBlock "Refer to the comment in Collection|do:." 1 to: self size do: [:index | aBlock value: (self at: index)]! ! !MetacelloVersionNumber methodsFor: 'enumerating' stamp: 'dkh 6/14/2009 09:37'! 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: 'operations' stamp: 'DaleHenrichs 11/15/2010 13:33'! 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: 'operations' stamp: 'dkh 10/7/2009 14:28'! 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: 'printing' stamp: 'dkh 6/14/2009 09:59'! 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: 'private' stamp: 'DaleHenrichs 10/16/2010 10:15'! 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: 'private' stamp: 'DaleHenrichs 10/5/2010 17:31'! 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: 'private' stamp: 'DaleHenrichs 10/5/2010 17:29'! 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 class instanceVariableNames: ''! !MetacelloVersionNumber class methodsFor: 'instance creation' stamp: 'dkh 8/13/2009 12:20'! 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! ! !MetacelloVersionNumber class methodsFor: 'private' stamp: 'TestRunner 10/19/2009 10:22'! extractNumericComponent: subString "$. separated components are integers" | number | number := [subString asNumber] on: Error do: [:ex | ex return: subString ]. ^number asString = subString ifTrue: [ number ] ifFalse: [ subString ]! ! MetacelloSpec subclass: #MetacelloVersionSpec instanceVariableNames: 'versionString blessing description author timestamp preLoadDoIt postLoadDoIt' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Specs'! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 9/13/2009 07:42'! author author == nil ifTrue: [ ^self project valueHolderSpec value: ''; yourself]. ^ author! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 9/13/2009 07:43'! author: anObject anObject setAuthorInMetacelloVersion: self! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 8/26/2009 10:10'! blessing blessing == nil ifTrue: [ ^self project valueHolderSpec value: self project defaultBlessing; yourself]. ^ blessing! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2009 10:44'! blessing: anObject anObject setBlessingInMetacelloVersion: self! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 8/26/2009 10:35'! description description == nil ifTrue: [ ^self project valueHolderSpec value: ''; yourself]. ^ description! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2009 11:40'! description: anObject anObject setDescriptionInMetacelloVersion: self! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 10/3/2009 16:42'! getAuthor ^author! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 10/3/2009 16:41'! getBlessing ^blessing! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 10/3/2009 16:41'! getDescription ^description! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 12/30/2009 13:25'! getPostLoadDoIt ^postLoadDoIt! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 12/30/2009 13:25'! getPreLoadDoIt ^preLoadDoIt! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 10/3/2009 16:42'! getTimestamp ^timestamp! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'DaleHenrichs 12/21/2010 13:51'! postLoadDoIt: anObject anObject setPostLoadDoItInMetacelloSpec: self! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'DaleHenrichs 12/21/2010 13:50'! preLoadDoIt: anObject anObject setPreLoadDoItInMetacelloSpec: self! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'DaleHenrichs 3/9/2010 16:31'! projectLabel ^self project label! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 9/13/2009 07:44'! setAuthor: anObject author := anObject! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2009 10:44'! setBlessing: anObject blessing := anObject! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/5/2009 11:40'! setDescription: anObject description := anObject! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'DaleHenrichs 12/21/2010 11:37'! setPostLoadDoIt: aSymbol postLoadDoIt := aSymbol! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'DaleHenrichs 12/21/2010 11:37'! setPreLoadDoIt: aSymbol preLoadDoIt := aSymbol! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 9/13/2009 07:44'! setTimestamp: anObject timestamp := anObject! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 9/13/2009 07:42'! timestamp timestamp == nil ifTrue: [ ^self project valueHolderSpec value: ''; yourself]. ^ timestamp! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 9/13/2009 07:44'! timestamp: anObject anObject setTimestampInMetacelloVersion: self! ! !MetacelloVersionSpec methodsFor: 'accessing' stamp: 'dkh 6/4/2009 18:50'! versionString: anObject versionString := anObject! ! !MetacelloVersionSpec methodsFor: 'copying' stamp: 'dkh 10/4/2009 19:10'! postCopy super postCopy. blessing := blessing copy. description := description copy. author := author copy. timestamp := timestamp copy. ! ! !MetacelloVersionSpec methodsFor: 'merging' stamp: 'dkh 12/30/2009 14:17'! 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! ! !MetacelloVersionSpec methodsFor: 'printing' stamp: 'DaleHenrichs 12/23/2010 10:03'! 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: 'printing' stamp: 'DaleHenrichs 12/23/2010 14:27'! configMethodOn: aStream indent: indent self configMethodOn: aStream last: true indent: indent! ! !MetacelloVersionSpec methodsFor: 'printing' stamp: 'DaleHenrichs 12/23/2010 09:51'! configMethodOn: 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: 'printing' stamp: 'DaleHenrichs 12/23/2010 09:38'! 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: 'printing' stamp: 'DaleHenrichs 12/23/2010 09:39'! 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: 'printing' stamp: 'DaleHenrichs 3/9/2010 16:34'! label ^self versionString, ' [', self projectLabel, ']'! ! !MetacelloVersionSpec methodsFor: 'querying' stamp: 'dkh 12/30/2009 13:14'! postLoadDoIt ^postLoadDoIt! ! !MetacelloVersionSpec methodsFor: 'querying' stamp: 'dkh 12/30/2009 13:15'! preLoadDoIt ^preLoadDoIt! ! !MetacelloVersionSpec methodsFor: 'querying' stamp: 'dkh 8/31/2009 05:10'! versionString versionString == nil ifTrue: [ ^'' ]. ^ versionString! ! !MetacelloVersionSpec methodsFor: 'testing' stamp: 'dkh 12/14/2009 10:20'! isPartiallyCurrent: notLoadedMatters useEquality: useEquality self subclassResponsibility! ! !MetacelloVersionSpec methodsFor: 'testing' stamp: 'dkh 12/14/2009 10:20'! isPossibleBaseline self subclassResponsibility! ! !MetacelloVersionSpec methodsFor: 'toolbox support' stamp: 'dkh 9/12/2012 14:26'! deleteSpec: aSpec "remove the spec from packages" self packages deleteSpec: aSpec! ! !MetacelloVersionSpec methodsFor: 'private' stamp: 'dkh 10/7/2009 14:45'! createVersion ^self versionClass fromSpec: self! ! !MetacelloVersionSpec methodsFor: 'private' stamp: 'dkh 10/7/2009 14:44'! versionClass ^MetacelloVersion! ! MetacelloAbstractConstructor subclass: #MetacelloVersionValidator instanceVariableNames: 'configurationClass exludededValidations validationReport recurse debug visited' classVariableNames: '' poolDictionaries: '' category: 'Metacello-Core-Validation'! !MetacelloVersionValidator methodsFor: 'accessing' stamp: 'DaleHenrichs 11/3/2010 11:42'! configurationClass ^ configurationClass! ! !MetacelloVersionValidator methodsFor: 'accessing' stamp: 'DaleHenrichs 11/3/2010 11:41'! configurationClass: anObject configurationClass := anObject! ! !MetacelloVersionValidator methodsFor: 'accessing' stamp: 'DaleHenrichs 11/24/2010 08:59'! debug debug == nil ifTrue: [ debug := #() ]. ^ debug! ! !MetacelloVersionValidator methodsFor: 'accessing' stamp: 'DaleHenrichs 11/24/2010 09:00'! debug: aCollection "Any combination of: #error, #criticalWarning, #warning" debug := aCollection! ! !MetacelloVersionValidator methodsFor: 'accessing' stamp: 'DaleHenrichs 11/30/2010 13:17'! exludededValidations exludededValidations == nil ifTrue: [ exludededValidations := self extractExcludedValidations ]. ^exludededValidations! ! !MetacelloVersionValidator methodsFor: 'accessing' stamp: 'DaleHenrichs 11/30/2010 13:30'! recordValidationCriticalWarning: aString callSite: callSite reasonCode: aSymbol ^self recordValidationCriticalWarning: aString versionString: nil callSite: callSite reasonCode: aSymbol ! ! !MetacelloVersionValidator methodsFor: 'accessing' stamp: 'DaleHenrichs 11/30/2010 13:28'! 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: 'accessing' stamp: 'DaleHenrichs 12/3/2010 10:50'! recordValidationError: aString callSite: callSite reasonCode: aSymbol ^self recordValidationError: aString versionString: nil callSite: callSite reasonCode: aSymbol ! ! !MetacelloVersionValidator methodsFor: 'accessing' stamp: 'DaleHenrichs 11/30/2010 13:28'! 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: 'DaleHenrichs 11/30/2010 13:30'! recordValidationWarning: aString callSite: callSite reasonCode: aSymbol ^self recordValidationWarning: aString versionString: nil callSite: callSite reasonCode: aSymbol ! ! !MetacelloVersionValidator methodsFor: 'accessing' stamp: 'DaleHenrichs 11/30/2010 13:29'! 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: 'DaleHenrichs 11/5/2010 09:56'! recurse recurse == nil ifTrue: [ recurse := false ]. ^ recurse! ! !MetacelloVersionValidator methodsFor: 'accessing' stamp: 'DaleHenrichs 11/5/2010 09:39'! recurse: anObject recurse := anObject! ! !MetacelloVersionValidator methodsFor: 'accessing' stamp: 'DaleHenrichs 11/3/2010 14:02'! validationReport validationReport == nil ifTrue: [ validationReport := OrderedCollection new ]. ^ validationReport! ! !MetacelloVersionValidator methodsFor: 'accessing' stamp: 'DaleHenrichs 11/3/2010 14:01'! validationReport: anObject validationReport := anObject! ! !MetacelloVersionValidator methodsFor: 'accessing' stamp: 'DaleHenrichs 11/08/2010 14:45'! visited visited == nil ifTrue: [ visited := IdentitySet new ]. ^visited! ! !MetacelloVersionValidator methodsFor: 'accessing' stamp: 'DaleHenrichs 11/08/2010 14:49'! visited: anIdentitySet visited := anIdentitySet! ! !MetacelloVersionValidator methodsFor: 'pragma extraction' stamp: 'DaleHenrichs 11/30/2010 14:33'! 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: 'validation' stamp: 'DaleHenrichs 11/4/2010 10:36'! 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: 'validation' stamp: 'DaleHenrichs 11/30/2010 13:49'! 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: 'validation' stamp: 'DaleHenrichs 12/21/2010 10:39'! 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: 'DaleHenrichs 12/17/2010 13:04'! criticalWarningReasonCodes ^ #(#packageNameMismatch #projectClassNameFileMismatch #duplicateVersionDefinitions)! ! !MetacelloVersionValidator methodsFor: 'private' stamp: 'DaleHenrichs 11/30/2010 11:51'! errorReasonCodes ^ #(#duplicateNames #shadowedNames #invalidDoItSelector #invalidVersionString #missingVersionImport #projectCreationError #noVersionsDefined #cannotResolveVersion #incompleteProjectSpec #incorrectVersionString #versionCompositionError)! ! !MetacelloVersionValidator methodsFor: 'private' stamp: 'DaleHenrichs 11/3/2010 16:46'! validateBaselineVersionSpec: versionSpec self subclassResponsibility! ! !MetacelloVersionValidator methodsFor: 'private' stamp: 'DaleHenrichs 12/21/2010 11:48'! 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: 'private' stamp: 'DaleHenrichs 11/30/2010 13:37'! 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: 'private' stamp: 'DaleHenrichs 11/30/2010 13:46'! 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: 'private' stamp: 'DaleHenrichs 12/4/2010 09:55'! validateProjectCreationFrom: aConfigurationClass onError: aBlock [ ^ aConfigurationClass project ] on: Error , MetacelloValidationNotification do: [ :ex | (ex isKindOf: MetacelloValidationNotification) ifTrue: [ self validationReport add: ex issue. ex resume ]. ^ aBlock value: ex ]! ! !MetacelloVersionValidator methodsFor: 'private' stamp: 'DaleHenrichs 12/4/2010 10:53'! 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: 'private' stamp: 'DaleHenrichs 11/12/2010 10:44'! validateVersionSpec: versionSpec self subclassResponsibility! ! !MetacelloVersionValidator methodsFor: 'private' stamp: 'DaleHenrichs 11/12/2010 10:44'! validateVersionSpecForSymbolicVersion: versionSpec symbolicVersion: symbolicVersionString self subclassResponsibility! ! !MetacelloVersionValidator methodsFor: 'private' stamp: 'DaleHenrichs 11/30/2010 11:45'! warningReasonCodes ^ #(#onlyBaselineVersion )! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MetacelloVersionValidator class instanceVariableNames: 'reasonCodeDescriptions'! !MetacelloVersionValidator class methodsFor: 'accessing' stamp: 'DaleHenrichs 12/17/2010 15:16'! descriptionForReasonCode: reasonCode ^ self reasonCodeDescriptions at: reasonCode ifAbsent: [ self error: 'Unknown reasonCode: ' , reasonCode printString ]! ! !MetacelloVersionValidator class methodsFor: 'accessing' stamp: 'DaleHenrichs 12/17/2010 14:50'! reasonCodeDescriptions reasonCodeDescriptions ifNil: [ reasonCodeDescriptions := self populateReasonCodeDescriptions ]. ^reasonCodeDescriptions! ! !MetacelloVersionValidator class methodsFor: 'instance creation' stamp: 'DaleHenrichs 12/4/2010 08:39'! validateConfiguration: configurationClass ^self validateConfiguration: configurationClass debug: #() recurse: false! ! !MetacelloVersionValidator class methodsFor: 'instance creation' stamp: 'DaleHenrichs 11/24/2010 09:02'! validateConfiguration: configurationClass debug: debugList recurse: aBool ^ ((self new) configurationClass: configurationClass; debug: debugList; recurse: aBool; yourself) validate! ! !MetacelloVersionValidator class methodsFor: 'instance creation' stamp: 'DaleHenrichs 12/4/2010 08:39'! validateConfiguration: configurationClass recurse: aBool ^self validateConfiguration: configurationClass debug: #() recurse: aBool! ! !MetacelloVersionValidator class methodsFor: 'instance creation' stamp: 'DaleHenrichs 12/4/2010 08:40'! validateProject: aMetacelloProject ^self validateProject: aMetacelloProject debug: #() recurse: false! ! !MetacelloVersionValidator class methodsFor: 'instance creation' stamp: 'DaleHenrichs 11/24/2010 09:01'! validateProject: aMetacelloProject debug: debugList recurse: aBool ^ ((self new) recurse: aBool; debug: debugList; configurationClass: aMetacelloProject configuration class; yourself) validateProject: aMetacelloProject! ! !MetacelloVersionValidator class methodsFor: 'instance creation' stamp: 'DaleHenrichs 12/4/2010 08:40'! validateProject: aMetacelloProject recurse: aBool ^self validateProject: aMetacelloProject debug: #() recurse: aBool! ! !MetacelloVersionValidator class methodsFor: 'instance creation' stamp: 'DaleHenrichs 12/4/2010 08:43'! validateProject: aMetacelloProject version: versionString ^self validateProject: aMetacelloProject version: versionString debug: #() recurse: false ! ! !MetacelloVersionValidator class methodsFor: 'instance creation' stamp: 'DaleHenrichs 12/4/2010 08:43'! validateProject: aMetacelloProject version: versionString debug: debugList ^self validateProject: aMetacelloProject version: versionString debug: debugList recurse: false ! ! !MetacelloVersionValidator class methodsFor: 'instance creation' stamp: 'DaleHenrichs 12/4/2010 08:42'! 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: 'DaleHenrichs 12/4/2010 08:41'! 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: 'private' stamp: 'DaleHenrichs 1/24/2011 12:41'! populateReasonCodeDescriptions | dict | dict := Dictionary new. "Warnings" dict at: #onlyBaselineVersion put: 'one or more baseline versions have been defined, but no non-baseline versions are defined.'. "Critical Warnings" dict at: #duplicateVersionDefinitions put: 'there are multiple pragma methods specifying the same version.'. dict at: #packageNameMismatch put: 'the name in the packageSpec does not match the name of the mcz file.'. dict at: #projectClassNameFileMismatch put: 'the class name of the configuration does not match the mcz file containing the configuration.'. "Errors" dict 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).'. dict at: #incompleteProjectSpec put: 'missing required fields in project reference (className and/or repository).'. dict at: #incorrectVersionString put: 'the version declared in pragma doesn''t match version in versionSpec.'. dict at: #invalidDoItSelector put: 'doit select must be a Symbol.'. dict at: #invalidVersionString put: 'versionString must be a String.'. dict at: #missingVersionImport put: 'version specified in import pragma not defined in configuration.'. dict at: #noVersionsDefined put: 'no usable baseline or version defined in configuration ... configuration cannot be loaded.'. dict at: #projectCreationError put: 'error occured while resolving project reference.'. dict at: #shadowedNames put: 'name duplication between packages and projects.'. dict at: #versionCompositionError put: 'error while creating versionSpec from pragmas.'. ^dict! ! Object subclass: #MetacelloVisitedPackages instanceVariableNames: 'groups packages projects' classVariableNames: '' poolDictionaries: '' category: 'Metacello-MC-Specs'! !MetacelloVisitedPackages methodsFor: 'initialize-release' stamp: 'dkh 10/21/2009 15:17'! initialize groups := Set new. packages := Set new. projects := Set new.! ! !MetacelloVisitedPackages methodsFor: 'visiting' stamp: 'dkh 10/22/2009 08:31'! 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 ]! ! !MetacelloVisitedPackages methodsFor: 'visiting' stamp: 'dkh 10/21/2009 15:26'! 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! ! ClassDescription subclass: #Metaclass uses: TApplyingOnClassSide instanceVariableNames: 'thisClass traitComposition localSelectors' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Classes'! !Metaclass commentStamp: '' prior: 0! 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: '*Fuel' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^aGeneralMapper visitMetaclass: self ! ! !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: '*Ring-Core-Kernel' stamp: 'VeronicaUquillas 9/19/2011 16:46'! asFullRingDefinition ^ self theNonMetaClass asFullRingDefinition theMetaClass! ! !Metaclass methodsFor: '*Ring-Core-Kernel' stamp: 'VeronicaUquillas 9/19/2011 16:46'! asRingDefinition ^ self theNonMetaClass asRingDefinition theMetaClass! ! !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: 'accessing' stamp: 'al 3/25/2006 13:16'! basicLocalSelectors: aSetOrNil localSelectors := aSetOrNil! ! !Metaclass methodsFor: 'accessing' stamp: 'ar 7/11/1999 05:19'! environment ^thisClass environment! ! !Metaclass methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/23/2011 18:54'! hasTraitComposition ^ traitComposition notNil and: [ traitComposition notEmpty ]! ! !Metaclass methodsFor: 'accessing'! 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: 'accessing'! soleInstance "The receiver has only one instance. Answer it." ^thisClass! ! !Metaclass methodsFor: 'accessing' stamp: 'al 3/25/2006 12:35'! traitComposition traitComposition ifNil: [traitComposition := TraitComposition new]. ^traitComposition! ! !Metaclass methodsFor: 'accessing' stamp: 'al 3/25/2006 12:38'! traitComposition: aTraitComposition traitComposition := aTraitComposition! ! !Metaclass methodsFor: 'accessing instances and variables' stamp: 'adrian.lienhard 1/5/2009 23:04'! classVarNames "Answer a set of the names of the class variables defined in the receiver's instance." thisClass ifNil: [ ^ Set new ]. ^thisClass classVarNames! ! !Metaclass methodsFor: 'accessing parallel hierarchy' stamp: 'sd 6/27/2003 22:51'! theMetaClass "Sent to a class or metaclass, always return the metaclass" ^self! ! !Metaclass methodsFor: 'accessing parallel hierarchy'! theNonMetaClass "Sent to a class or metaclass, always return the class" ^thisClass! ! !Metaclass methodsFor: 'class hierarchy' stamp: 'ar 9/19/2002 23:44'! addObsoleteSubclass: aClass "Do nothing."! ! !Metaclass methodsFor: 'class hierarchy' stamp: 'ar 7/11/1999 15:43'! addSubclass: aClass "Do nothing."! ! !Metaclass methodsFor: 'class hierarchy' stamp: 'ar 9/19/2002 23:44'! obsoleteSubclasses "Answer the receiver's subclasses." thisClass == nil ifTrue:[^#()]. ^thisClass obsoleteSubclasses select:[:aSubclass| aSubclass isMeta not] thenCollect:[:aSubclass| aSubclass class] "Metaclass allInstancesDo: [:m | Compiler evaluate: 'subclasses:=nil' for: m logged: false]"! ! !Metaclass methodsFor: 'class hierarchy' stamp: 'ar 9/19/2002 23:44'! removeObsoleteSubclass: aClass "Do nothing."! ! !Metaclass methodsFor: 'class hierarchy' stamp: 'ar 7/11/1999 15:43'! removeSubclass: aClass "Do nothing."! ! !Metaclass methodsFor: 'class hierarchy' stamp: 'ar 7/14/1999 11:19'! subclasses "Answer the receiver's subclasses." thisClass == nil ifTrue:[^#()]. ^thisClass subclasses select:[:aSubclass| aSubclass isMeta not] thenCollect:[:aSubclass| aSubclass class] "Metaclass allInstancesDo: [:m | Compiler evaluate: 'subclasses:=nil' for: m logged: false]"! ! !Metaclass methodsFor: 'class hierarchy' stamp: 'ar 7/9/1999 14:11'! subclassesDo: aBlock "Evaluate aBlock for each of the receiver's immediate subclasses." thisClass 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: 'compiling' stamp: 'CamilloBruni 8/1/2012 15:57'! 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." ^ thisClass acceptsLoggingOfCompilation! ! !Metaclass methodsFor: 'compiling' stamp: 'MarcusDenker 9/19/2012 16:56'! 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 methodClassAssociation]! ! !Metaclass methodsFor: 'compiling' stamp: 'ar 5/18/2003 18:13'! bindingOf: varName ^thisClass classBindingOf: varName! ! !Metaclass methodsFor: 'compiling'! possibleVariablesFor: misspelled continuedFrom: oldResults ^ thisClass possibleVariablesFor: misspelled continuedFrom: oldResults ! ! !Metaclass methodsFor: 'compiling' stamp: 'CamilloBruni 8/1/2012 16:18'! wantsChangeSetLogging "Answer whether code submitted for the receiver should be remembered by the changeSet mechanism.The metaclass follows the rule of the class itself." ^ thisClass wantsChangeSetLogging! ! !Metaclass methodsFor: 'compiling' stamp: 'sw 7/31/2000 14:29'! wantsRecompilationProgressReported "The metaclass follows the rule of the class itself." ^ thisClass wantsRecompilationProgressReported! ! !Metaclass methodsFor: 'composition'! 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: 'composition'! 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: 'copying' stamp: 'nice 12/29/2010 10:21'! postCopy "Don't share the reference to the sole instance." super postCopy. thisClass := nil.! ! !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: '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: 'fileIn/Out' stamp: 'di 2/17/2000 22:33'! fileOutInitializerOn: aStream (self methodDict includesKey: #initialize) ifTrue: [aStream cr. aStream nextChunkPut: thisClass name , ' initialize'].! ! !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: 'fileIn/Out' stamp: 'al 7/19/2004 18:28'! fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex initializing: aBool super fileOutOn: aFileStream moveSource: moveSource toFile: fileIndex. (aBool and:[moveSource not and: [self methodDict includesKey: #initialize]]) ifTrue: [aFileStream cr. aFileStream cr. aFileStream nextChunkPut: thisClass name , ' initialize'. aFileStream cr]! ! !Metaclass methodsFor: 'fileIn/Out' stamp: 'jannik.laval 2/5/2010 21:40'! nonTrivial "Answer whether the receiver has any methods or instance variables." ^ self instVarNames notEmpty or: [self hasMethods or: [self hasTraitComposition]]! ! !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: 'initialize-release' stamp: 'ar 7/15/1999 18:56'! instanceVariableNames: instVarString "Declare additional named variables for my instance." ^(ClassBuilder new) class: self instanceVariableNames: instVarString! ! !Metaclass methodsFor: 'initialize-release' stamp: 'EstebanLorenzano 7/27/2012 16:30'! 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: '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: 'instance variables' stamp: 'StephaneDucasse 8/27/2010 11:19'! 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: 'instance variables' stamp: 'StephaneDucasse 8/27/2010 11:19'! 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: 'pool variables'! classPool "Answer the dictionary of class variables." ^thisClass classPool! ! !Metaclass methodsFor: 'testing' stamp: 'ar 9/10/1999 17:41'! canZapMethodDictionary "Return true if it is safe to zap the method dictionary on #obsolete" thisClass == nil ifTrue:[^true] ifFalse:[^thisClass canZapMethodDictionary]! ! !Metaclass methodsFor: 'testing' stamp: 'StephaneDucasse 12/16/2012 18:18'! isAbstractClass self deprecated: 'Use defineAbstractMethods' on: '16 December 2012' in: #Pharo2.0. ^ self theNonMetaClass isAbstractClass! ! !Metaclass methodsFor: 'testing' stamp: 'MarcusDenker 2/21/2013 17:02'! isAnonymous ^thisClass isAnonymous ! ! !Metaclass methodsFor: 'testing' stamp: 'dvf 9/27/2005 14:59'! isMeta ^ true! ! !Metaclass methodsFor: 'testing' stamp: 'ar 7/11/1999 07:27'! isObsolete "Return true if the receiver is obsolete" ^thisClass == nil "Either no thisClass" or:[thisClass class ~~ self "or I am not the class of thisClass" or:[thisClass isObsolete]] "or my instance is obsolete"! ! !Metaclass methodsFor: 'testing' stamp: 'nice 11/5/2009 21:57'! isSelfEvaluating ^self isObsolete not! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Metaclass class uses: TApplyingOnClassSide classTrait instanceVariableNames: ''! SystemAnnouncement subclass: #MethodAdded instanceVariableNames: 'method methodClass protocol selector' classVariableNames: '' poolDictionaries: '' category: 'System-Announcements'! !MethodAdded commentStamp: 'cyrilledelaunay 1/18/2011 13:06' prior: 0! 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:12'! method ^ method! ! !MethodAdded methodsFor: 'accessing' stamp: 'GuillermoPolito 8/1/2012 18:10'! method: aCompiledMethod method := aCompiledMethod! ! !MethodAdded methodsFor: 'accessing' stamp: 'GuillermoPolito 8/3/2012 14:11'! methodAffected ^ self 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 18:12'! protocol ^ protocol! ! !MethodAdded methodsFor: 'accessing' stamp: 'GuillermoPolito 8/1/2012 23:38'! protocol: aProtocolName protocol := aProtocolName! ! !MethodAdded methodsFor: 'accessing' stamp: 'GuillermoPolito 8/1/2012 18:12'! selector ^ selector! ! !MethodAdded methodsFor: 'accessing' stamp: 'GuillermoPolito 8/1/2012 23:38'! selector: aSelector selector := aSelector! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MethodAdded class instanceVariableNames: ''! !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! ! !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! ! Object subclass: #MethodAddition instanceVariableNames: 'text category changeStamp requestor logSource myClass methodAndNode selector compiledMethod priorMethodOrNil priorCategoryOrNil' classVariableNames: '' poolDictionaries: '' category: 'Monticello-Loading'! !MethodAddition commentStamp: 'rej 2/25/2007 19:30' prior: 0! 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: 'accessing' stamp: 'PavelKrivanek 12/6/2012 22:54'! priorCategoryOrNil ^ priorCategoryOrNil! ! !MethodAddition methodsFor: 'accessing' stamp: 'PavelKrivanek 12/6/2012 22:54'! priorCategoryOrNil: anObject priorCategoryOrNil := anObject! ! !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! ! !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: 'notifying' stamp: 'PavelKrivanek 12/6/2012 23:00'! notifyObservers SystemAnnouncer uniqueInstance suspendAllWhile: [myClass organization classify: selector under: category]. priorMethodOrNil isNil ifTrue: [SystemAnnouncer uniqueInstance methodAdded: compiledMethod selector: selector inProtocol: category class: myClass requestor: requestor] ifFalse: [ 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: 'operations' stamp: 'PavelKrivanek 12/6/2012 22:58'! createCompiledMethod methodAndNode := myClass compile: text asString classified: category notifying: requestor trailer: myClass defaultMethodTrailer ifFail: [^nil]. selector := methodAndNode selector. compiledMethod := methodAndNode method. self writeSourceToLog. priorMethodOrNil := myClass compiledMethodAt: selector ifAbsent: [nil]. priorCategoryOrNil := myClass organization categoryOfElement: selector.! ! !MethodAddition methodsFor: 'operations' stamp: 'rej 2/25/2007 22:09'! installMethod myClass addSelectorSilently: selector withMethod: compiledMethod. ! ! !MethodAddition methodsFor: 'operations' stamp: 'rej 2/25/2007 20:42'! writeSourceToLog logSource ifTrue: [ myClass logMethodSource: text forMethodWithNode: methodAndNode inCategory: category withStamp: changeStamp notifying: requestor. ]. ! ! ComposableModel subclass: #MethodBrowser instanceVariableNames: 'listModel textModel toolbarModel' classVariableNames: '' poolDictionaries: '' category: 'Spec-Examples-PolyWidgets'! !MethodBrowser commentStamp: '' prior: 0! A MethodBrowser is a simple browser using Spec to display a list of methods and their source code 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: 'accessing' stamp: 'BenjaminVanRyseghem 2/4/2012 14:42'! action ^ textModel actionToPerformHolder content! ! !MethodBrowser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/14/2011 14:51'! listModel ^ listModel! ! !MethodBrowser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/14/2011 14:51'! textModel ^ textModel! ! !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 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: 'initialization' stamp: 'BenjaminVanRyseghem 6/12/2012 19:33'! initializeWidgets self instantiateModels: #( listModel ListComposableModel textModel TextModel toolbarModel MethodToolbar ). self focusOrder add: listModel; add: toolbarModel; add: textModel. textModel aboutToStyle: true.! ! !MethodBrowser methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/12/2012 19:32'! displayBlock: aBlock listModel displayBlock: aBlock! ! !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/6/2012 20:46'! wrapWith: aBlock listModel displayBlock: aBlock! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MethodBrowser class instanceVariableNames: ''! !MethodBrowser class methodsFor: 'example' stamp: 'BenjaminVanRyseghem 1/16/2012 23:18'! example | mb | mb := MethodBrowser new. mb openWithSpec. mb methods: Object methodDict values! ! !MethodBrowser class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/15/2013 13:48'! defaultSpec ^{ #ComposableSpec. #add:. {{#model. #listModel}. #layout:. #(FrameLayout bottomFraction: 0.5 bottomOffset: -15) }. #add:. {{#model. #toolbarModel}. #layout:. #(FrameLayout topFraction: 0.5 bottomFraction: 0.5 topOffset: -15 bottomOffset: 15) }. #add:. {{#model. #textModel}. #layout:. #(FrameLayout topFraction: 0.5 topOffset: 15). }}! ! !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.}! ! !MethodBrowser class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/31/2012 13:36'! title ^ 'Method Browser'! ! Object subclass: #MethodChangeRecord instanceVariableNames: 'changeType infoFromRemoval' classVariableNames: '' poolDictionaries: '' category: 'System-Changes'! !MethodChangeRecord commentStamp: '' prior: 0! 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: 'as yet unclassified' stamp: 'di 4/1/2000 12:02'! changeType ^ changeType! ! !MethodChangeRecord methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'di 4/4/2000 11:05'! noteChangeType: newChangeType (changeType == #addedThenRemoved and: [newChangeType == #change]) ifTrue: [changeType := #add] ifFalse: [changeType := newChangeType]! ! !MethodChangeRecord methodsFor: 'as yet unclassified' 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: 'printing' stamp: 'di 4/1/2000 12:02'! printOn: strm super printOn: strm. strm nextPutAll: ' ('; print: changeType; nextPutAll: ')'! ! Object subclass: #MethodClassifier instanceVariableNames: 'prefixMapping' classVariableNames: '' poolDictionaries: '' category: 'System-Support'! !MethodClassifier commentStamp: '' prior: 0! I am a method classifier that sets the protocl of methods using some simple rules. Example Usage: MethodClassifier classify: MyClass >> #mySelector! !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 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: 'CamilloBruni 1/30/2013 22:13'! classifyByKnownPrefix: aMethod prefixMapping keysAndValuesDo: [ :prefix :protocol | (aMethod selector beginsWith: prefix) ifTrue: [ aMethod protocol: protocol. ^ true ]]. ^ false.! ! !MethodClassifier methodsFor: 'classification-rules' stamp: 'CamilloBruni 2/12/2013 21:54'! 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 = ClassOrganizer default ]) ifFalse: [ protocolBag add: method protocol ]] without: aMethod ]. protocolBag ifEmpty: [ ^ false ]. aMethod protocol: protocolBag sortedCounts first value. ^ true! ! !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: 'initialize-release' stamp: 'CamilloBruni 1/30/2013 22:17'! buildPrefixDictionary prefixMapping := Dictionary new. prefixMapping at: 'test' put: 'tests'; at: 'bench' put: 'benchmarking'; at: 'copy' put: 'copying'; at: 'initialize' put: 'initialize-release'; 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: 'initialize-release' stamp: 'CamilloBruni 1/30/2013 21:02'! initialize self buildPrefixDictionary.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MethodClassifier class instanceVariableNames: ''! !MethodClassifier class methodsFor: 'classification' stamp: 'CamilloBruni 1/30/2013 21:45'! classify: aMethod ^ self new classify: aMethod! ! !MethodClassifier class methodsFor: 'classification' stamp: 'CamilloBruni 1/30/2013 21:54'! classifyAll: aCollectionOfMethods | classifier | classifier := MethodClassifier new. aCollectionOfMethods do: [ :method | classifier classify: method ]! ! AbstractMethodIconAction subclass: #MethodContainsBreakpointAction instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Nautilus-Widgets'! !MethodContainsBreakpointAction commentStamp: '' prior: 0! A MethodContainsBreakpointAction is the action corresponding to the fact that the method contains a breakpoint! !MethodContainsBreakpointAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 2/20/2013 19:56'! actionOrder "Return the priority of this action" ^ 400! ! !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: 'BenjaminVanRyseghem 1/24/2013 11:02'! isActionHandled "Return true if the provided method fits this action requirement" ^ method hasBreakpoint! ! !MethodContainsBreakpointAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 1/24/2013 11:04'! privateActionIcon "Return the icon for this action" ^ self iconClass iconNamed: #breakpoint! ! AbstractMethodIconAction subclass: #MethodContainsFlagsAction instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Nautilus-Widgets'! !MethodContainsFlagsAction commentStamp: '' prior: 0! Action when the method contains a flag! !MethodContainsFlagsAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 1/24/2013 11:03'! actionOrder "Return the priority of this action" ^ 300! ! !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: '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/2/2013 12:49'! privateActionIcon "Return the icon for this action" ^ self iconClass iconNamed: #flag! ! AbstractMethodIconAction subclass: #MethodContainsHaltAction instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Nautilus-Widgets'! !MethodContainsHaltAction commentStamp: '' prior: 0! Action when the method contains a halt! !MethodContainsHaltAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 2/20/2013 19:57'! actionOrder "Return the priority of this action" ^ 100! ! !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: 'BenjaminVanRyseghem 1/2/2013 12:41'! isActionHandled ^ method containsHalt! ! !MethodContainsHaltAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 1/24/2013 11:37'! privateActionIcon "Return the icon for this action" ^ self iconClass iconNamed: #haltIcon! ! ContextPart variableSubclass: #MethodContext instanceVariableNames: 'method closureOrNil receiver' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Methods'! !MethodContext commentStamp: '' prior: 0! 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. In addition to their inherited state, this includes the receiver (self), the closure for a BlockClosure activation (which is nil for a method activation), a CompiledMethod, and space in the variable part of the context for arguments and temporary variables. 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: '*Fuel' stamp: 'MartinDias 3/26/2012 19:17'! cleanCopy ^ self class sender: nil receiver: receiver method: method arguments: #()! ! !MethodContext methodsFor: '*Fuel' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^aGeneralMapper visitMethodContext: self! ! !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: '*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: '*Tools-Inspector' stamp: 'StephaneDucasse 8/21/2010 20:49'! 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." ^ ContextInspector! ! !MethodContext methodsFor: 'accessing' stamp: 'eem 6/15/2008 11:28'! 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 isExecutingBlock ifFalse: [^self]. self sender ifNil: [^nil]. methodReturnContext := self methodReturnContext. ^self sender findContextSuchThat: [:ctxt | ctxt = methodReturnContext]! ! !MethodContext methodsFor: 'accessing' stamp: 'eem 5/28/2008 10:45'! 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 isExecutingBlock ifFalse: [^self]. self sender ifNil: [^nil]. outerContext := self outerContext. ^self sender findContextSuchThat: [:ctxt | ctxt = outerContext]! ! !MethodContext methodsFor: 'accessing' stamp: 'eem 7/22/2008 11:57'! closure ^closureOrNil! ! !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: 'accessing' stamp: 'md 4/27/2006 15:12'! hasInstVarRef "Answer whether the receiver references an instance variable." ^self method hasInstVarRef.! ! !MethodContext methodsFor: 'accessing' stamp: 'eem 4/25/2009 09:50'! hasMethodReturn ^closureOrNil hasMethodReturn! ! !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: 'accessing' stamp: 'eem 7/22/2008 11:57'! isExecutingBlock "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: 'accessing'! method ^method! ! !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: '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: 'eem 7/22/2008 11:58'! outerContext "Answer the context within which the receiver is nested." ^closureOrNil == nil ifFalse: [closureOrNil outerContext]! ! !MethodContext methodsFor: 'accessing'! receiver "Refer to the comment in ContextPart|receiver." ^receiver! ! !MethodContext methodsFor: 'accessing'! removeSelf "Nil the receiver pointer and answer its former value." | tempSelf | tempSelf := receiver. receiver := nil. ^tempSelf! ! !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: '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: '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: 'accessing' stamp: 'MarianoMartinezPeck 5/2/2012 22:15'! tempNamed: aName put: anObject ^self namedTempAt: (self tempNames indexOf: aName) put: anObject! ! !MethodContext methodsFor: 'closure support' stamp: 'md 1/20/2006 17:17'! asContext ^ self! ! !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: 'closure support' stamp: 'md 1/20/2006 17:16'! isClosureContext ^ self isExecutingBlock! ! !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: '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: 'instruction decoding (closures)' 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: 'instruction decoding (closures)' stamp: 'eem 5/30/2008 18:40'! 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: '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: 'printing' stamp: 'MarcusDenker 11/14/2012 18:14'! printDetails: strm "Put my class>>selector and instance variables and arguments and temporaries on the stream. Protect against errors during printing." | pe str pos | self printOn: strm. strm cr. strm tab; nextPutAll: 'Receiver: '. pe := '<>'. strm nextPutAll: ([receiver printStringLimitedTo: 90] ifError: [pe]). strm cr; tab; nextPutAll: 'Arguments and temporary variables: '; cr. str := [(self tempsAndValuesLimitedTo: 80 indent: 2) padRightTo:1 with: $x] ifError: [pe]. strm nextPutAll: (str allButLast). strm cr; tab; nextPutAll: 'Receiver''s instance variables: '; cr. pos := strm position. [receiver longPrintOn: strm limitedTo: 80 indent: 2] ifError: [ strm nextPutAll: pe]. pos = strm position ifTrue: ["normal printString for an Array (it has no inst vars)" strm nextPutAll: ([receiver printStringLimitedTo: 90] ifError: [pe])]. strm peekLast == Character cr ifFalse: [strm cr].! ! !MethodContext methodsFor: 'printing' stamp: 'md 7/2/2010 16:25'! printOn: aStream self outerContext ifNil: [super printOn: aStream] ifNotNil: [:outerContext| aStream nextPutAll: closureOrNil printString,' in '. outerContext printOn: aStream]! ! !MethodContext methodsFor: 'system simulation' stamp: 'sd 8/3/2010 19:22'! pushArgs: args "" from: sendr "" "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: (args at: i)]. sender := sendr! ! !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: 'eem 4/26/2012 10:17'! endPC ^closureOrNil ifNil: [self method endPC] ifNotNil: [closureOrNil endPC]! ! !MethodContext methodsFor: 'private' stamp: 'di 1/14/1999 22:30'! instVarAt: index put: value index = 3 ifTrue: [self stackp: value. ^ value]. ^ super instVarAt: index put: value! ! !MethodContext methodsFor: 'private' stamp: 'eem 7/22/2008 11:59'! setSender: s receiver: r method: m arguments: args "Create the receiver's initial state." sender := s. receiver := r. method := m. closureOrNil := nil. pc := method initialPC. self stackp: method numTemps. 1 to: args size do: [:i | self at: i put: (args at: i)]! ! !MethodContext methodsFor: 'private' stamp: 'eem 7/22/2008 12:00'! setSender: s receiver: r method: m closure: c startpc: startpc "Create the receiver's initial state." sender := s. receiver := r. method := m. closureOrNil := c. pc := startpc. stackp := 0! ! !MethodContext methodsFor: 'private' stamp: 'eem 7/22/2008 12:00'! startpc ^closureOrNil ifNil: [self method initialPC] ifNotNil: [closureOrNil startpc]! ! !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: 'private-exceptions' stamp: 'tpr 2/24/2001 22:05'! isHandlerContext "is this context for method that is marked?" ^method primitive = 199! ! !MethodContext methodsFor: 'private-exceptions' stamp: 'tpr 2/24/2001 22:05'! isUnwindContext "is this context for method that is marked?" ^method primitive = 198! ! !MethodContext methodsFor: 'private-exceptions' stamp: 'tfei 3/23/1999 13:00'! receiver: r receiver := r! ! !MethodContext methodsFor: 'private-exceptions' stamp: 'ar 6/28/2003 00:10'! restartWithNewReceiver: obj self swapReceiver: obj; restart! ! !MethodContext methodsFor: 'private-exceptions' stamp: 'ajh 10/8/2001 23:56'! swapReceiver: r receiver := r! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MethodContext class instanceVariableNames: ''! !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! ! TestCase subclass: #MethodContextTest instanceVariableNames: 'aCompiledMethod aReceiver aMethodContext aSender' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Methods'! !MethodContextTest commentStamp: 'tlk 5/31/2004 16:07' prior: 0! 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: '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: '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: '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: 'tests' stamp: 'tlk 5/31/2004 17:08'! testMethodIsBottomContext self assert: aMethodContext bottomContext = aSender. self assert: aMethodContext secondFromBottom = aMethodContext.! ! !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 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: '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: '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: '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'! 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: '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 class instanceVariableNames: ''! !MethodContextTest class methodsFor: 'closures for testing' stamp: 'mada 5/3/2012 18:57'! contextWithTempForTesting | string | string := 'test'. ^ [self class. string asUppercase] asContext. ! ! BehaviorInstallingDeclaration subclass: #MethodDeclaration instanceVariableNames: 'categoryReader categoryName stamp' classVariableNames: '' poolDictionaries: '' category: 'CodeImport'! !MethodDeclaration commentStamp: '' prior: 0! 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: 'accessing' stamp: 'GuillermoPolito 5/5/2012 20:13'! category: aCategoryName categoryName := aCategoryName! ! !MethodDeclaration methodsFor: 'accessing' stamp: 'GuillermoPolito 5/5/2012 16:24'! categoryReader: aClassCategoryReader categoryReader := aClassCategoryReader! ! !MethodDeclaration methodsFor: 'accessing' stamp: 'GuillermoPolito 5/5/2012 20:13'! stamp: aMethodStamp stamp := aMethodStamp! ! !MethodDeclaration methodsFor: 'importing' stamp: 'GuillermoPolito 5/5/2012 20:41'! import (self existsBehavior) ifFalse: [ self error: ('Cannot install method in unexistent behavior {1}' format: { behaviorName asString } ) ]. ^self targetClass compile: contents classified: categoryName withStamp: stamp notifying: nil! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MethodDeclaration class instanceVariableNames: ''! !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! ! AbstractMethodIconAction subclass: #MethodDefaultAction instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Nautilus-Widgets'! !MethodDefaultAction commentStamp: '' prior: 0! Action by default, empty icon! !MethodDefaultAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 2/20/2013 19:57'! actionOrder "Return the priority of this action" ^ 9999999999999999999999999999! ! !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: 'BenjaminVanRyseghem 1/2/2013 13:04'! isActionHandled "Return true if the provided method fits this action requirement" ^ true! ! !MethodDefaultAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 1/2/2013 13:04'! privateActionIcon "Return the icon for this action" ^ self iconClass iconNamed: #blank! ! Dictionary variableSubclass: #MethodDictionary instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Methods'! !MethodDictionary commentStamp: 'StephaneDucasse 2/27/2010 22:35' prior: 0! 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: '*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: 'accessing' stamp: 'StephaneDucasse 8/25/2010 22:14'! add: anAssociation ^ self at: anAssociation key put: anAssociation 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: '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: '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: '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: 'accessing' stamp: 'Alexandre Bergel 12/25/2009 08:13'! includesKey: aSymbol "This override assumes that pointsTo is a fast primitive" aSymbol ifNil: [^ false]. ^ self pointsTo: aSymbol! ! !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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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 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: 'private' stamp: 'StephaneDucasse 8/25/2010 22:01'! postCopy array := array copy! ! !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'! 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: '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: '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 class instanceVariableNames: ''! !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: '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'! new: numberOfElements "Create an instance large enough to hold numberOfElements methods without growing." ^self newForCapacity: (self sizeFor: numberOfElements)! ! !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 ! ! !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 ! ! TestCase subclass: #MethodDictionaryTest uses: TIncludesTest + TDictionaryKeysValuesAssociationsAccess + TDictionaryRemovingTest instanceVariableNames: 'nonEmptyDict' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Methods'! !MethodDictionaryTest methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'TestRunner 12/25/2009 08:23'! testIncludesKeyLocalyDefined " self debug: #testIncludesKeyLocalyDefined " self assert: (self class methodDictionary includesKey: #testIncludesKeyLocalyDefined).! ! !MethodDictionaryTest methodsFor: 'as yet unclassified' 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: 'assertions' stamp: 'GuillermoPolito 8/28/2010 19:53'! assertPreservesCapacity: oldDictionary comparedTo: rehashedDictionary self assert: oldDictionary capacity = rehashedDictionary capacity.! ! !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: 'helpers' stamp: 'Alexandre Bergel 12/25/2009 08:21'! aValue ^ self class >> #aValue! ! !MethodDictionaryTest methodsFor: 'helpers' stamp: 'Alexandre Bergel 12/25/2009 08:20'! anIndex ^ #aMethodName! ! !MethodDictionaryTest methodsFor: 'helpers' stamp: 'Alexandre Bergel 12/25/2009 08:21'! anotherValue ^ self class >> #anotherValue! ! !MethodDictionaryTest methodsFor: 'requirement' stamp: 'Alexandre Bergel 12/25/2009 08:22'! speciesClass ^ 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: 'requirements' stamp: 'Alexandre Bergel 12/25/2009 08:29'! elementNotIn "return an element not included in 'nonEmpty' " ^ self class >> #elementNotIn! ! !MethodDictionaryTest methodsFor: 'requirements' stamp: 'Alexandre Bergel 12/25/2009 08:25'! empty ^ MethodDictionary new! ! !MethodDictionaryTest methodsFor: 'requirements' stamp: 'Alexandre Bergel 12/25/2009 08:31'! emptyDict ^ self empty! ! !MethodDictionaryTest methodsFor: 'requirements' stamp: 'TestRunner 12/25/2009 08:35'! keyNotIn " return a key not included in nonEmpty" ^ #bouba! ! !MethodDictionaryTest methodsFor: 'requirements' stamp: 'TestRunner 12/25/2009 08:37'! keyNotInNonEmptyDict " return a key not included in nonEmptyDict" ^ #keyNotInNonEmptyDict! ! !MethodDictionaryTest methodsFor: 'requirements' stamp: 'Alexandre Bergel 12/25/2009 08:31'! newEmptyDict ^ MethodDictionary new! ! !MethodDictionaryTest methodsFor: 'requirements' stamp: 'Alexandre Bergel 12/25/2009 08:27'! nonEmpty ^ nonEmptyDict! ! !MethodDictionaryTest methodsFor: 'requirements' stamp: 'TestRunner 12/25/2009 08:30'! nonEmptyDict ^ nonEmptyDict ! ! !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: '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: 'setUps' stamp: 'GuillermoPolito 8/28/2010 19:59'! modifiedMethodDictionaryCopy | copy | copy := self class methodDict copy. copy at: #methodAddedToIncreaseTheDict put: Object >> #=. ^copy.! ! !MethodDictionaryTest methodsFor: 'test - removing'! 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: 'test - removing'! testRemove self should: [self nonEmptyDict remove: nil] raise: Error. self should: [self nonEmptyDict remove: nil ifAbsent: ['What ever here']] raise: Error.! ! !MethodDictionaryTest methodsFor: 'test - removing'! 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: 'test - removing'! 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: 'tests - Dictionary keys values associations access'! 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 - Dictionary keys values associations access'! testKeys | collection result | collection := self nonEmpty. result := collection keys. result do: [ :key | self shouldnt: [collection at: key ] raise:Error ]. self assert: result size = collection size . self should: [result detect: [:each | (result occurrencesOf: each ) > 1] ] raise: Error. ! ! !MethodDictionaryTest methodsFor: 'tests - Dictionary keys values associations access'! testKeysSortedSafely | collection result | collection := self nonEmpty. result := collection keysSortedSafely . result do: [ :key | self shouldnt: [collection at: key ] raise:Error ]. self assert: result size = collection size . self should: [result detect: [:each | (result occurrencesOf: each ) > 1] ] raise: Error. self assert: result asArray isSorted.! ! !MethodDictionaryTest methodsFor: 'tests - Dictionary keys values associations access'! 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 - fixture'! test0FixtureDictionaryKeysValuesAssociationsAccess self shouldnt: [self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty .! ! !MethodDictionaryTest methodsFor: 'tests - fixture'! test0FixtureDictionaryRemovingTest self shouldnt: [self nonEmptyDict ] raise: Error. self deny: self nonEmptyDict isEmpty. self shouldnt: [self keyNotInNonEmptyDict ] raise: Error. self deny: (self nonEmptyDict keys includes: self keyNotInNonEmptyDict ).! ! !MethodDictionaryTest methodsFor: 'tests - fixture'! test0FixtureIncludeTest | anElementIn | self shouldnt: [ self nonEmpty ]raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self elementNotIn ]raise: Error. anElementIn := true. self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self shouldnt: [ self anotherElementNotIn ]raise: Error. anElementIn := true. self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self shouldnt: [ self empty ] raise: Error. self assert: self empty isEmpty. ! ! !MethodDictionaryTest methodsFor: 'tests - includes'! 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 - includes'! testIncludesAllNoneThere "self debug: #testIncludesAllOfNoneThere'" self deny: (self empty includesAll: self nonEmpty ). self deny: (self nonEmpty includesAll: { self elementNotIn. self anotherElementNotIn })! ! !MethodDictionaryTest methodsFor: 'tests - includes'! 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 - includes'! testIncludesAnyNoneThere "self debug: #testIncludesAnyOfNoneThere'" self deny: (self nonEmpty includesAny: self empty). self deny: (self nonEmpty includesAny: { self elementNotIn. self anotherElementNotIn })! ! !MethodDictionaryTest methodsFor: 'tests - includes'! 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: 'tests - includes'! testIncludesElementIsThere "self debug: #testIncludesElementIsThere" self assert: (self nonEmpty includes: self nonEmpty 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: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 - 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 - 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: '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 - 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: '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: '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: '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 - 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: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: '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 - rehashing' stamp: 'MarianoMartinezPeck 9/27/2011 20:09'! testRehashPreservesCapacity | oldDictionary rehashedDictionary | oldDictionary := self modifiedMethodDictionaryCopy. rehashedDictionary := oldDictionary copy rehash. self assertPreservesCapacity: oldDictionary comparedTo: rehashedDictionary.! ! !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: '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 class uses: TIncludesTest classTrait + TDictionaryKeysValuesAssociationsAccess classTrait + TDictionaryRemovingTest classTrait instanceVariableNames: ''! Object subclass: #MethodFinder instanceVariableNames: 'data answers selector argMap thisData mapStage mapList expressions cachedClass cachedArgNum cachedSelectorLists' classVariableNames: 'AddAndRemove Approved Blocks Dangerous' poolDictionaries: '' category: 'Tools-Finder'! !MethodFinder commentStamp: 'sd 4/21/2011 17:22' prior: 0! 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: 'accessing' stamp: 'tk 12/29/2000 13:39'! answers ^ answers! ! !MethodFinder methodsFor: 'accessing' stamp: 'tk 12/29/2000 13:39'! data ^ data! ! !MethodFinder methodsFor: 'accessing' stamp: 'tk 12/29/2000 13:20'! expressions ^ expressions! ! !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: 'argument permutation maps' stamp: 'tk 4/24/1999 19:29'! argMap ^ argMap ! ! !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: '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: '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 4/24/1999 19:29'! thisData ^ thisData ! ! !MethodFinder methodsFor: 'debugging it' 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: 'debugging it' stamp: 'CamilloBruni 5/9/2012 11:51'! testRandom "verify that the methods allowed don't crash the system. Pick 3 or 4 from a mixed list of the fundamental types." "MethodFinder new testRandom" | objects other aa cnt take tuple fName sss | objects := #( #(1 4 17 42) #($a $b $c $d) #('one' 'two' 'three' 'four') #(#x #+ #rect: #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}. {"{ 4 blocks }." (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. " fName := (FileSystem workingDirectory filesMatching: '*.ran') first basename. sss := fName splitInteger first. (Collection classPool at: #RandomForPicking) seed: sss. cnt := 0. [ take := #(3 4) atRandom. tuple := (1 to: take) collect: [ :ind | objects atRandom atRandom ]. other := (1 to: take) collect: [ :ind | objects atRandom atRandom ]. self load: (aa := Array with: tuple with: 1 with: other with: 7). (cnt := cnt + 1) \\ 10 = 0 ifTrue: [ Transcript cr; show: cnt printString; tab; tab; show: aa first printString ]. " | (cnt > Skip)" cnt > (Smalltalk globals at: #StopHere) ifTrue: [ self halt ]. "stop just before crash" cnt > (Smalltalk globals at: #Skip) ifTrue: [ "skip this many at start" self search: true. self test2: aa first. self test2: (aa at: 3) "self test2: objects" ]. true ] whileTrue! ! !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/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: '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: '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: '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: '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: '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: '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 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: '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: 'initialize' stamp: 'SvenVanCaekenberghe 12/4/2012 19:08'! 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 defaultLabelForInspector 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:modify: 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" compilerClass decompilerClass evaluatorClass format methodDict parserClass 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" classVersion 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: newDay:month:year: newDay:year: today "in class, general inquiries" dateAndTimeNow dayOfWeek: daysInMonth:forYear: daysInYear: firstWeekdayOfMonth:year: indexOfMonth: leapYear: 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: dateAndTimeNow 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" atRandom 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: atRandom: 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 "private" copyReplaceAll:with:asTokens: ) 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: 'initialize' stamp: 'EstebanLorenzano 8/17/2012 16:40'! 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 fromPacked: "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: crc16 endsWith: endsWithAnyOf: sameAs: startingAt:match:startingAt: "copying" copyReplaceTokens:with: padLeftTo: padRightTo: padLeftTo:with: padRightTo:with: "converting" asByteArray asDate asFileName asLegalSelector asPacked asText asTime asUrl asUrlRelativeTo: capitalized compressWithTable: contractTo: correctAgainst: encodeForHTTP 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 unescapePercents withInternetLineEndings withSqueakLineEndings withoutQuoting "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: fromRgbTriplet: 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" colorNames 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 ) (at:modify: 2 ) (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: 'initialize' stamp: 'sd 4/21/2011 17:10'! initialize3 "additional selectors to consider" #(asWords threeDigitName ) do: [:sel | Approved add: sel].! ! !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: '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: '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 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: '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: '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'! 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: '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: 'tests' stamp: 'sd 4/21/2011 16:58'! 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 + rect: 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: 'tests' stamp: 'sd 4/21/2011 16:58'! verify "Test a bunch of examples" " MethodFinder new verify " Approved ifNil: [self initialize]. "Sets of allowed selectors" (MethodFinder new load: #(('abcd') $a ('TedK') $T) ) searchForOne asArray = #('data1 asCharacter' 'data1 first' 'data1 anyOne') ifFalse: [self error: 'should have found it']. (MethodFinder new load: #(('abcd' 1) $a ('Ted ' 3) $d ) ) searchForOne asArray = #('data1 at: data2' 'data1 atPin: data2' 'data1 atWrap: data2') ifFalse: [self error: 'should have found it']. (MethodFinder new load: #(((12 4 8)) 24 ((1 3 6)) 10 ) ) searchForOne asArray= #('data1 sum') ifFalse: [self error: 'should have found it']. "note extra () needed for an Array object as an argument" (MethodFinder new load: #((4) 4 (-10) 10 (-3) 3 (2) 2 (-6) 6 (612) 612) ) searchForOne asArray = #('data1 abs') ifFalse: [self error: 'should have found it']. (MethodFinder new load: {#(4 3). true. #(-7 3). false. #(5 1). true. #(5 5). false} ) searchForOne asArray = #('data1 > data2') ifFalse: [self error: 'should have found it']. (MethodFinder new load: #((12 4 8) 2 (1 3 6) 2 (5 2 16) 8) ) searchForOne asArray = #() " '(data3 / data2) ' want to be able to leave out args" ifFalse: [self error: 'should have found it']. (MethodFinder new load: #((0.0) 0.0 (1.5) 0.997495 (0.75) 0.681639) ) searchForOne asArray = #('data1 sin') ifFalse: [self error: 'should have found it']. (MethodFinder new load: #((7 5) 2 (4 5) 4 (-9 4) 3) ) searchForOne asArray = #('data1 \\ data2') ifFalse: [self error: 'should have found it']. (MethodFinder new load: #((7) 2 (4) 2 ) ) searchForOne asArray = #('^ 2') ifFalse: [self error: 'should have found it']. (MethodFinder new load: {#(7). true. #(4.1). true. #(1.5). false} ) searchForOne asArray = #('data1 >= 4.1') ifFalse: [self error: 'should have found it']. (MethodFinder new load: #((35) 3 (17) 1 (5) 5) ) searchForOne asArray = #('data1 \\ 8') ifFalse: [self error: 'should have found it']. (MethodFinder new load: #((36) 7 (50) 10 ) ) searchForOne asArray = #('data1 quo: 5' 'data1 // 5') ifFalse: [ self error: 'should have found it']. (MethodFinder new load: #( ((2 3) 2) 8 ((2 3) 5) 17 ) ) searchForOne asArray = #('data1 polynomialEval: data2') ifFalse: [ self error: 'should have found it']. (MethodFinder new load: #((2) 8 (5) 17 ) ) searchForOne asArray = #('#(2 3) polynomialEval: data1') ifFalse: [ self error: 'should have found it']. ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MethodFinder class instanceVariableNames: ''! !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! ! TestCase subclass: #MethodFinderTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolsTest-Finder'! !MethodFinderTest commentStamp: 'sd 4/21/2011 16:54' prior: 0! To do: - radix should be returned ! !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: '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: '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 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: '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: '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: '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:11'! testSubstraction "self debug: #testSubstraction" self assert: (MethodFinder new load: #((14 3) 11 (-10 5) -15 (4 -3) 7)) searchForOne asArray = #('data1 - data2')! ! AbstractMethodIconAction subclass: #MethodFromTraitAction instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Nautilus-Widgets'! !MethodFromTraitAction commentStamp: '' prior: 0! Action when the method comes from a trait! !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! ! !MethodFromTraitAction methodsFor: 'order' stamp: 'EstebanLorenzano 1/15/2013 18:19'! privateActionIcon "Return the icon for this action" ^ IconicButton new target: method originMethod; actionSelector: #browse; labelGraphic: (self iconClass iconNamed: #trait) ; color: Color transparent; extent: 12 @ 12; helpText: 'Browse the trait'; borderWidth: 0! ! ClosureCompilerTest subclass: #MethodHighlightingTests instanceVariableNames: 'creator timeStamp duration tracks' classVariableNames: '' poolDictionaries: '' category: 'CompilerTests'! !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'. ]. ! ! !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! ! AbstractMethodIconAction subclass: #MethodIsAbstractAction instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Nautilus-Widgets'! !MethodIsAbstractAction commentStamp: '' prior: 0! Action when the method is abstract! !MethodIsAbstractAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 2/20/2013 19:57'! actionOrder "Return the priority of this action" ^ 700! ! !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: 'BenjaminVanRyseghem 1/2/2013 12:58'! isActionHandled ^ method isAbstract! ! !MethodIsAbstractAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 1/14/2013 08:21'! privateActionIcon "Return the icon for this action" ^ self iconClass iconNamed: #abstract! ! AbstractMethodIconAction subclass: #MethodIsTestAction instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Nautilus-Widgets'! !MethodIsTestAction commentStamp: '' prior: 0! Aciton when the method is a test! !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! ! !MethodIsTestAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 1/2/2013 12:57'! privateActionIcon "Return the icon for this action" | testIcon | testIcon := self iconClass iconNamed: #testNotRun. method hasPassedTest ifTrue: [ testIcon := self iconClass iconNamed: #testGreen ]. method hasFailedTest ifTrue: [ testIcon := self iconClass iconNamed: #testYellow ]. method hasErrorTest ifTrue: [ testIcon := self iconClass iconNamed: #testRed ]. ^ 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! ! SystemAnnouncement subclass: #MethodModified instanceVariableNames: 'methodClass newMethod newProtocol oldMethod oldProtocol selector' classVariableNames: '' poolDictionaries: '' category: 'System-Announcements'! !MethodModified commentStamp: 'BenjaminVanRyseghem 4/1/2011 16:04' prior: 0! 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:11'! methodAffected ^self newMethod! ! !MethodModified methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:47'! methodClass ^ methodClass! ! !MethodModified methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:47'! methodClass: anObject methodClass := anObject! ! !MethodModified methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:55'! newMethod ^ newMethod! ! !MethodModified methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:55'! newMethod: aCompiledMethod newMethod := aCompiledMethod.! ! !MethodModified methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:47'! newProtocol ^ newProtocol! ! !MethodModified methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:47'! newProtocol: anObject newProtocol := anObject! ! !MethodModified methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:52'! oldMethod ^ oldMethod! ! !MethodModified methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:55'! oldMethod: aCompiledMethod oldMethod := aCompiledMethod.! ! !MethodModified methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:47'! oldProtocol ^ oldProtocol! ! !MethodModified methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:47'! oldProtocol: anObject oldProtocol := anObject! ! !MethodModified methodsFor: 'accessing' stamp: 'GuillermoPolito 8/3/2012 14:02'! selector ^ selector! ! !MethodModified methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:47'! selector: anObject selector := anObject! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MethodModified class instanceVariableNames: ''! !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! ! DialogWindow subclass: #MethodNameEditor instanceVariableNames: 'argumentIndex labelMorph methodName selectorField' classVariableNames: '' poolDictionaries: '' category: 'NautilusRefactoring-Utilities'! !MethodNameEditor commentStamp: '' prior: 0! 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: 'accessing'! argumentIndex ^ argumentIndex! ! !MethodNameEditor methodsFor: 'accessing'! argumentIndex: anInteger argumentIndex := anInteger. self update! ! !MethodNameEditor methodsFor: 'accessing'! argumentList ^ self methodName arguments! ! !MethodNameEditor methodsFor: 'accessing'! methodName ^ methodName! ! !MethodNameEditor methodsFor: 'accessing'! selector ^ self methodName selector! ! !MethodNameEditor methodsFor: 'accessing'! selector: aString self methodName selector: aString. self update! ! !MethodNameEditor methodsFor: 'actions'! cancel methodName := nil. ^ super cancel! ! !MethodNameEditor methodsFor: 'actions'! down self isDownEnabled ifFalse: [ ^ self ]. self argumentList swap: self argumentIndex with: self argumentIndex + 1. self argumentIndex: self argumentIndex + 1! ! !MethodNameEditor methodsFor: 'actions'! up self isUpEnabled ifFalse: [ ^ self ]. self argumentList swap: self argumentIndex with: self argumentIndex - 1. self argumentIndex: self argumentIndex - 1! ! !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: '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: 'grips' stamp: 'BenjaminVanRyseghem 4/25/2012 13:53'! addGrips self addEdgeGrips! ! !MethodNameEditor methodsFor: 'initialization'! initializeOn: aMethodName methodName := aMethodName. argumentIndex := 0. self initialize. self title: 'Method Name'! ! !MethodNameEditor methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 4/25/2012 13:39'! initialize "Initialization code for MethodNameEditor" super initialize. self beResizeable! ! !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'! newOKButton ^ self newOKButtonFor: self getEnabled: #isOkEnabled! ! !MethodNameEditor methodsFor: 'morphic'! update self changed: #argumentList; changed: #argumentIndex. self changed: #isUpEnabled; changed: #isDownEnabled; changed: #isOkEnabled. labelMorph contents: self methodName printString! ! !MethodNameEditor methodsFor: 'testing'! isDownEnabled ^ self argumentIndex ~= 0 and: [ self argumentIndex + 1 between: 1 and: self argumentList size ]! ! !MethodNameEditor methodsFor: 'testing'! isOkEnabled ^ self methodName isValid! ! !MethodNameEditor methodsFor: 'testing'! isUpEnabled ^ self argumentIndex ~= 0 and: [ self argumentIndex - 1 between: 1 and: self argumentList size ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MethodNameEditor class instanceVariableNames: ''! !MethodNameEditor class methodsFor: 'instance creation'! on: aMethodName ^ self basicNew initializeOn: aMethodName! ! !MethodNameEditor class methodsFor: 'instance creation'! openOn: aMethodName ^ UITheme builder openModal: (self on: aMethodName)! ! ParseNode subclass: #MethodNode instanceVariableNames: 'selectorOrFalse precedence arguments block primitive encoder temporaries properties sourceText locationCounter localsPool' classVariableNames: '' poolDictionaries: '' category: 'Compiler-ParseNodes'! !MethodNode commentStamp: '' prior: 0! I am the root of the parse tree.! !MethodNode methodsFor: 'accessing' stamp: 'eem 7/21/2009 16:00'! arguments "For transformations etc, not used in compilation" ^arguments! ! !MethodNode methodsFor: 'accessing' stamp: 'eem 7/21/2009 16:00'! arguments: aSequence "For transformations etc, not used in compilation" arguments := aSequence! ! !MethodNode methodsFor: 'accessing' stamp: 'md 7/27/2006 19:12'! body ^block! ! !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: 'accessing' stamp: 'eem 6/11/2009 17:27'! removeProperty: aSymbol properties := properties copyWithout: (Association key: aSymbol value: (properties propertyValueAt: aSymbol))! ! !MethodNode methodsFor: 'accessing' stamp: 'eem 7/21/2009 15:59'! temporaries "For transformations etc, not used in compilation" ^temporaries! ! !MethodNode methodsFor: 'accessing' stamp: 'eem 7/21/2009 15:59'! temporaries: aSequence "For transformations etc, not used in compilation" temporaries := aSequence! ! !MethodNode methodsFor: 'code generation'! encoder ^ encoder! ! !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: '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: '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: '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: 'code generation' stamp: 'ajh 7/6/2003 15:25'! parserClass "Which parser produces this class of parse node" ^ Parser! ! !MethodNode methodsFor: 'code generation' stamp: 'lr 2/6/2006 23:24'! properties ^ properties! ! !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: '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: 'code generation (closures)' stamp: 'eem 5/29/2008 15:27'! addLocalsToPool: locals "" localsPool isNil ifTrue: [localsPool := IdentitySet new]. localsPool addAll: locals! ! !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/20/2008 13:43'! locationCounter ^locationCounter! ! !MethodNode methodsFor: 'code generation (closures)' stamp: 'eem 5/30/2008 11:27'! noteBlockEntry: aBlock "Evaluate aBlock with the numbering for the block entry." locationCounter isNil ifTrue: [locationCounter := -1]. aBlock value: locationCounter + 1. locationCounter := locationCounter + 2! ! !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: '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: 'ar 4/17/2010 16:50'! decompileString "Answer a string description of the parse tree whose root is the receiver." ^self fullPrintString ! ! !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: '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: 'debugger support' stamp: 'Igor.Stasenko 12/20/2009 03:59'! 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 := encoder classEncoding parserClass new encoderClass: encoder class; parse: (sourceText ifNil: [self decompileString]) class: self methodClass. "As a side effect generate: creates data needed for the map." methNode generate. methNode encoder blockExtentsToTempsMap]! ! !MethodNode methodsFor: 'debugger support' stamp: 'eem 7/1/2009 13:45'! hasGeneratedMethod ^encoder hasGeneratedMethod! ! !MethodNode methodsFor: 'debugger support' stamp: 'Igor.Stasenko 12/20/2009 03:58'! schematicTempNamesString "Answer the temp names for the current method node in a form that captures temp structure. The temps at each method and block scope level occur space-separated, with any indirect temps enclosed in parentheses. Each block level is enclosed in square brackets. e.g. 'method level temps (indirect temp)[block args and temps (indirect)]' This representation can be reconstituted into a blockExtentsToTempsMap by a CompiledMethod that has been copied with the schematicTempNamesString." encoder hasGeneratedMethod ifFalse: ["create the encoder's blockExtentsToLoals map, except if the method is quick in which case it has no temps." (self generate) isQuick ifTrue: [^'']]. ^encoder schematicTempNamesString! ! !MethodNode methodsFor: 'initialize-release' stamp: 'tk 8/3/1999 12:47'! block ^ block! ! !MethodNode methodsFor: 'initialize-release' stamp: 'ajh 1/24/2003 17:37'! selector: symbol selectorOrFalse := symbol! ! !MethodNode methodsFor: 'initialize-release'! 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: '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: 'initialize-release' stamp: 'ajh 1/22/2003 17:53'! sourceText: stringOrText sourceText := stringOrText! ! !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: 'printing' stamp: 'ajh 1/22/2003 17:39'! methodClass ^ encoder classEncoding! ! !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: '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: '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: '.! ! !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: 'printing' stamp: 'EstebanLorenzano 8/17/2012 16:41'! printWithClosureAnalysisOn: aStream self ensureClosureAnalysisDone. precedence = 1 ifTrue: [(self selector includesSubstring: '()/') ifTrue: [aStream nextPutAll: (self selector copyUpTo: $)). arguments do: [:arg| aStream nextPutAll: arg key] separatedBy: [aStream nextPutAll: ', ']. aStream nextPut: $)] ifFalse: [aStream nextPutAll: self selector]] "no node for method selector" ifFalse: [self selector keywords with: arguments do: [:kwd :arg | aStream nextPutAll: kwd; space. arg printDefinitionForClosureAnalysisOn: aStream. aStream space]]. comment == nil ifFalse: [aStream crtab: 1. self printCommentOn: aStream indent: 1]. temporaries size > 0 ifTrue: [aStream crtab: 1; nextPut: $|. temporaries do: [:temp | aStream space. temp printDefinitionForClosureAnalysisOn: aStream]. aStream space; nextPut: $|]. 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 printWithClosureAnalysisStatementsOn: aStream indent: 0! ! !MethodNode methodsFor: 'printing' stamp: 'MarcusDenker 4/29/2012 09:35'! sourceCode ^ self sourceText.! ! !MethodNode methodsFor: 'printing' stamp: 'ajh 1/24/2003 17:41'! sourceText ^ sourceText ifNil: [self printString]! ! !MethodNode methodsFor: 'printing'! tempNames ^ encoder tempNames! ! !MethodNode methodsFor: 'source mapping' stamp: 'eem 6/4/2008 19:21'! rawSourceRanges ^self rawSourceRangesAndMethodDo: [:rawSourceRanges :method| rawSourceRanges]! ! !MethodNode methodsFor: 'source mapping' stamp: 'Igor.Stasenko 12/20/2009 03:54'! rawSourceRangesAndMethodDo: aBinaryBlock "Evaluate aBinaryBlock with the rawSourceRanges and method generated from the receiver." | methNode method | methNode := encoder classEncoding parserClass new encoderClass: encoder class; parse: (sourceText "If no source, use decompile string as source to map from" ifNil: [self decompileString] ifNotNil: [sourceText]) class: self methodClass. method := methNode generate. "set bytecodes to map to" ^aBinaryBlock value: methNode encoder rawSourceRanges value: method! ! !MethodNode methodsFor: 'visiting' stamp: 'eem 9/6/2009 12:35'! accept: aVisitor ^aVisitor visitMethodNode: self! ! TestCase subclass: #MethodNodeTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CompilerTests'! !MethodNodeTest methodsFor: 'testing' stamp: 'MarcusDenker 4/29/2012 09:51'! testGenerateWithSource | source ast method | source := 'testMethod |hello| ^hello. ' . ast := Compiler new compile: source in: self class notifying: nil ifFail: [self error: 'compilation error']. method := ast generateWithSource. self assert: (method isKindOf: CompiledMethod). self assert: method trailer hasSourcePointer not. self assert: method trailer hasSource. self assert: (method sourceCode = source). ! ! AbstractMethodIconAction subclass: #MethodOveridesAction instanceVariableNames: 'isOverridden isOverride result' classVariableNames: '' poolDictionaries: '' category: 'Nautilus-Widgets'! !MethodOveridesAction commentStamp: '' prior: 0! 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: 'BenjaminVanRyseghem 2/20/2013 19:57'! actionOrder "Return the priority of this action" ^ 600! ! !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 1/2/2013 13:06'! privateActionIcon "Return the icon for this action" | testMethod | isOverride ifTrue: [ isOverridden ifTrue: [ result := self buildUpAndDownArrowIcon: method. ^ result key ] ifFalse: [ ^ IconicButton new target: self browser; actionSelector: #arrowUp:; arguments: {method}; labelGraphic: (self iconClass iconNamed: #arrowUp); 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: (self iconClass iconNamed: #arrowDown); color: Color transparent; helpText: 'Browse overriding messages'; extent: 12 @ 12; borderWidth: 0 ] ]! ! !MethodOveridesAction methodsFor: 'private' stamp: 'BenjaminVanRyseghem 1/2/2013 13:08'! 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: (self iconClass iconNamed: #arrowDoubleUp); color: Color transparent; extent: 12 @ 6; helpText: 'Browse overriden message'; borderWidth: 0. down := IconicButton new target: self browser; actionSelector: #arrowDown:; arguments: { aMethod }; labelGraphic: (self iconClass iconNamed: #arrowDoubleDown); color: Color transparent; extent: 12 @ 6; helpText: 'Browse overriding messages'; borderWidth: 0. ^ (container changeTableLayout; listDirection: #topToBottom; addMorph: down; addMorph: up; yourself) -> {up. down}.! ! TestCase subclass: #MethodPragmaTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Methods'! !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' 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' 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: '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' 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-compiled' stamp: 'lr 2/6/2006 21:03'! testNoPragma | method | method := self compile: '' selector: #foo. self assert: method pragmas = #().! ! !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 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-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-compiler' stamp: 'lr 1/20/2006 02:25'! testCompileEmpty self assertPragma: 'foo' givesKeyword: #foo arguments: #().! ! !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-compiler' stamp: 'lr 10/5/2006 10:15'! 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: '' 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. self should: [ self compile: '' selector: #zork ] raise: SyntaxErrorNotification. self should: [ self compile: '' selector: #zork ] raise: SyntaxErrorNotification! ! !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-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-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-compiler' stamp: 'lr 7/3/2006 15:00'! testCompileTemps "Pragmas should be placeable before and after temps." self shouldnt: [ self assert: (self compile: '| temps | ' selector: #zork) pragmas notEmpty ] raise: SyntaxErrorNotification. self shouldnt: [ self assert: (self compile: ' | temps |' selector: #zork) pragmas notEmpty ] raise: SyntaxErrorNotification.! ! !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-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-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-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: '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-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-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: '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-method' stamp: 'lr 1/20/2006 07:54'! testSelector | pragma | pragma := self pragma: 'foo' selector: #bar. self assert: pragma selector == #bar.! ! !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-pragma' stamp: 'lr 1/20/2006 00:35'! testKeyword | pragma | pragma := Pragma keyword: #foo: arguments: #( 123 ). self assert: pragma keyword = #foo:.! ! !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: '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-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-primitives' stamp: 'lr 1/20/2006 02:42'! testPrimitiveNamed1 "This test useses the #primitiveDirectoryLookup primitive." self compile: ' ^ #lookup' selector: #lookup. self assert: self lookup = #lookup. ! ! !MethodPragmaTest methodsFor: 'testing-primitives' stamp: 'CamilloBruni 5/9/2012 11:47'! testPrimitiveNamed2 "This test useses the #primPathNameDelimiter primitive." self compile: ' ^ #delim' selector: #delim. self assert: self delim = FilePluginPrims new delimiter. ! ! !MethodPragmaTest methodsFor: 'utilities' stamp: 'EstebanLorenzano 8/17/2012 16:40'! assertPragma: aString givesKeyword: aSymbol arguments: anArray | pragma decompiled | pragma := self pragma: aString selector: #zork. self assert: pragma keyword = aSymbol. self assert: pragma arguments = anArray. decompiled := (self class>>#zork) decompile. self assert: (decompiled properties pragmas includes: pragma). self assert: (decompiled asString includesSubstring: pragma asString).! ! !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: 'utilities' stamp: 'lr 1/20/2006 11:50'! methodCategory ^ #generated! ! !MethodPragmaTest methodsFor: 'utilities' stamp: 'lr 2/6/2006 20:48'! pragma: aString selector: aSelector ^ (self compile: '<' , aString , '>' selector: aSelector) pragmas first.! ! !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.! ! SystemAnnouncement subclass: #MethodRecategorized instanceVariableNames: 'methodClass methodRecategorized newProtocol oldProtocol selector' classVariableNames: '' poolDictionaries: '' category: 'System-Announcements'! !MethodRecategorized commentStamp: 'cyrilledelaunay 1/18/2011 15:03' prior: 0! 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/3/2012 14:10'! methodAffected ^self methodRecategorized! ! !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'! methodRecategorized ^ methodRecategorized! ! !MethodRecategorized methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:57'! methodRecategorized: anObject methodRecategorized := anObject! ! !MethodRecategorized methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:57'! newProtocol ^ newProtocol! ! !MethodRecategorized methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:57'! newProtocol: anObject newProtocol := anObject! ! !MethodRecategorized methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:57'! oldProtocol ^ oldProtocol! ! !MethodRecategorized methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:57'! oldProtocol: anObject oldProtocol := anObject! ! !MethodRecategorized methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:57'! selector ^ selector! ! !MethodRecategorized methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 09:57'! selector: anObject selector := anObject! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MethodRecategorized class instanceVariableNames: ''! !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! ! SystemAnnouncement subclass: #MethodRemoved instanceVariableNames: 'methodRemoved protocol selector methodClass methodOrigin' classVariableNames: '' poolDictionaries: '' category: 'System-Announcements'! !MethodRemoved commentStamp: 'cyrilledelaunay 1/18/2011 14:43' prior: 0! 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/3/2012 14:10'! methodAffected ^self methodRemoved! ! !MethodRemoved methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:49'! methodClass ^methodClass! ! !MethodRemoved methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:48'! methodClass: anObject methodClass := anObject! ! !MethodRemoved methodsFor: 'accessing' stamp: 'MartinDias 2/11/2013 14:09'! methodOrigin ^ methodOrigin! ! !MethodRemoved methodsFor: 'accessing' stamp: 'MartinDias 2/11/2013 14:09'! methodOrigin: anObject methodOrigin := anObject ! ! !MethodRemoved methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:48'! methodRemoved ^ 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'! protocol ^ protocol! ! !MethodRemoved methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:48'! protocol: anObject protocol := anObject! ! !MethodRemoved methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:49'! selector ^selector! ! !MethodRemoved methodsFor: 'accessing' stamp: 'GuillermoPolito 8/2/2012 00:48'! selector: anObject selector := anObject! ! !MethodRemoved methodsFor: 'testing' stamp: 'MartinDias 2/11/2013 14:09'! isProvidedByATrait ^ self methodOrigin ~= self methodClass ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MethodRemoved class instanceVariableNames: ''! !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! ! SystemAnnouncement subclass: #MethodRepackaged instanceVariableNames: 'methodRepackaged newPackage oldPackage' classVariableNames: '' poolDictionaries: '' category: 'RPackage-SystemIntegration'! !MethodRepackaged methodsFor: 'accessing' stamp: 'GuillermoPolito 8/17/2012 17:18'! methodRepackaged ^ methodRepackaged! ! !MethodRepackaged methodsFor: 'accessing' stamp: 'GuillermoPolito 8/17/2012 17:18'! methodRepackaged: anObject methodRepackaged := anObject! ! !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 methodsFor: 'accessing' stamp: 'GuillermoPolito 8/17/2012 17:18'! oldPackage ^ oldPackage! ! !MethodRepackaged methodsFor: 'accessing' stamp: 'GuillermoPolito 8/17/2012 17:18'! oldPackage: anObject oldPackage := anObject! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MethodRepackaged class instanceVariableNames: ''! !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.! ! ComposableModel subclass: #MethodToolbar instanceVariableNames: 'methodHolder browseModel sendersModel implementorsModel versionModel dropListModel model' classVariableNames: '' poolDictionaries: '' category: 'Spec-Widgets-PolyWidgets'! !MethodToolbar commentStamp: '' prior: 0! A MethodToolbar is xxxxxxxxx. | b | b := MethodToolbar new. b openWithSpec. b method: (ButtonModel>>#state:). b method: nil! !MethodToolbar methodsFor: 'accessing'! browseModel ^ browseModel! ! !MethodToolbar methodsFor: 'accessing'! dropListModel ^ dropListModel! ! !MethodToolbar methodsFor: 'accessing'! implementorsModel ^ implementorsModel! ! !MethodToolbar methodsFor: 'accessing'! model ^ model! ! !MethodToolbar methodsFor: 'accessing'! sendersModel ^ sendersModel! ! !MethodToolbar methodsFor: 'accessing'! versionModel ^ versionModel! ! !MethodToolbar methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/12/2012 18:00'! initialize "Initialization code for MethodToolbar" methodHolder := nil asValueHolder. model := AbstractTool new. super initialize.! ! !MethodToolbar methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/12/2012 18:00'! initializeWidgets self instantiateModels: #( browseModel ButtonModel sendersModel ButtonModel implementorsModel ButtonModel versionModel ButtonModel dropListModel DropListModel ). self setFocusOrder; setBrowseModel; setVersionModel; setSendersModel; setImplementorsModel ! ! !MethodToolbar methodsFor: 'initialization'! 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'! setBrowseModel browseModel state: false; label: 'Browse'; action: [ self browseMethod ]. ! ! !MethodToolbar methodsFor: 'initialization'! setFocusOrder self focusOrder add: browseModel; add: sendersModel; add: implementorsModel; add: versionModel. ! ! !MethodToolbar methodsFor: 'initialization'! setImplementorsModel implementorsModel state: false; label: 'Implementors'; action: [ self implementorsMethod ]. ! ! !MethodToolbar methodsFor: 'initialization'! setSendersModel sendersModel state: false; label: 'Senders'; action: [ self sendersMethod ]. ! ! !MethodToolbar methodsFor: 'initialization'! setVersionModel versionModel state: false; label: 'Version'; action: [ self versionMethod ]. ! ! !MethodToolbar methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 2/8/2013 13:51'! method: aMethod methodHolder contents: aMethod! ! !MethodToolbar methodsFor: 'protocol'! setDropListItems: aCollection dropListModel items: aCollection! ! !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: 'private'! browseMethod methodHolder contents ifNotNil: [:aMethod | aMethod browse ]! ! !MethodToolbar methodsFor: 'private'! implementorsMethod methodHolder contents ifNotNil: [:aMethod | self model browseMessagesFrom: aMethod selector ]! ! !MethodToolbar methodsFor: 'private'! sendersMethod methodHolder contents ifNotNil: [:aMethod | self model browseSendersOfMessagesFrom: aMethod selector ]! ! !MethodToolbar methodsFor: 'private'! versionMethod methodHolder contents ifNotNil: [:aMethod | self model browseVersionsFrom: aMethod ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MethodToolbar class instanceVariableNames: ''! !MethodToolbar class methodsFor: 'specs' stamp: 'bvr 6/4/2012 14:50'! defaultSpec ^ { #Panel. #changeTableLayout. #listDirection:. #rightToLeft. #addMorph:. {#model. #browseModel.}. #addMorph:. {#model. #sendersModel.}. #addMorph:. {#model. #implementorsModel.}. #addMorph:. {#model. #versionModel. }. #addMorph:. {#model. #dropListModel.}. #hResizing:. #spaceFill. #vResizing:. #shrinkWrap. }! ! !MethodToolbar class methodsFor: 'specs'! title ^ 'Toolbar'! ! AbstractMethodWidget subclass: #MethodWidget instanceVariableNames: 'methodsList methodsSelection methods' classVariableNames: '' poolDictionaries: '' category: 'Nautilus-Widgets'! !MethodWidget commentStamp: '' prior: 0! MethodWidget is the basic implementation of a wiget managing methods! !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: 'protocol' stamp: 'SeanDeNigris 7/7/2012 21:03'! getMethods ^ methods ifNil: [ methods := self loadMethods ].! ! !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: 'BenjaminVanRyseghem 3/23/2012 18:57'! label: aString "methodsGroup label: aString"! ! !MethodWidget methodsFor: 'protocol'! methodsSelection ^ methodsSelection! ! !MethodWidget methodsFor: 'protocol'! removeAllFromMethodsIconsCache: aMethod self methodsIconsCache keys do: [:method | " for overrides " method selector = aMethod selector ifTrue: [ MethodsIconsCache removeKey: method ifAbsent: [ ]]].! ! !MethodWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/27/2012 23:02'! resetSelection self methodsSelection removeAll! ! !MethodWidget methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/14/2012 12:17'! updateList self update: #getMethodItem:! ! !MethodWidget methodsFor: 'protocol'! vScrollValue ^ methodsList scrollValue y! ! !MethodWidget methodsFor: 'protocol'! vScrollValue: aNumber ^ methodsList vScrollValue: aNumber! ! !MethodWidget methodsFor: 'selection'! 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: 'selection'! methodSelectionAt: anIndex put: aBoolean | element | element := self getMethods at: anIndex ifAbsent: [ ^ self ]. methodsSelection at: element put: aBoolean.! ! !MethodWidget methodsFor: 'selection'! resetMethodsListSelection methodsSelection removeAll! ! !MethodWidget methodsFor: 'selection'! selectedMethodIndex ^ self getMethods identityIndexOf: self selectedMethod ifAbsent: [ 0 ].! ! !MethodWidget methodsFor: 'selection'! selectedMethodIndex: anInteger | aMethod | aMethod := self getMethods at: anInteger ifAbsent: [ nil ]. self selectedMethod: aMethod. self changed: #selectedMethodIndex.! ! !MethodWidget methodsFor: 'selection'! selectedMethods | associations | associations := self methodsSelection associations select: [:assoc | assoc value == true ] thenCollect: [:assoc | assoc key ]. ^ associations reject: [:each | each isNil ]! ! !MethodWidget methodsFor: 'testing'! resetMethodCache methods := nil! ! !MethodWidget methodsFor: 'private'! deselectMethod: aMethod methodsSelection at: aMethod put: false! ! !MethodWidget methodsFor: 'private'! getMethodItem: anIndex ^ self getMethods at: anIndex! ! !MethodWidget methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/14/2012 13:10'! hasFocus ^ methodsList hasKeyboardFocus! ! !MethodWidget methodsFor: 'private'! initialize super initialize. methodsSelection := Dictionary new.! ! !MethodWidget methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/7/2012 14:34'! 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'! methodListSize ^ self getMethods size! ! !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'! methodsLabel ^ self showInstance ifTrue: ['Instance methods' asText ] ifFalse: ['Class methods' asText allBold ]! ! !MethodWidget methodsFor: 'private'! selectMethod: aMethod methodsSelection at: aMethod put: true! ! !MethodWidget methodsFor: 'private'! takeKeyboardFocus methodsList takeKeyboardFocus! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MethodWidget class instanceVariableNames: ''! !MethodWidget class methodsFor: 'menu' stamp: 'EstebanLorenzano 2/6/2013 15:28'! 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'] ifTrue: [ 'Remove breakpoint'] )]. 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: (target iconClass 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'.! ! AbstractMethodIconAction subclass: #MethodWithCorrespondingTestAction instanceVariableNames: 'testMethod' classVariableNames: '' poolDictionaries: '' category: 'Nautilus-Widgets'! !MethodWithCorrespondingTestAction commentStamp: '' prior: 0! Action when the method has a corresponding test method! !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! ! !MethodWithCorrespondingTestAction methodsFor: 'order' stamp: 'BenjaminVanRyseghem 1/2/2013 12:57'! privateActionIcon "Return the icon for this action" | testIcon | testIcon := self iconClass iconNamed: #testNotRun. testMethod hasPassedTest ifTrue: [ testIcon := self iconClass iconNamed: #testGreen ]. testMethod hasFailedTest ifTrue: [ testIcon := self iconClass iconNamed: #testYellow ]. testMethod hasErrorTest ifTrue: [ testIcon := self iconClass iconNamed: #testRed ]. ^ 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! ! Object subclass: #MimeConverter instanceVariableNames: 'dataStream mimeStream' classVariableNames: '' poolDictionaries: '' category: 'Network-MIME'! !MimeConverter commentStamp: 'LaurentLaffont 6/8/2011 22:18' prior: 0! 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:55'! dataStream ^dataStream! ! !MimeConverter methodsFor: 'accessing' stamp: 'tk 12/9/97 13:51'! dataStream: anObject dataStream := anObject! ! !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: '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 instanceVariableNames: ''! !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! ! !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! ! TestCase subclass: #MirrorPrimitiveTests instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CompilerTests'! !MirrorPrimitiveTests methodsFor: 'tests' stamp: 'MarcusDenker 8/20/2011 13:47'! testMirrorAt "self debug: #testMirrorAt" | stackpBefore stackpAfter array byteArray | stackpBefore := thisContext stackPtr. array := { 1. 2. 3 }. byteArray := ByteArray with: 1 with: 2 with: 3. self assert: (thisContext object: array basicAt: 1) = 1. self assert: (thisContext object: byteArray basicAt: 2) = 2. thisContext object: array basicAt: 2 put: #two. self assert: array = #(1 #two 3). thisContext object: byteArray basicAt: 2 put: 222. self assert: byteArray asArray = #(1 222 3). stackpAfter := thisContext stackPtr. self assert: stackpBefore = stackpAfter. "Make sure primitives pop all their arguments" self should: [thisContext object: array basicAt: 4] raise: Error. self should: [thisContext object: byteArray basicAt: 0] raise: Error. self should: [thisContext object: byteArray basicAt: 1 put: -1] raise: Error! ! !MirrorPrimitiveTests methodsFor: 'tests' stamp: 'MarcusDenker 8/20/2011 13:48'! testMirrorClass | stackpBefore stackpAfter | stackpBefore := thisContext stackPtr. self assert: (thisContext objectClass: Array new) = Array. self assert: (thisContext objectClass: 1) = 1 class. self assert: (thisContext objectClass: ProtoObject new) = ProtoObject. stackpAfter := thisContext stackPtr. self assert: stackpBefore = stackpAfter "Make sure primitives pop all their arguments"! ! !MirrorPrimitiveTests methodsFor: 'tests' stamp: 'MarcusDenker 8/20/2011 13:48'! testMirrorEqEq | stackpBefore stackpAfter | stackpBefore := thisContext stackPtr. self assert: (thisContext object: Array new eqeq: Array new) == false. self assert: (thisContext object: Array eqeq: Array) == true. stackpAfter := thisContext stackPtr. self assert: stackpBefore = stackpAfter "Make sure primitives pop all their arguments"! ! !MirrorPrimitiveTests methodsFor: 'tests' stamp: 'MarcusDenker 8/20/2011 13:48'! testMirrorInstVarAt | stackpBefore stackpAfter array point | stackpBefore := thisContext stackPtr. array := { 1. 2. 3 }. point := Point x: 1 y: 2. self assert: (thisContext object: array instVarAt: 1) = 1. self assert: (thisContext object: point instVarAt: 2) = 2. thisContext object: array instVarAt: 2 put: #two. self assert: array = #(1 #two 3). thisContext object: point instVarAt: 1 put: 1/2. self assert: point = (Point x: 1 / 2 y: 2). stackpAfter := thisContext stackPtr. self assert: stackpBefore = stackpAfter. "Make sure primitives pop all their arguments" self should: [thisContext object: array instVarAt: 4] raise: Error. self should: [thisContext object: point instVarAt: 3] raise: Error! ! !MirrorPrimitiveTests methodsFor: 'tests' stamp: 'MarcusDenker 8/20/2011 13:48'! testMirrorPerform | stackpBefore stackpAfter anInterval | stackpBefore := thisContext stackPtr. anInterval := 1 to: 2. self assert: (thisContext object: anInterval perform:# species withArguments: #() inClass: Interval) == Array. self assert: (thisContext object: anInterval perform:# species withArguments: #() inClass: Interval superclass) == Interval. self should: [thisContext object: anInterval perform:# species withArguments: #() inClass: Point] raise: Error. self should: [thisContext object: anInterval perform:# species withArguments: OrderedCollection new inClass: Interval] raise: Error. stackpAfter := thisContext stackPtr. self assert: stackpBefore = stackpAfter "Make sure primitives pop all their arguments"! ! !MirrorPrimitiveTests methodsFor: 'tests' stamp: 'md 5/1/2012 12:33'! testMirrorSize | stackpBefore stackpAfter | stackpBefore := thisContext stackPtr. self assert: (thisContext objectSize: #(1 2 3)) = 3. self assert: (thisContext objectSize: '123') = 3. self assert: (thisContext objectSize: nil) = 0. self assert: (thisContext objectSize: 1) = 0. stackpAfter := thisContext stackPtr. self assert: stackpBefore = stackpAfter. "Make sure primitives pop all their arguments"! ! Parser subclass: #MockCustomParser instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CompilerTests'! Exception subclass: #MockExceptionWithPassAction instanceVariableNames: 'passAction' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Weak'! !MockExceptionWithPassAction methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 5/23/2011 13:07'! pass ^ passAction cull: self! ! !MockExceptionWithPassAction methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 5/23/2011 13:07'! passAction: aValuable passAction := aValuable! ! Object subclass: #MockFinalizerAction instanceVariableNames: 'finAction' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Weak'! !MockFinalizerAction methodsFor: 'accessing' stamp: 'IgorStasenko 5/23/2011 13:16'! finAction: aValuable finAction := aValuable! ! !MockFinalizerAction methodsFor: 'accessing' stamp: 'IgorStasenko 5/23/2011 13:16'! finalize finAction value! ! !MockFinalizerAction methodsFor: 'accessing' stamp: 'IgorStasenko 5/23/2011 13:29'! finalizeValues finAction value! ! Object subclass: #MockForCompilation instanceVariableNames: 'var1' classVariableNames: '' poolDictionaries: '' category: 'CompilerTests'! Stream subclass: #MockSocketStream instanceVariableNames: 'atEnd inStream outStream' classVariableNames: '' poolDictionaries: '' category: 'NetworkTests-Kernel'! !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: '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 in' stamp: 'fbs 3/22/2004 13:10'! nextLine ^self nextLineCrLf! ! !MockSocketStream methodsFor: 'stream in' stamp: 'fbs 3/22/2004 13:09'! nextLineCrLf ^(self upToAll: String crlf).! ! !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: 'stream out' stamp: 'PeterHugossonMiller 9/3/2009 10:05'! resetOutStream outStream := String new writeStream.! ! !MockSocketStream methodsFor: 'stream out' stamp: 'fbs 3/22/2004 13:07'! sendCommand: aString self outStream nextPutAll: aString; nextPutAll: String crlf.! ! !MockSocketStream methodsFor: 'testing' stamp: 'fbs 3/22/2004 13:08'! atEnd ^self inStream atEnd.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MockSocketStream class instanceVariableNames: ''! !MockSocketStream class methodsFor: 'instance creation' stamp: 'fbs 3/22/2004 12:46'! on: socket ^self basicNew initialize! ! Object subclass: #MockSourceEditor instanceVariableNames: 'text selectionStart selectionEnd' classVariableNames: '' poolDictionaries: '' category: 'CompilerTests'! !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'! cut text := (text first: selectionStart-1), (text copyFrom: selectionEnd+1 to: text size). selectionStart := selectionStart - 1. selectionEnd := selectionStart! ! !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: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: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)! ! !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 13:25'! selection ^ self text copyFrom: selectionStart to: selectionEnd! ! !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 13:24'! selectionInterval ^ Interval from: selectionStart to: selectionEnd.! ! !MockSourceEditor methodsFor: 'as yet unclassified' stamp: 'PavelKrivanek 11/8/2012 13:43'! startIndex ^ selectionStart! ! !MockSourceEditor methodsFor: 'as yet unclassified' stamp: 'PavelKrivanek 11/8/2012 12:49'! text ^ text! ! Object subclass: #MockTranscript instanceVariableNames: 'stream' classVariableNames: '' poolDictionaries: '' category: 'CompilerTests'! !MockTranscript methodsFor: 'accessing' stamp: 'JorgeRessia 3/4/2010 21:19'! contents ^stream contents ! ! !MockTranscript methodsFor: 'initializing' stamp: 'JorgeRessia 3/4/2010 21:19'! initialize super initialize. stream := String new writeStream.! ! !MockTranscript methodsFor: 'streaming' stamp: 'JorgeRessia 3/4/2010 21:19'! cr stream cr! ! !MockTranscript methodsFor: 'streaming' stamp: 'JorgeRessia 3/4/2010 21:19'! show: anObject stream nextPutAll: anObject asString ! ! Object subclass: #Model instanceVariableNames: 'dependents' classVariableNames: '' poolDictionaries: '' category: 'System-Support'! !Model commentStamp: '' prior: 0! 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: '*Polymorph-Widgets' stamp: 'MarcusDenker 4/14/2011 11:30'! theme ^ UITheme current ! ! !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: '*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-edits' stamp: 'sma 2/29/2000 19:26'! canDiscardEdits "Answer true if none of the views on this model has unaccepted edits that matter." dependents ifNil: [^ true]. ^ super canDiscardEdits ! ! !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: '*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: '*UI-Basic-menus' stamp: 'StephaneDucasse 3/18/2010 21:23'! initialExtent ^ RealEstateAgent standardWindowExtent! ! !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: '*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 "What should be displayed if a trash pane is restored to initial state" ^ ''! ! !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: 'copying'! 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: 'sma 2/29/2000 19:54'! myDependents ^ dependents! ! !Model methodsFor: 'dependents' stamp: 'sma 2/29/2000 19:54'! myDependents: aCollectionOrNil dependents := aCollectionOrNil! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Model class instanceVariableNames: ''! !Model class methodsFor: '*UI-Basic-window color'! patchworkUIThemeColor "Answer a default color for UI themes that make use of different colors for Browser, MessageList etc..." ^ Color gray whiter whiter lighter! ! DialogWindow subclass: #ModelDependentDialogWindow instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Windows'! !ModelDependentDialogWindow commentStamp: 'gvc 5/18/2007 12:44' prior: 0! DialogWindow that updates content based upon its model.! !ModelDependentDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 9/15/2006 15:27'! addInitialPanel "Don't until the model is set."! ! !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! ! RawSpec subclass: #ModelSpec instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Spec-Core-Specs'! !ModelSpec commentStamp: '' prior: 0! A ModelSpec is a spec to describe a call to model! !ModelSpec methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2012 11:04'! model: aModel self instance: aModel ! ! !ModelSpec methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 10/17/2012 11:27'! removeSubWidgets "^ SpecInterpreter interpretASpec: #(model removeSubWidgets) model: self instance"! ! AbstractNautilusPlugin subclass: #MondrianPlugin instanceVariableNames: 'subMorphs' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Plugin'! !MondrianPlugin commentStamp: '' prior: 0! 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 instanceVariableNames: ''! !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'! ! Object subclass: #Monitor instanceVariableNames: 'mutex ownerProcess nestingLevel defaultQueue queueDict queuesMutex' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Processes'! !Monitor commentStamp: 'md 3/3/2006 09:19' prior: 0! 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: 'accessing' stamp: 'NS 7/1/2002 20:02'! cleanup self checkOwnerProcess. self critical: [self privateCleanup].! ! !Monitor methodsFor: 'initialize-release' stamp: 'alain.plantec 5/28/2009 10:08'! initialize super initialize. mutex := Semaphore forMutualExclusion. queuesMutex := Semaphore forMutualExclusion. nestingLevel := 0.! ! !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-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 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: '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: '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: '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-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: '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-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-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: '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: '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: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: '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: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: '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-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: '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: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: '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: '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: '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: '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-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: 'private' stamp: 'NS 4/13/2004 13:40'! checkOwnerProcess self isOwnerProcess ifFalse: [self error: 'Monitor access violation'].! ! !Monitor methodsFor: 'private' stamp: 'NS 7/1/2002 15:06'! defaultQueue defaultQueue ifNil: [defaultQueue := OrderedCollection new]. ^ defaultQueue! ! !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. ].! ! !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: 'nice 1/5/2010 20:52'! exitAndWaitInQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil | lock delay | lock := queuesMutex critical: [anOrderedCollection addLast: Semaphore new]. self exit. anIntegerOrNil isNil ifTrue: [ lock wait ] ifFalse: [ delay := MonitorDelay signalLock: lock afterMSecs: anIntegerOrNil inMonitor: self queue: anOrderedCollection. lock wait. delay unschedule. ]. self enter.! ! !Monitor methodsFor: 'private' stamp: 'NS 7/1/2002 15:42'! isOwnerProcess ^ Processor activeProcess == ownerProcess! ! !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: 'private' stamp: 'StephaneDucasse 10/19/2010 14:01'! queueDict ^ queueDict ifNil: [queueDict := IdentityDictionary new]. ! ! !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: 'StephaneDucasse 10/19/2010 14:05'! signalAllInQueue: anOrderedCollection queuesMutex critical: [ anOrderedCollection removeAllSuchThat: [ :each | each signal. true ] ]! ! !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: 'StephaneDucasse 10/19/2010 14:03'! signalQueue: anOrderedCollection queuesMutex critical: [ anOrderedCollection isEmpty ifFalse: [ anOrderedCollection removeFirst signal ] ]! ! !Monitor methodsFor: 'private' stamp: 'NS 7/1/2002 13:17'! waitInQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil self exitAndWaitInQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil.! ! !Monitor methodsFor: 'private' stamp: 'NS 7/1/2002 13:17'! waitWhile: aBlock inQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil [aBlock value] whileTrue: [self exitAndWaitInQueue: anOrderedCollection maxMilliseconds: anIntegerOrNil].! ! Delay subclass: #MonitorDelay instanceVariableNames: 'monitor queue' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Processes'! !MonitorDelay commentStamp: 'NS 4/13/2004 16:51' prior: 0! 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 instanceVariableNames: ''! !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! ! TestCase subclass: #MonitorTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Processes'! !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 ! ! Timespan subclass: #Month instanceVariableNames: '' classVariableNames: '' poolDictionaries: 'ChronologyConstants' category: 'Kernel-Chronology'! !Month commentStamp: 'brp 5/13/2003 09:48' prior: 0! I represent a month.! !Month methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:04'! asMonth ^ self ! ! !Month methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:05'! daysInMonth ^ self duration days.! ! !Month methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:05'! index ^ self monthIndex ! ! !Month methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:05'! name ^ self monthName ! ! !Month methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:05'! previous ^ self class starting: (self start - 1) ! ! !Month methodsFor: 'squeak protocol' stamp: 'brp 5/13/2003 09:05'! printOn: aStream aStream nextPutAll: self monthName, ' ', self year printString.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Month class instanceVariableNames: ''! !Month class methodsFor: 'smalltalk-80' 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: 'smalltalk-80' 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: 'smalltalk-80' stamp: 'brp 5/13/2003 09:02'! nameOfMonth: anIndex ^ MonthNames at: anIndex.! ! !Month class methodsFor: 'squeak protocol' stamp: 'brp 7/27/2003 16:22'! month: month year: year "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: 'squeak protocol' stamp: 'simondenier 11/30/2009 22:50'! 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 month: (Month indexOfMonth: m contents) year: y contents asNumber "Month readFrom: 'July 1998' readStream" ! ! !Month class methodsFor: 'squeak protocol' stamp: 'brp 7/1/2003 13:59'! 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)! ! ClassTestCase subclass: #MonthTest instanceVariableNames: 'month' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Chronology'! !MonthTest commentStamp: 'brp 7/26/2003 22:44' prior: 0! This is the unit test for the class Month. ! !MonthTest methodsFor: 'Coverage' stamp: 'brp 7/27/2003 12:42'! classToBeTested ^ Month! ! !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'! setUp super setUp. month := Month month: 7 year: 1998.! ! !MonthTest methodsFor: 'Running' stamp: 'brp 8/6/2003 19:37'! tearDown super tearDown. month := nil.! ! !MonthTest methodsFor: 'Tests' stamp: 'brp 7/26/2003 22:52'! testConverting self assert: month asDate = '1 July 1998' asDate! ! !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: '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 8/23/2003 16:08'! testInquiries self assert: month index = 7; assert: month name = #July; assert: month duration = (31 days). ! ! !MonthTest methodsFor: 'Tests' stamp: 'nk 7/30/2004 17:52'! testInstanceCreation | m1 m2 | m1 := Month starting: '4 July 1998' asDate. m2 := Month month: #July year: 1998. self assert: month = m1; assert: month = m2! ! !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.! ! !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: 'brp 7/26/2003 22:46'! testReadFrom | m | m := Month readFrom: 'July 1998' readStream. self assert: m = month! ! ComposableModel subclass: #MonticelloRepositoryBrowser instanceVariableNames: 'repositories workingCopies order' classVariableNames: 'Order' poolDictionaries: '' category: 'Spec-Tools-Monticello'! !MonticelloRepositoryBrowser commentStamp: '' prior: 0! MonticelloRepositoryBrowser example! !MonticelloRepositoryBrowser methodsFor: 'accessing' stamp: 'StephaneDucasse 6/2/2012 20:29'! allManagers ^ self class allManagers ! ! !MonticelloRepositoryBrowser methodsFor: 'accessing' stamp: 'StephaneDucasse 4/17/2012 18:04'! repositories ^ repositories! ! !MonticelloRepositoryBrowser methodsFor: 'accessing' stamp: 'StephaneDucasse 4/17/2012 18:04'! workingCopies ^ workingCopies! ! !MonticelloRepositoryBrowser methodsFor: 'accessing' stamp: 'StephaneDucasse 4/19/2012 18:20'! workingCopy ^ workingCopies selectedItem! ! !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: '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: 'actions' stamp: 'StephaneDucasse 4/19/2012 18:19'! openRepository self repository ifNotNil: [:repos | repos morphicOpen: self workingCopy ]! ! !MonticelloRepositoryBrowser methodsFor: 'initialize' stamp: 'StephaneDucasse 4/17/2012 18:06'! initialExtent ^ 600@200! ! !MonticelloRepositoryBrowser methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 6/12/2012 18:41'! initialize "Initialization code for MonticelloRepositoryBrowser" super initialize. order := self class order! ! !MonticelloRepositoryBrowser methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 6/12/2012 18:41'! initializePresenter workingCopies whenSelectedItemChanged: [ :item | repositories items: (self repositoriesOfWorkingCopy: item) ].! ! !MonticelloRepositoryBrowser methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 6/12/2012 18:41'! initializeWidgets self instantiateModels: #( repositories ListComposableModel workingCopies ListComposableModel). 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: 'menu' stamp: 'StephaneDucasse 4/17/2012 18:49'! order ^ order! ! !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: '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: '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: '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: '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: 'protocol' stamp: 'SD 4/19/2012 16:12'! workingCopies: aCollection "Set the value of the list widget" workingCopies items: aCollection ! ! !MonticelloRepositoryBrowser methodsFor: 'private' stamp: 'StephaneDucasse 4/17/2012 18:31'! allRepositories ^ MCRepositoryGroup default repositories! ! !MonticelloRepositoryBrowser methodsFor: 'private' stamp: 'StephaneDucasse 4/17/2012 19:11'! defaultOrderingBlock ^ (self orderSpecs at: self class order) value! ! !MonticelloRepositoryBrowser methodsFor: 'private' stamp: 'StephaneDucasse 4/17/2012 18:20'! repositoriesOfWorkingCopy: aWorkingCopy ^ aWorkingCopy isNil ifFalse: [ aWorkingCopy repositoryGroup repositories] ifTrue: [ self allRepositories] ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MonticelloRepositoryBrowser class instanceVariableNames: ''! !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'! ! !MonticelloRepositoryBrowser class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/15/2013 14:17'! defaultSpec ^ { #ComposableSpec. #add: . {{#model . #workingCopies} . #layout: . #(FrameLayout rightFraction: 0.5)} . #add: . {{#model . #repositories } . #layout: . #(FrameLayout leftFraction: 0.5)} }! ! !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: 'utils' stamp: 'StephaneDucasse 4/17/2012 18:42'! order: anInteger Order := anInteger! ! Object subclass: #Morph instanceVariableNames: 'bounds owner submorphs fullBounds color extension' classVariableNames: 'CmdGesturesEnabled CycleHalosBothDirections DefaultYellowButtonMenuEnabled EmptyArray HalosEnabled' poolDictionaries: '' category: 'Morphic-Kernel'! !Morph commentStamp: 'efc 2/26/2003 20:01' prior: 0! 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: '*Keymapping-Core' stamp: 'GuillermoPolito 5/31/2011 11:19'! allowsKeymapping ^ true! ! !Morph methodsFor: '*Keymapping-Core' stamp: 'GuillermoPolito 10/20/2011 17:44'! attachKeymapCategory: aCategoryName self kmDispatcher attachCategory: aCategoryName.! ! !Morph methodsFor: '*Keymapping-Core' stamp: 'GuillermoPolito 10/20/2011 23:33'! attachKeymapCategory: aCategoryName onProperty: aProperty self kmDispatcher attachCategory: aCategoryName onProperty: aProperty! ! !Morph methodsFor: '*Keymapping-Core' stamp: 'GuillermoPolito 10/20/2011 18:09'! attachKeymapCategory: aCategoryName targetting: anObject self kmDispatcher attachCategory: aCategoryName targetting: anObject! ! !Morph methodsFor: '*Keymapping-Core' stamp: 'BenjaminVanRyseghem 2/20/2012 19:35'! detachAllKeymapCategories self kmDispatcher detachAllKeymapCategories! ! !Morph methodsFor: '*Keymapping-Core' stamp: 'BenjaminVanRyseghem 2/20/2012 19:23'! detachKeymapCategory: aCategoryName self kmDispatcher detachKeymapCategory: aCategoryName.! ! !Morph methodsFor: '*Keymapping-Core' stamp: 'BenjaminVanRyseghem 2/20/2012 19:23'! detachKeymapCategory: aCategoryName targetting: anObject self kmDispatcher detachKeymapCategory: aCategoryName targetting: anObject! ! !Morph methodsFor: '*Keymapping-Core' stamp: 'GuillermoPolito 3/14/2011 00:03'! dispatchKeystrokeForEvent: evt self kmDispatcher dispatchKeystroke: evt ! ! !Morph methodsFor: '*Keymapping-Core' stamp: 'SeanDeNigris 7/9/2012 23:40'! hasKeymapCategoryNamed: aString ^ self kmDispatcher targets anySatisfy: [ :e | e category name = aString ].! ! !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: '*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: '*Keymapping-Core' stamp: 'GuillermoPolito 9/12/2011 16:39'! on: aShortcut do: anAction self kmDispatcher on: aShortcut asShortcut do: anAction! ! !Morph methodsFor: '*Keymapping-Core-override' stamp: 'BenjaminVanRyseghem 4/27/2012 11:15'! handleKeystroke: anEvent "System level event handling." anEvent wasHandled ifTrue: [^ self]. self allowsKeymapping ifTrue: [ self dispatchKeystrokeForEvent: anEvent. 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: '*Morphic-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: '*Morphic-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: '*Morphic-Widgets' stamp: 'BenjaminVanRyseghem 7/25/2012 11:42'! heightToDisplayInList: aList ^ self minExtent y! ! !Morph methodsFor: '*Morphic-Widgets' stamp: 'BenjaminVanRyseghem 2/21/2013 23:19'! listRenderOn: aCanvas atRow: aRow bounds: drawBounds color: drawColor backgroundColor: backgroundColor from: aMorph self bounds: drawBounds. self fullDrawOn: aCanvas. aMorph addMorph: self! ! !Morph methodsFor: '*Morphic-Widgets' stamp: 'BenjaminVanRyseghem 2/12/2012 00:22'! widthToDisplayInList: aList ^ self minExtent x! ! !Morph methodsFor: '*Morphic-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: '*Morphic-Worlds' stamp: 'sw 7/1/1998 18:02'! pasteUpMorph "Answer the closest containing morph that is a PasteUp morph" ^ self ownerThatIsA: PasteUpMorph! ! !Morph methodsFor: '*Morphic-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: '*Morphic-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: '*Morphic-Worlds' stamp: 'dgd 9/27/2004 11:45'! viewBox ^ self pasteUpMorph viewBox! ! !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: '*Polymorph-Widgets' stamp: 'gvc 10/18/2006 11:58'! adoptPaneColor "Adopt our pane color." self adoptPaneColor: self paneColor! ! !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: '*Polymorph-Widgets' stamp: 'gvc 4/20/2009 18:42'! boundsWithinCorners "Changed to be more realistic..." ^self bounds insetBy: 2! ! !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: '*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: '*Polymorph-Widgets' stamp: 'gvc 1/10/2007 13:40'! dialogWindow "Answer the receiver's dialog window." ^self ownerThatIsA: DialogWindow! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/5/2007 12:55'! drawKeyboardFocusOn: aCanvas "Draw the keyboard focus indication." self focusIndicatorMorph drawOn: aCanvas! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/11/2007 12:21'! enabled "Answer whether the receiver is enabled." ^true! ! !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: '*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: '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: '*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/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: '*Polymorph-Widgets' stamp: 'gvc 9/6/2007 15:35'! focusIndicatorMorph "Answer the focus indicator morph for the receiver." ^self theme focusIndicatorMorphFor: self! ! !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: '*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: '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: '*Polymorph-Widgets' stamp: 'gvc 1/25/2008 17:34'! handlesMouseWheel: evt "Do I want to receive mouseWheel events?." ^false! ! !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: '*Polymorph-Widgets' stamp: 'BenjaminVanRyseghem 6/24/2012 23:27'! heightToDisplayInTree: aTree ^ self minExtent y! ! !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 10/9/2007 10:36'! isTaskbar "Answer false in the general case." ^false! ! !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: '*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: '*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: '*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: '*Polymorph-Widgets' stamp: 'GaryChambers 12/2/2011 11:45'! 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 isNil ifTrue: [minExtent := 0 @ 0] ifFalse: [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: '*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: '*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: '*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: '*Polymorph-Widgets' stamp: 'gvc 1/25/2008 17:35'! mouseWheel: evt "Handle a mouseWheel event."! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/7/2006 15:53'! myDependents "Improved performance dependents." ^(self valueOfProperty: #myDependents) ifNil: [super myDependents]! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 9/7/2006 15:55'! myDependents: aCollectionOrNil "Improved performance dependents." aCollectionOrNil isNil ifTrue: [self removeProperty: #myDependents] ifFalse: [self setProperty: #myDependents toValue: aCollectionOrNil]! ! !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: '*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: '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: '*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: '*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: '*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: '*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: '*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: '*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: '*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: '*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: '*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: '*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: '*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 4/13/2007 15:25'! preferredCornerStyle "Answer the preferred corner style." ^#square! ! !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: '*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: '*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: '*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/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: '*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: '*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: '*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: '*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: '*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 1/11/2007 12:27'! takesKeyboardFocus "Answer whether the receiver can normally take keyboard focus." ^ false! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/20/2007 11:30'! 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 image: f! ! !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: '*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: '*Polymorph-Widgets' stamp: 'gvc 6/11/2007 15:04'! taskbarThumbnail "Answer a new taskbar thumbnail for the receiver." ^self taskThumbnailOfSize: self taskbarThumbnailExtent! ! !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: '*Polymorph-Widgets' stamp: 'gvc 10/9/2007 10:36'! taskbars "Answer the receiver's taskbars." ^self submorphs select: [:each | each isTaskbar]! ! !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: '*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: '*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: '*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: '*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: '*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 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 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: '*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: '*Polymorph-Widgets' stamp: 'BenjaminVanRyseghem 6/24/2012 23:27'! widthToDisplayInTree: aTree ^ self minExtent x! ! !Morph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/10/2007 10:07'! window "Answer the receiver's window." ^self ownerThatIsA: SystemWindow! ! !Morph methodsFor: '*SUnit-UITesting' stamp: 'SeanDeNigris 12/1/2011 22:08'! simulateClick self simulateClickWith: MouseEvent redButton.! ! !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: '*SUnit-UITesting' stamp: 'SeanDeNigris 12/9/2011 13:56'! simulateMiddleClick self simulateClickWith: MouseEvent blueButton.! ! !Morph methodsFor: '*SUnit-UITesting' stamp: 'SeanDeNigris 12/1/2011 22:08'! simulateRightClick self simulateClickWith: MouseEvent yellowButton.! ! !Morph methodsFor: '*Spec-Core'! addMorphWrapper: aMorphWrapper aMorphWrapper addIn: self.! ! !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: '*Tools-ViewHierarchyExplorer' stamp: 'IgorStasenko 1/22/2012 14:45'! exploreViewHierarchy ^Smalltalk tools viewHierarchyExplorer openOn: self! ! !Morph methodsFor: 'accessing' stamp: 'ar 12/18/2001 20:09'! adoptPaneColor: paneColor self submorphsDo:[:m| m adoptPaneColor: paneColor].! ! !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: 'accessing' stamp: 'dgd 2/16/2003 21:57'! beSticky "make the receiver sticky" self assureExtension sticky: true! ! !Morph methodsFor: 'accessing' stamp: 'sw 10/23/1998 12:01'! beTransparent self color: Color transparent! ! !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: 'accessing' stamp: 'ar 8/25/2001 18:28'! borderColor ^self borderStyle color! ! !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: 'accessing' stamp: 'gvc 9/11/2009 17:09'! borderStyle extension ifNil: [^BorderStyle default trackColorFrom: self]. ^(extension borderStyle ifNil: [BorderStyle default]) trackColorFrom: self! ! !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: '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: 'accessing' stamp: 'ar 8/25/2001 18:28'! borderWidth ^self borderStyle width! ! !Morph methodsFor: 'accessing' stamp: 'di 2/6/2001 14:02'! borderWidthForRounding ^ self borderWidth! ! !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: 'accessing' stamp: 'tk 2/15/2001 15:55'! color ^ color "has already been set to ((self valueOfProperty: #fillStyle) asColor)"! ! !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: '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: 'accessing' stamp: 'ar 12/27/2001 17:56'! couldHaveRoundedCorners ^ true! ! !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: 'accessing' stamp: 'md 2/27/2006 09:53'! eventHandler "answer the receiver's eventHandler" ^ extension ifNotNil: [extension eventHandler] ! ! !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: 'accessing' stamp: 'usmanbhatti 3/6/2012 19:23'! halosEnabled ^ self class halosEnabled! ! !Morph methodsFor: 'accessing' stamp: 'di 1/3/1999 12:25'! hasTranslucentColor "Answer true if this any of this morph is translucent but not transparent." ^ color isColor and: [color isTranslucentColor] ! ! !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: 'accessing' stamp: 'sw 3/6/1999 02:09'! highlightColor | val | ^ (val := self valueOfProperty: #highlightColor) ifNotNil: [val ifNil: [self error: 'nil highlightColor']] ifNil: [owner ifNil: [self color] ifNotNil: [owner highlightColor]]! ! !Morph methodsFor: 'accessing' stamp: 'sw 7/2/1998 13:51'! highlightColor: aColor self setProperty: #highlightColor toValue: aColor! ! !Morph methodsFor: 'accessing' stamp: 'tk 1/31/2002 10:25'! insetColor owner ifNil:[^self color]. ^ self colorForInsets! ! !Morph methodsFor: 'accessing' stamp: 'md 2/27/2006 09:53'! isLocked "answer whether the receiver is Locked" extension ifNil: [^ false]. ^ extension locked! ! !Morph methodsFor: 'accessing' stamp: 'md 2/27/2006 09:57'! isSticky "answer whether the receiver is Sticky" extension ifNil: [^ false]. ^ extension sticky! ! !Morph methodsFor: 'accessing' stamp: 'sw 8/4/97 12:05'! lock self lock: true! ! !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: 'sw 10/23/1999 22:35'! modelOrNil ^ nil! ! !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: 'accessing' stamp: 'sw 11/15/2001 16:33'! resistsRemoval "Answer whether the receiver is marked as resisting removal" ^ self hasProperty: #resistsRemoval! ! !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: 'accessing' stamp: 'nk 9/4/2004 10:49'! scaleFactor ^self valueOfProperty: #scaleFactor ifAbsent: [ 1.0 ] ! ! !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: '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: 'accessing' stamp: 'md 2/27/2006 08:33'! sticky: aBoolean "change the receiver's sticky property" extension sticky: aBoolean! ! !Morph methodsFor: 'accessing' stamp: 'RAA 2/19/2001 17:38'! toggleLocked self lock: self isLocked not! ! !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: '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: 'accessing' stamp: 'di 8/11/1998 12:33'! unlock self lock: false! ! !Morph methodsFor: 'accessing' stamp: 'sw 8/15/97 23:59'! unlockContents self submorphsDo: [:m | m unlock]! ! !Morph methodsFor: 'accessing' stamp: 'tk 12/16/1998 11:54'! userString "Do I have a text string to be searched on?" ^ nil! ! !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: 'accessing' stamp: 'ar 6/23/2001 16:06'! 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 hasTranslucentColor ifTrue:[^false]. self submorphsDo:[:m| m wantsToBeCachedByHand ifFalse:[^false]. ]. ^true! ! !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: '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: 'accessing - extension' stamp: 'dgd 2/16/2003 19:22'! extension "answer the recevier's extension" ^ extension! ! !Morph methodsFor: 'accessing - extension' stamp: 'md 2/27/2006 08:31'! hasExtension "answer whether the receiver has extention" ^ extension notNil! ! !Morph methodsFor: 'accessing - extension' stamp: 'md 2/27/2006 08:35'! initializeExtension "private - initializes the receiver's extension" extension := MorphExtension new! ! !Morph methodsFor: 'accessing - extension' stamp: 'md 2/27/2006 08:46'! privateExtension: aMorphExtension "private - change the receiver's extension" extension := aMorphExtension! ! !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: '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 - properties' stamp: 'md 2/27/2006 09:47'! otherProperties "answer the receiver's otherProperties" ^ extension ifNotNil: [extension otherProperties]! ! !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: '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: '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: '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: '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: '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: '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: '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: 'announcements' stamp: 'GuillermoPolito 5/3/2012 20:54'! announceDeleted self announcer announce: (MorphDeleted morph: self). self submorphs do: #announceDeleted! ! !Morph methodsFor: 'announcements' stamp: 'CamilloBruni 10/10/2012 13:32'! announceKeyboardFocusChange: gotFocus | announcement | announcement := gotFocus ifTrue: [ MorphGotFocus morph: self ] ifFalse: [ MorphLostFocus morph: self ]. self announcer announce: announcement.! ! !Morph methodsFor: 'announcements' stamp: 'GuillermoPolito 5/1/2012 20:01'! announceOpened self announcer announce: (MorphOpened morph: self). self submorphs do: #announceOpened! ! !Morph methodsFor: 'announcements' stamp: 'GuillermoPolito 5/1/2012 17:01'! announcer ^self valueOfProperty: #announcer ifAbsentPut: [ Announcer new ]! ! !Morph methodsFor: 'announcements' stamp: 'GuillermoPolito 5/1/2012 19:50'! onAnnouncement: anAnnouncement do: aValuable self announcer on: anAnnouncement do: aValuable.! ! !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: '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: '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: '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: '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: '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: 'change reporting' stamp: 'ar 8/12/2003 21:50'! addedMorph: aMorph "Notify the receiver that the given morph was just added." ! ! !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: 'change reporting' stamp: 'ar 11/12/2000 18:50'! invalidRect: damageRect ^self invalidRect: damageRect from: self! ! !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: '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: '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: 'classification' stamp: 'di 5/7/1998 01:21'! isAlignmentMorph ^ false! ! !Morph methodsFor: 'classification' stamp: 'jm 4/17/1998 00:44'! isFlexMorph ^ false ! ! !Morph methodsFor: 'classification'! isHandMorph ^ false! ! !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: 'classification' stamp: 'ar 12/16/2001 18:28'! isTextMorph ^false! ! !Morph methodsFor: 'classification'! isWorldMorph ^ false! ! !Morph methodsFor: 'classification'! isWorldOrHandMorph ^ self isWorldMorph or: [self isHandMorph]! ! !Morph methodsFor: 'converting'! asDraggableMorph ^self! ! !Morph methodsFor: 'copying' stamp: 'tk 2/19/2001 18:21'! copy ^ self veryDeepCopy! ! !Morph methodsFor: 'copying' stamp: 'tk 2/14/2001 12:47'! deepCopy self error: 'Please use veryDeepCopy'. ! ! !Morph methodsFor: 'copying' stamp: 'MarcusDenker 10/28/2010 14:02'! duplicate "Make and return a duplicate of the receiver" | newMorph w topRend | ((topRend := self topRendererOrSelf) ~~ self) ifTrue: [^ topRend duplicate]. newMorph := self veryDeepCopy. newMorph arrangeToStartStepping. newMorph privateOwner: nil. "no longer in world" ^newMorph! ! !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: '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: '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: '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: 'creation' stamp: 'tk 2/6/1999 22:43'! asMorph ^ self! ! !Morph methodsFor: 'debug and other' stamp: 'AlainPlantec 11/5/2011 16:09'! addDebuggingItemsTo: aMenu hand: aHandMorph aMenu add: 'debug...' translated subMenu: (self buildDebugMenu: aHandMorph). aMenu lastItem icon: self theme smallDebugIcon! ! !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: '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: '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: '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: 'debug and other' stamp: 'BenjaminVanRyseghem 7/25/2012 11:35'! 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: self theme smallInspectItIcon. aMenu add: 'inspect owner chain' translated action: #inspectOwnerChain. aMenu lastItem icon: self theme smallInspectItIcon. self isMorphicModel ifTrue: [ aMenu add: 'inspect model' translated target: self model action: #inspect. aMenu lastItem icon: self theme smallInspectItIcon. (self model class inheritsFrom: ComposableModel) ifTrue: [ aMenu add: 'edit model' translated target: self model action: #edit. aMenu lastItem icon: self theme smallInspectItIcon ]]. aMenu add: 'explore morph' translated target: self selector: #explore. aMenu lastItem icon: self theme 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 add: 'explore view hierarchy' translated target: self selector: #exploreViewHierarchy. ^ aMenu! ! !Morph methodsFor: 'debug and other' stamp: 'CamilloBruni 5/29/2012 17:17'! debugDrawError (self valueOfProperty: #drawError) debug.! ! !Morph methodsFor: 'debug and other' stamp: 'RAA 1/19/2001 07:51'! deleteAnyMouseActionIndicators self changed. (self valueOfProperty: #mouseActionIndicatorMorphs ifAbsent: [#()]) do: [ :each | each deleteWithSiblings "one is probably enough, but be safe" ]. self removeProperty: #mouseActionIndicatorMorphs. self hasRolloverBorder: false. self removeProperty: #rolloverWidth. self removeProperty: #rolloverColor. self layoutChanged. self changed. ! ! !Morph methodsFor: 'debug and other' stamp: 'sw 11/5/1998 20:31'! inspectOwnerChain self ownerChain inspectWithLabel: 'Owner chain for ', self printString! ! !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: '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: '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: '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: 'debug and other' stamp: 'RAA 7/12/2000 11:10'! programmedMouseLeave: anEvent for: aMorph self deleteAnyMouseActionIndicators. ! ! !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: '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: 'debug and other' stamp: 'CamilloBruni 5/29/2012 16:51'! resumeAfterDrawError self changed. self removeProperty:#errorOnDraw. self removeProperty:#drawError. self changed.! ! !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: '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: '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: 'drawing' stamp: 'ar 11/4/2000 23:39'! changeClipSubmorphs self clipSubmorphs: self clipSubmorphs not.! ! !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: '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: '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: '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: '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: 'tk 8/2/1998 14:33'! doesOwnRotation "Some morphs don't want to TransformMorph to rotate their images, but we do" ^ false! ! !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: '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: '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: 'drawing' stamp: ' 9/3/2000 13:55'! drawMouseDownHighlightOn: aCanvas self highlightedForMouseDown ifTrue: [ aCanvas frameRectangle: self fullBounds color: self color darker darker].! ! !Morph methodsFor: 'drawing' stamp: 'IgorStasenko 7/18/2011 17:48'! drawOn: aCanvas aCanvas fillRectangle: self bounds fillStyle: self fillStyle borderStyle: self borderStyle! ! !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: '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: 'drawing' stamp: 'ar 11/8/2000 19:29'! expandFullBoundsForRolloverBorder: aRectangle | delta | delta := self valueOfProperty: #rolloverWidth ifAbsent: [10@10]. ^aRectangle expandBy: delta. ! ! !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: '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: '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: 'sw 10/30/1998 18:27'! hide owner ifNil: [^ self]. self visible ifTrue: [self visible: false. self changed]! ! !Morph methodsFor: 'drawing' stamp: 'LC 5/18/2000 08:48'! highlightedForMouseDown ^(self valueOfProperty: #highlightedForMouseDown) == true! ! !Morph methodsFor: 'drawing' stamp: 'LC 5/18/2000 08:51'! highlightForMouseDown self highlightForMouseDown: true! ! !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: 'drawing' stamp: 'jm 6/11/97 17:21'! imageForm ^ self imageFormForRectangle: self fullBounds ! ! !Morph methodsFor: 'drawing' stamp: 'di 7/8/1998 12:42'! imageFormDepth: depth ^ self imageForm: depth forRectangle: self fullBounds ! ! !Morph methodsFor: 'drawing' stamp: 'di 9/9/1998 22:25'! imageFormForRectangle: rect ^ self imageForm: Display depth forRectangle: rect ! ! !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: '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: 'drawing' stamp: 'sw 10/10/1999 23:25'! refreshWorld | aWorld | (aWorld := self world) ifNotNil: [aWorld displayWorldSafely] ! ! !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: 'drawing' stamp: 'sw 10/22/1998 20:29'! show "Make sure this morph is on-stage." self visible ifFalse: [self visible: true. self changed]! ! !Morph methodsFor: 'drawing' stamp: 'md 2/27/2006 08:49'! visible "answer whether the receiver is visible" extension ifNil: [^ true]. ^ extension visible! ! !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: '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: '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: 'drop shadows' stamp: 'dgd 2/16/2003 21:42'! hasDropShadow "answer whether the receiver has DropShadow" ^ self valueOfProperty: #hasDropShadow ifAbsent: [false]! ! !Morph methodsFor: 'drop shadows' stamp: 'StephaneDucasse 4/22/2012 16:51'! hasDropShadowString ^ (self hasDropShadow) -> 'show shadow' translated! ! !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: 'drop shadows' stamp: 'dgd 2/16/2003 21:58'! hasRolloverBorder "answer whether the receiver has RolloverBorder" ^ self valueOfProperty: #hasRolloverBorder ifAbsent: [false]! ! !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: '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: '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: 'drop shadows' stamp: 'ar 10/26/2000 18:59'! shadowColor ^self valueOfProperty: #shadowColor ifAbsent:[Color black]! ! !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: '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: 'drop shadows' stamp: 'ar 10/26/2000 19:00'! shadowOffset: aPoint "Set the current shadow offset" (aPoint isNil or:[(aPoint x isZero) & (aPoint y isZero)]) ifTrue:[self removeProperty: #shadowOffset] ifFalse:[self setProperty: #shadowOffset toValue: aPoint].! ! !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: 'drop shadows' stamp: 'ar 10/26/2000 20:16'! toggleDropShadow self hasDropShadow ifTrue:[self removeDropShadow] ifFalse:[self addDropShadow].! ! !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: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:41'! disableDragNDrop self enableDragNDrop: false! ! !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: 'dropping/grabbing' stamp: 'ar 10/11/2000 18:18'! dragEnabled: aBool ^self enableDrag: aBool! ! !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: 'dropping/grabbing' stamp: 'panda 4/25/2000 18:36'! dragSelectionColor ^ Color magenta! ! !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: 'dropping/grabbing' stamp: 'ar 10/11/2000 18:18'! dropEnabled: aBool ^self enableDrop: aBool! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/28/2000 10:52'! dropHighlightColor ^ Color blue! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:41'! enableDragNDrop self enableDragNDrop: true! ! !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: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:50'! enableDrag: aBoolean self setProperty: #dragEnabled toValue: aBoolean! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/25/2000 15:51'! enableDrop: aBoolean self setProperty: #dropEnabled toValue: aBoolean! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'ar 10/5/2000 18:13'! formerOwner ^self valueOfProperty: #formerOwner! ! !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: 'dropping/grabbing' stamp: 'ar 10/5/2000 18:13'! formerPosition ^self valueOfProperty: #formerPosition! ! !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: '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: 'dropping/grabbing' stamp: 'panda 4/28/2000 10:53'! highlightedForDrop ^(self valueOfProperty: #highlightedForDrop) == true! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/28/2000 11:51'! highlightForDrop self highlightForDrop: true! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/28/2000 12:01'! highlightForDrop: aBoolean self setProperty: #highlightedForDrop toValue: aBoolean. self changed! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'AlainPlantec 12/1/2010 09:35'! 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 cmd | (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]]. (self isInWorld) ifTrue: [self world startSteppingSubmorphsOf: self]. "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: '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: 'dropping/grabbing' stamp: 'MarcusDenker 11/28/2009 14:35'! nameForUndoWording "Return wording appropriate to the receiver for use in an undo-related menu item (and perhaps elsewhere)" | aName | aName := self renderedMorph class name. ^ aName truncateTo: 24! ! !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: 'dropping/grabbing' stamp: 'sw 1/11/1999 20:07'! repelsMorph: aMorph event: ev ^ false! ! !Morph methodsFor: 'dropping/grabbing' stamp: 'panda 4/28/2000 12:02'! resetHighlightForDrop self highlightForDrop: false! ! !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: '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: 'dropping/grabbing' stamp: 'mir 1/4/2001 11:02'! startDrag: anItem with: anObject self currentHand attachMorph: anObject! ! !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: '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: '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: '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: '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: '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 3/8/1999 00:17'! cursorPoint ^ self currentHand lastEvent cursorPoint! ! !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: '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: 'event handling' stamp: 'ar 1/10/2001 21:28'! dropFiles: anEvent "Handle a number of files dropped from the OS" ! ! !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: '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: '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: 'event handling' stamp: 'GuillermoPolito 4/22/2012 17:19'! handlesKeyDown: evt ^self handlesKeyboard: evt! ! !Morph methodsFor: 'event handling' stamp: 'GuillermoPolito 4/22/2012 17:20'! handlesKeyStroke: evt ^self handlesKeyboard: evt! ! !Morph methodsFor: 'event handling' stamp: 'GuillermoPolito 4/22/2012 17:19'! handlesKeyUp: evt ^self handlesKeyboard: evt! ! !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: '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: '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: '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: 'event handling' stamp: 'sw 4/2/98 14:16'! hasFocus ^ false! ! !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: '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: 'event handling' stamp: 'BenjaminVanRyseghem 1/18/2012 16:48'! keyStroke: anEvent "Handle a keystroke event. The default response is to let my eventHandler, if any, handle it."! ! !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: 'event handling' stamp: 'BenjaminVanRyseghem 4/23/2012 15:26'! mouseDown: evt "Handle a mouse down event. The default response is to let my eventHandler, if any, handle it." evt yellowButtonPressed ifTrue: ["First check for option (menu) click" (self yellowButtonActivity: evt shiftPressed) ifTrue: [ ^ self ]]. self eventHandler ifNotNil: [self eventHandler mouseDown: evt fromMorph: self] ! ! !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: '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: '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: '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: '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: 'ar 10/25/2000 18:02'! mouseStillDownThreshold "Return the number of milliseconds after which mouseStillDown: should be sent" ^200! ! !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: 'event handling' stamp: 'tk 8/10/1998 16:05'! 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: 'event handling' stamp: 'dgd 8/28/2004 18:20'! 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]. "anEvent wasHandled: true." ] ! ! !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: '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: 'event handling' stamp: 'fbs 1/7/2005 15:43'! preferredKeyboardBounds ^ self bounds: self bounds in: World. ! ! !Morph methodsFor: 'event handling' stamp: 'fbs 1/7/2005 15:42'! preferredKeyboardPosition ^ (self bounds: self bounds in: World) topLeft. ! ! !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: '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: '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: '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: 'event handling' stamp: 'AlainPlantec 12/19/2009 23:25'! tabAmongFields ^ self theme settings tabAmongFields or: [self hasProperty: #tabAmongFields] ! ! !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: 'event handling'! transformFromWorld "Return a transform to map world coordinates into my local coordinates" ^ self transformFrom: nil! ! !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: '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: '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: 'event handling' stamp: 'tbn 3/12/2010 01:55'! windowEvent: anEvent "Host window event"! ! !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: '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: '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: 'events-accessing' stamp: 'gvc 9/11/2009 17:43'! actionMap "Answer an action map" ^self updateableActionMap! ! !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: '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: '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: '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: '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: '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: '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: '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: '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: 'events-alarms' stamp: 'ar 9/11/2000 16:34'! alarmScheduler "Return the scheduler being responsible for triggering alarms" ^self world! ! !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: '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: '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: '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: '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: 'events-processing' stamp: 'ar 9/15/2000 21:13'! handleEvent: anEvent "Handle the given event" ^anEvent sentTo: self.! ! !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: '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: '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: '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: '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: '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: '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: '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: '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: '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-processing' stamp: 'BenjaminVanRyseghem 1/18/2012 19:01'! 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] ifFalse:[self mouseUp: anEvent. self stopSteppingSelector: #handleMouseStillDown:]. ^ self eventHandler ifNotNil: [:handler | handler mouseUp: anEvent fromMorph: self ]! ! !Morph methodsFor: 'events-processing' stamp: 'md 10/22/2003 15:55'! handleUnknownEvent: anEvent "An event of an unknown type was sent to the receiver. What shall we do?!!" Beeper beep. anEvent printString displayAt: 0@0. anEvent wasHandled: true.! ! !Morph methodsFor: 'events-processing' stamp: 'StephaneDucasse 7/18/2010 16:22'! mouseDownPriority "Return the default mouse down priority for the receiver" ^ 0 ! ! !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: '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: '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: '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: 'events-removing' stamp: 'rw 4/25/2002 07:18'! releaseActionMap "Release the action map" self removeProperty: #actionMap! ! !Morph methodsFor: 'geniestubs' stamp: 'nk 3/11/2004 17:30'! mouseStillDownStepRate "At what rate do I want to receive #mouseStillDown: notifications?" ^1! ! !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: 'geometry' stamp: 'efc 2/13/2003 18:17'! bottom " Return the y-coordinate of my bottom side " ^ bounds bottom! ! !Morph methodsFor: 'geometry' stamp: 'di 3/6/2002 13:06'! bottomCenter ^ bounds bottomCenter! ! !Morph methodsFor: 'geometry' stamp: 'tk 9/8/97 10:44'! bottomLeft ^ bounds bottomLeft! ! !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: 'geometry' stamp: 'di 6/12/97 11:17'! bottomRight ^ bounds bottomRight! ! !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: '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: '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/25/2000 15:05'! boundsInWorld ^self bounds: self bounds in: self world! ! !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: '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: '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: '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: 'geometry'! center ^ bounds center! ! !Morph methodsFor: 'geometry' stamp: 'sw 6/11/1999 18:48'! center: aPoint self position: (aPoint - (self extent // 2))! ! !Morph methodsFor: 'geometry'! extent ^ bounds extent! ! !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: 'geometry' stamp: 'ar 10/25/2000 15:06'! fullBoundsInWorld ^self bounds: self fullBounds in: self world! ! !Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:06'! globalPointToLocal: aPoint ^self point: aPoint from: nil! ! !Morph methodsFor: 'geometry' stamp: 'MarcusDenker 3/21/2010 20:15'! goHome | box fb | owner isNil ifTrue: [^ 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: 'geometry' stamp: 'ar 9/15/2000 14:21'! griddedPoint: ungriddedPoint | griddingContext | self flag: #arNote. "Used by event handling - should transform to pasteUp for gridding" (griddingContext := self pasteUpMorph) ifNil: [^ ungriddedPoint]. ^ griddingContext gridPoint: ungriddedPoint! ! !Morph methodsFor: 'geometry' stamp: 'di 8/25/2000 00:35'! gridPoint: ungriddedPoint ^ ungriddedPoint! ! !Morph methodsFor: 'geometry'! height ^ bounds height! ! !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: '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: 'nk 4/27/2003 16:16'! intersects: aRectangle "Answer whether aRectangle, which is in World coordinates, intersects me." ^self fullBoundsInWorld intersects: aRectangle! ! !Morph methodsFor: 'geometry' stamp: 'efc 2/13/2003 18:16'! left " Return the x-coordinate of my left side " ^ bounds left! ! !Morph methodsFor: 'geometry' stamp: 'di 3/6/2002 13:06'! leftCenter ^ bounds leftCenter! ! !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: 'geometry' stamp: 'ar 10/25/2000 15:07'! localPointToGlobal: aPoint ^self point: aPoint in: nil! ! !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: 'geometry' stamp: 'sw 6/4/2000 22:00'! minimumExtent: aPoint "Remember a minimumExtent, for possible future use" self setProperty: #minimumExtent toValue: aPoint ! ! !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: '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: 'ar 10/25/2000 15:02'! pointFromWorld: aPoint ^self point: aPoint from: self world! ! !Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:03'! pointInWorld: aPoint ^self point: aPoint in: self world! ! !Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:01'! point: aPoint from: aReferenceMorph owner ifNil: [^ aPoint]. ^ (owner transformFrom: aReferenceMorph) globalPointToLocal: aPoint. ! ! !Morph methodsFor: 'geometry' stamp: 'ar 10/25/2000 15:01'! point: aPoint in: aReferenceMorph owner ifNil: [^ aPoint]. ^ (owner transformFrom: aReferenceMorph) localPointToGlobal: aPoint. ! ! !Morph methodsFor: 'geometry'! position ^ bounds topLeft! ! !Morph methodsFor: 'geometry' stamp: 'di 9/30/1998 12:11'! positionInWorld ^ self pointInWorld: self position. ! ! !Morph methodsFor: 'geometry' stamp: 'sw 10/9/1998 08:56'! positionSubmorphs self submorphsDo: [:aMorph | aMorph snapToEdgeIfAppropriate]! ! !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: '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: '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: 'sw 10/25/1999 16:49'! referencePositionInWorld ^ self pointInWorld: self referencePosition ! ! !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: 'geometry' stamp: 'efc 2/13/2003 18:16'! right " Return the x-coordinate of my right side " ^ bounds right! ! !Morph methodsFor: 'geometry' stamp: 'di 3/6/2002 13:06'! rightCenter ^ bounds rightCenter! ! !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: 'geometry' stamp: 'bf 1/5/2000 19:08'! screenLocation "For compatibility only" ^ self fullBounds origin! ! !Morph methodsFor: 'geometry' stamp: 'sma 2/5/2000 13:58'! screenRectangle "For compatibility only" ^ self fullBounds! ! !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: '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: 'geometry' stamp: 'efc 2/13/2003 18:17'! top " Return the y-coordinate of my top side " ^ bounds top! ! !Morph methodsFor: 'geometry' stamp: 'di 3/6/2002 13:06'! topCenter ^ bounds topCenter! ! !Morph methodsFor: 'geometry' stamp: 'di 6/12/97 11:07'! topLeft ^ bounds topLeft! ! !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: 'geometry' stamp: 'sw 8/20/97 23:04'! topRight ^ bounds topRight! ! !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: '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: '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: 'geometry'! width ^ bounds width! ! !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: 'geometry' stamp: 'di 2/23/98 11:36'! worldBounds ^ self world bounds! ! !Morph methodsFor: 'geometry testing'! containsPoint: aPoint ^ self bounds containsPoint: aPoint! ! !Morph methodsFor: 'geometry testing' stamp: 'di 5/3/2000 19:05'! fullContainsPoint: aPoint (self fullBounds containsPoint: aPoint) ifFalse: [^ false]. "quick elimination" (self containsPoint: aPoint) ifTrue: [^ true]. "quick acceptance" submorphs do: [:m | (m fullContainsPoint: aPoint) ifTrue: [^ true]]. ^ false ! ! !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: 'halos and balloon help' stamp: 'BenjaminVanRyseghem 10/25/2012 15:03'! addHalo: evt | halo prospectiveHaloClass | UsersManager default currentUser 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: '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: '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: 'halos and balloon help' stamp: 'AlainPlantec 5/7/2010 23:29'! addOptionalHandlesTo: aHalo box: box ! ! !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: 'halos and balloon help' stamp: 'sma 11/11/2000 14:54'! balloonColor ^ self valueOfProperty: #balloonColor ifAbsent: [self defaultBalloonColor]! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sma 11/11/2000 14:55'! balloonColor: aColor ^ self setProperty: #balloonColor toValue: aColor! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sd 12/5/2001 20:29'! balloonFont ^ self valueOfProperty: #balloonFont ifAbsent: [self defaultBalloonFont]! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sd 12/5/2001 20:30'! balloonFont: aFont ^ self setProperty: #balloonFont toValue: aFont! ! !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: '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: '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: '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: 'halos and balloon help' stamp: 'sw 3/1/2000 11:39'! comeToFrontAndAddHalo self comeToFront. self addHalo! ! !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: 'halos and balloon help' stamp: 'sd 12/5/2001 20:23'! defaultBalloonFont ^ BalloonMorph balloonFont! ! !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: '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: '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: '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: '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: '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: 'halos and balloon help' stamp: 'ar 9/15/2000 16:16'! hasHalo ^self hasProperty: #hasHalo.! ! !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: '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: 'halos and balloon help' stamp: 'em 3/24/2005 10:05'! noHelpString ^ 'Help not yet supplied' translated! ! !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: '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: '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: '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: '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: 'halos and balloon help' stamp: 'dgd 9/9/2004 22:43'! removeHalo "remove the surrounding halo (if any)" self halo isNil ifFalse: [self primaryHand removeHalo]! ! !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: '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: 'halos and balloon help' stamp: 'sw 10/29/1999 17:38'! setCenteredBalloonText: aString self setBalloonText: aString. self setProperty: #helpAtCenter 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: '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: '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: 'halos and balloon help' stamp: 'AlainPlantec 12/19/2009 23:40'! wantsDirectionHandles ^self valueOfProperty: #wantsDirectionHandles ifAbsent:[false]! ! !Morph methodsFor: 'halos and balloon help' stamp: 'AlainPlantec 12/19/2009 23:41'! wantsDirectionHandles: aBool self setProperty: #wantsDirectionHandles toValue: aBool ! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sw 4/8/98 13:26'! wantsHaloFor: aSubMorph ^ false! ! !Morph methodsFor: 'halos and balloon help' stamp: 'sw 1/25/2000 17:43'! wantsHaloFromClick ^ true! ! !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: '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: 'initialize' stamp: 'dgd 3/7/2003 15:06'! defaultBounds "answer the default bounds for the receiver" ^ 0 @ 0 corner: 50 @ 40! ! !Morph methodsFor: 'initialize' stamp: 'dgd 2/14/2003 22:28'! defaultColor "answer the default color/fill style for the receiver" ^ Color blue! ! !Morph methodsFor: 'initialize' 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: '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: 'initialize' stamp: 'RAA 10/18/2000 12:33'! openCenteredInWorld self fullBounds; position: Display extent - self extent // 2; openInWorld.! ! !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: 'initialize' stamp: 'djp 10/24/1999 17:13'! openInWindow ^self openInWindowLabeled: self defaultLabelForInspector ! ! !Morph methodsFor: 'initialize' stamp: 'sma 4/22/2000 20:28'! openInWindowLabeled: aString ^self openInWindowLabeled: aString inWorld: self currentWorld! ! !Morph methodsFor: 'initialize' stamp: 'alain.plantec 6/10/2008 18:35'! openInWorld "Add this morph to the world." self openInWorld: self currentWorld! ! !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: '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: '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: '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: 'layout' stamp: 'dgd 2/22/2003 14:31'! 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." | layout box priorBounds | priorBounds := self outerBounds. submorphs isEmpty ifTrue: [^fullBounds := priorBounds]. "Send #ownerChanged to our children" submorphs do: [:m | m ownerChanged]. layout := self layoutPolicy. layout ifNotNil: [layout layout: self in: layoutBounds]. self adjustLayoutBounds. fullBounds := self privateFullBounds. box := self outerBounds. box = priorBounds ifFalse: [self invalidRect: (priorBounds quickMerge: box)]! ! !Morph methodsFor: 'layout' stamp: 'ar 1/1/2002 20:00'! 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 doLayoutIn: self layoutBounds] on: Error do:[:ex| "This should do it unless you don't screw up the bounds" fullBounds := bounds. ex pass]. ^fullBounds! ! !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: '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: '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' stamp: 'dgd 2/16/2003 21:52'! minHeight "answer the receiver's minHeight" ^ self valueOfProperty: #minHeight ifAbsent: [2]! ! !Morph methodsFor: 'layout' stamp: 'dgd 2/22/2003 14:32'! minHeight: aNumber aNumber isNil ifTrue: [self removeProperty: #minHeight] ifFalse: [self setProperty: #minHeight toValue: aNumber]. self layoutChanged! ! !Morph methodsFor: 'layout' stamp: 'dgd 2/16/2003 21:54'! minWidth "answer the receiver's minWidth" ^ self valueOfProperty: #minWidth ifAbsent: [2]! ! !Morph methodsFor: 'layout' stamp: 'dgd 2/22/2003 14:32'! minWidth: aNumber aNumber isNil ifTrue: [self removeProperty: #minWidth] ifFalse: [self setProperty: #minWidth toValue: aNumber]. self layoutChanged! ! !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: '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-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: '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: '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: '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: '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: 'layout-menu' stamp: 'ar 10/31/2000 19:19'! changeDisableTableLayout self disableTableLayout: self disableTableLayout not. self layoutChanged.! ! !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: '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: '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: '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-menu' stamp: 'ar 10/31/2000 19:19'! changeNoLayout self layoutPolicy ifNil:[^self]. "already no layout" self layoutPolicy: nil. self layoutChanged.! ! !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: 'layout-menu' stamp: 'ar 11/13/2000 19:10'! changeReverseCells self reverseTableCells: self reverseTableCells not.! ! !Morph methodsFor: 'layout-menu' stamp: 'ar 11/13/2000 19:10'! changeRubberBandCells self rubberBandCells: self rubberBandCells not.! ! !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: 'layout-menu' stamp: 'StephaneDucasse 4/22/2012 16:49'! hasClipLayoutCellsString ^ (self clipLayoutCells) -> 'clip to cell size' translated! ! !Morph methodsFor: 'layout-menu' stamp: 'StephaneDucasse 4/22/2012 16:50'! hasDisableTableLayoutString ^ (self disableTableLayout) -> 'disable layout in tables' translated! ! !Morph methodsFor: 'layout-menu' stamp: 'StephaneDucasse 4/22/2012 16:52'! hasNoLayoutString ^ (self layoutPolicy isNil) -> 'no layout' translated! ! !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: 'layout-menu' stamp: 'StephaneDucasse 4/22/2012 16:52'! hasReverseCellsString ^ (self reverseTableCells) -> 'reverse table cells' translated! ! !Morph methodsFor: 'layout-menu' stamp: 'StephaneDucasse 4/22/2012 16:52'! hasRubberBandCellsString ^ (self rubberBandCells) -> 'rubber band cells' translated! ! !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: '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: '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: '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: '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-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: '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: 'layout-properties' stamp: 'ar 10/29/2000 02:48'! cellPositioningString: aSymbol ^self layoutMenuPropertyString: aSymbol from: self cellPositioning! ! !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: '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: 'layout-properties' stamp: 'ar 10/29/2000 02:47'! cellSpacingString: aSymbol ^self layoutMenuPropertyString: aSymbol from: self cellSpacing! ! !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: '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: '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: '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: 'layout-properties' stamp: 'ar 10/31/2000 20:45'! hResizingString: aSymbol ^self layoutMenuPropertyString: aSymbol from: self hResizing! ! !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: '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: '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: 'layout-properties' stamp: 'ar 11/14/2000 16:38'! layoutInset "Return the extra inset for layouts" | props | props := self layoutProperties. ^props ifNil:[0] ifNotNil:[props layoutInset].! ! !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: '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: '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: '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: '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: '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: 'layout-properties' stamp: 'ar 10/29/2000 02:47'! listCenteringString: aSymbol ^self layoutMenuPropertyString: aSymbol from: self listCentering! ! !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: '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: 'layout-properties' stamp: 'ar 10/29/2000 02:47'! listDirectionString: aSymbol ^self layoutMenuPropertyString: aSymbol from: self listDirection! ! !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: '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: 'layout-properties' stamp: 'ar 10/29/2000 02:47'! listSpacingString: aSymbol ^self layoutMenuPropertyString: aSymbol from: self listSpacing! ! !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 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: '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: '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: '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: '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: '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: '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: '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: '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: '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: 'layout-properties' stamp: 'tk 10/30/2001 18:39'! vResizeToFit: aBoolean aBoolean ifTrue:[ self vResizing: #shrinkWrap. ] ifFalse:[ self vResizing: #rigid. ].! ! !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: 'layout-properties' stamp: 'ar 10/31/2000 20:45'! vResizingString: aSymbol ^self layoutMenuPropertyString: aSymbol from: self vResizing! ! !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: '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: 'layout-properties' stamp: 'ar 10/29/2000 03:00'! wrapCenteringString: aSymbol ^self layoutMenuPropertyString: aSymbol from: self wrapCentering! ! !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-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: 'layout-properties' stamp: 'ar 10/29/2000 03:00'! wrapDirectionString: aSymbol ^self layoutMenuPropertyString: aSymbol from: self wrapDirection ! ! !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: '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: '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: '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: '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: '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: 'menu' stamp: 'MarcusDenker 9/7/2010 17:41'! addTitleForHaloMenu: aMenu aMenu addTitle: self externalName icon: (self iconOrThumbnailOfSize: 28)! ! !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: '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: 'menu' stamp: 'StephaneDucasse 7/18/2010 16:17'! hasYellowButtonMenu "Answer true if I have any items at all for a context (yellow button) menu." ^ self wantsYellowButtonMenu or: [self modelOrNil ifNil: [false] ifNotNilDo: [:aModel | aModel hasModelYellowButtonMenuItems]]! ! !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: '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: '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: '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: '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: '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: 'menus' stamp: 'AlainPlantec 11/5/2011 16:12'! 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: self theme smallExportIcon subMenu: aSubMenu. aMenu lastItem icon: self theme smallExportIcon]. ! ! !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: '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: '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: '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: '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: '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: '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: '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: '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: 'menus' stamp: 'tbn 5/10/2011 09:22'! changeColor "Change the color of the receiver -- triggered, e.g. from a menu" |d| d := self openModal: ( ColorSelectorDialogWindow new title: 'Choose color'; selectedColor: self color). d cancelled ifFalse: [self fillStyle: d selectedColor] ! ! !Morph methodsFor: 'menus' stamp: 'ar 11/29/2001 19:57'! changeDirectionHandles ^self wantsDirectionHandles: self wantsDirectionHandles not! ! !Morph methodsFor: 'menus' stamp: 'ar 11/2/2000 15:04'! changeDragAndDrop ^self enableDragNDrop: self dragNDropEnabled not! ! !Morph methodsFor: 'menus' stamp: 'sw 2/21/2000 15:21'! collapse CollapsedMorph new beReplacementFor: self! ! !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: '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: '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: '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: 'menus' stamp: 'StephaneDucasse 4/22/2012 16:50'! hasDirectionHandlesString ^ (self wantsDirectionHandles) -> 'direction handles' translated! ! !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: 'menus' stamp: 'IgorStasenko 4/15/2011 17:24'! inspectInMorphic: evt evt hand attachMorph: ((Smalltalk tools inspect: self) extent: 300@200)! ! !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: '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: '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: 'menus' stamp: 'dgd 9/22/2004 20:30'! model ^ nil ! ! !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: '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: 'menus' stamp: 'AlainPlantec 12/19/2009 23:35'! 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: [Beeper beep]! ! !Morph methodsFor: 'menus' stamp: 'ar 9/22/2000 20:14'! setRotationCenterFrom: aPoint self rotationCenter: (aPoint - self bounds origin) / self bounds extent asFloatPoint.! ! !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: '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: '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: '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: '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: '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: '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: '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: 'meta-actions' stamp: 'MarcusDenker 12/10/2011 17:05'! 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: self theme 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: '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: 'meta-actions' stamp: 'MarcusDenker 11/7/2009 18:52'! copyToPasteBuffer: evt ^evt hand copyToPasteBuffer: self.! ! !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: 'meta-actions' stamp: 'mir 3/17/2006 18:01'! dismissMorph: evt self dismissMorph! ! !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: 'meta-actions' stamp: 'ar 10/6/2000 16:37'! grabMorph: evt evt hand grabMorph: self! ! !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: '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: '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: '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: 'meta-actions' stamp: 'BenjaminVanRyseghem 10/25/2012 15:04'! invokeMetaMenu: evt | menu | UsersManager default currentUser canShowMorphHalo ifFalse: [ ^ self ]. menu := self buildMetaMenu: evt. menu addTitle: self externalName. self world ifNotNil: [ menu popUpEvent: evt in: self world ]! ! !Morph methodsFor: 'meta-actions' stamp: 'MarcusDenker 3/27/2011 17:12'! maybeDuplicateMorph "Maybe duplicate the morph" ^self duplicate openInHand! ! !Morph methodsFor: 'meta-actions' stamp: 'MarcusDenker 11/7/2009 18:50'! maybeDuplicateMorph: evt ^self duplicateMorph: evt! ! !Morph methodsFor: 'meta-actions' stamp: 'wiz 1/2/2005 01:06'! 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) select: [:m | m isFlexMorph not]! ! !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: '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: 'meta-actions' stamp: 'sw 11/27/2001 14:59'! resizeFromMenu "Commence an interaction that will resize the receiver" self resizeMorph: ActiveEvent! ! !Morph methodsFor: 'meta-actions' stamp: 'st 9/14/2004 12:30'! resizeMorph: evt | handle | handle := HandleMorph new forEachPointDo: [:newPoint | self extent: (self griddedPoint: newPoint) - self bounds topLeft]. evt hand attachMorph: handle. handle startStepping. ! ! !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: '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: '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: 'naming' stamp: 'gm 2/22/2003 13:16'! name: aName (aName isString) ifTrue: [self setNameTo: aName]! ! !Morph methodsFor: 'naming' stamp: 'dgd 2/16/2003 21:57'! setNamePropertyTo: aName "change the receiver's externalName" self assureExtension externalName: aName! ! !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: '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: '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: '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: 'printing' stamp: 'StephaneDucasse 8/2/2011 22:46'! colorString: aColor aColor ifNil: [ ^'nil' ]. ^aColor name ifNil: [ aColor storeString ] ifNotNil: [ :colorName | 'Color ', colorName ]! ! !Morph methodsFor: 'printing'! fullPrintOn: aStream aStream nextPutAll: self class name , ' newBounds: ('; print: bounds; nextPutAll: ') color: ' , (self colorString: color)! ! !Morph methodsFor: 'printing' stamp: 'MarcusDenker 10/28/2010 14:02'! printOn: aStream super printOn: aStream. aStream nextPutAll: '('. aStream print: self identityHash; nextPutAll: ')'! ! !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: '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: '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: '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: 'rotate scale and flex' stamp: 'ar 2/16/1999 18:59'! newTransformationMorph ^TransformationMorph new! ! !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: 'rotate scale and flex' stamp: 'AlainPlantec 5/8/2010 00:33'! removeFlexShell self isFlexed ifTrue: [self owner removeFlexShell]! ! !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: 'rotate scale and flex' stamp: 'ar 9/22/2000 20:11'! 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 isNil ifTrue:[self removeProperty: #rotationCenter] ifFalse:[self setProperty: #rotationCenter toValue: aPointOrNil] ! ! !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: '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: '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: 'rounding' stamp: 'ar 12/25/2001 19:44'! toggleCornerRounding self cornerStyle == #rounded ifTrue: [self cornerStyle: #square] ifFalse: [self cornerStyle: #rounded]. self changed! ! !Morph methodsFor: 'rounding' stamp: 'MarcusDenker 10/26/2011 14:58'! useRoundedCorners self cornerStyle: #rounded! ! !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: '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: 'settings' stamp: 'AlainPlantec 12/19/2009 23:16'! balloonHelpEnabled ^ self theme settings balloonHelpEnabled! ! !Morph methodsFor: 'settings' stamp: 'AlainPlantec 12/19/2009 23:12'! cmdGesturesEnabled ^ self class cmdGesturesEnabled! ! !Morph methodsFor: 'settings' stamp: 'AlainPlantec 12/10/2009 13:03'! defaultYellowButtonMenuEnabled ^ self class defaultYellowButtonMenuEnabled! ! !Morph methodsFor: 'settings' stamp: 'AlainPlantec 12/19/2009 23:23'! menuKeyboardControl ^ self theme settings menuKeyboardControl! ! !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: '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: '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: '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: 'stepping and presenter'! start "Start running my script. For ordinary morphs, this means start stepping." self startStepping. ! ! !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: '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: '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: '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: '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: '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: 'stepping and presenter'! stop "Stop running my script. For ordinary morphs, this means stop stepping." self stopStepping. ! ! !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: '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: 'stepping and presenter' stamp: 'sw 10/11/1999 12:59'! stopSteppingSelfAndSubmorphs self allMorphsDo: [:m | m stopStepping] ! ! !Morph methodsFor: 'structure' stamp: 'ar 3/18/2001 00:11'! activeHand ^ActiveHand! ! !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: '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: 'structure' stamp: 'alain.plantec 6/19/2008 09:34'! containingWindow "Answer a window that contains the receiver" ^ self ownerThatIsA: SystemWindow! ! !Morph methodsFor: 'structure' stamp: 'di 11/13/2000 00:48'! firstOwnerSuchThat: conditionBlock self allOwnersDo: [:m | (conditionBlock value: m) ifTrue: [^ m]]. ^ nil ! ! !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: '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: '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: 'structure' stamp: 'dgd 2/22/2003 19:05'! isInWorld "Return true if this morph is in a world." ^self world notNil! ! !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: '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: '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: 'structure' stamp: 'marcus.denker 7/24/2009 14:07'! outermostWorldMorph ^World.! ! !Morph methodsFor: 'structure'! owner "Returns the owner of this morph, which may be nil." ^ owner! ! !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: 'structure' stamp: 'RAA 6/13/2000 15:01'! primaryHand | outer | outer := self outermostWorldMorph ifNil: [^ nil]. ^ outer activeHand ifNil: [outer firstHand]! ! !Morph methodsFor: 'structure' stamp: 'wiz 12/7/2006 15:12'! renderedMorph "This now gets overridden by rendering morphs." ^self! ! !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: '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: '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: '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: 'dgd 2/22/2003 14:36'! world ^owner isNil ifTrue: [nil] ifFalse: [owner world]! ! !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: '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: '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: '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: 'dgd 8/31/2004 16:53'! dockingBars "Answer the receiver's dockingBars" ^ self submorphs select: [:each | each 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: '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: '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: '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: 'submorphs-accessing' stamp: 'dgd 2/22/2003 14:31'! firstSubmorph ^submorphs first! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'dgd 2/22/2003 14:32'! hasSubmorphs ^submorphs notEmpty! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'dgd 2/22/2003 14:32'! lastSubmorph ^submorphs last! ! !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: '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: '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: '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: '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: '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: '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: '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: 'submorphs-accessing' stamp: 'ar 8/13/2003 11:32'! noteNewOwner: aMorph "I have just been added as a submorph of aMorph"! ! !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: '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: '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-accessing'! submorphCount ^ submorphs size! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'sw 4/9/98 14:26'! submorphNamed: aName ^ self submorphNamed: aName ifNone: [nil]! ! !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: '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: '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: 'submorphs-accessing' stamp: 'dgd 2/22/2003 14:35'! submorphsDo: aBlock submorphs do: aBlock! ! !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: 'submorphs-accessing'! submorphsReverseDo: aBlock submorphs reverseDo: aBlock.! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'sw 8/15/97 22:03'! submorphsSatisfying: aBlock ^ submorphs select: [:m | (aBlock value: m) == true]! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'sw 10/26/1999 23:42'! submorphThat: block1 ifNone: block2 ^ submorphs detect: [:m | (block1 value: m) == true] ifNone: [block2 value] ! ! !Morph methodsFor: 'submorphs-accessing' stamp: 'sw 7/3/1998 18:47'! submorphWithProperty: aSymbol ^ submorphs detect: [:aMorph | aMorph hasProperty: aSymbol] ifNone: [nil]! ! !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-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: '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: 'submorphs-add/remove' stamp: 'ar 8/12/2003 23:28'! addAllMorphs: aCollection ^self privateAddAllMorphs: aCollection atIndex: submorphs size! ! !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: 'submorphs-add/remove' stamp: 'ar 1/31/2001 12:55'! addMorphBack: aMorph ^self privateAddMorph: aMorph atIndex: submorphs size+1! ! !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: 'submorphs-add/remove' stamp: 'ar 12/16/2001 21:08'! addMorphFrontFromWorldPosition: aMorph ^self addMorphFront: aMorph fromWorldPosition: aMorph positionInWorld.! ! !Morph methodsFor: 'submorphs-add/remove' stamp: 'ar 1/31/2001 12:54'! addMorphFront: aMorph ^self privateAddMorph: aMorph atIndex: 1! ! !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: 'submorphs-add/remove'! addMorph: aMorph self addMorphFront: aMorph.! ! !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: '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: '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: '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: '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-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: '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: '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: '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: '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: 'submorphs-add/remove' stamp: 'michael.rueger 3/9/2009 18:48'! goBehind owner addMorphBack: self. ! ! !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: '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: '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: '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: '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: '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: '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: '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: 'testing' stamp: 'dgd 8/31/2004 15:00'! isDockingBar "Return true if the receiver is a docking bar" ^ false! ! !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: '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: 'testing' stamp: 'nk 10/13/2003 18:36'! isLineMorph ^false! ! !Morph methodsFor: 'testing'! isMorph ^ true! ! !Morph methodsFor: 'testing' stamp: 'stephane.ducasse 11/14/2008 21:48'! renameTo: aName "Set The morph name." self topRendererOrSelf setNameTo: aName. ^aName! ! !Morph methodsFor: 'testing' stamp: 'ar 12/3/2001 12:33'! shouldDropOnMouseUp | former | former := self formerPosition ifNil:[^false]. ^(former dist: self position) > 10! ! !Morph methodsFor: 'testing' stamp: 'WilliamSix 1/14/2013 19:43'! shouldFlex ^ self isFlexMorph.! ! !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: 'testing' stamp: 'BenjaminVanRyseghem 11/28/2012 00:59'! simulateKeyStrokes: aString aString do: [:c | self simulateKeyStroke: c ].! ! !Morph methodsFor: 'testing' stamp: 'SeanDeNigris 12/18/2011 16:51'! stepTime "Answer the desired time between steps in milliseconds. This is just a recommendation; there is absolutely no guarantee how often #step will actually be called. This default implementation requests that the 'step' method be called once every second." ^ 1000 ! ! !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: '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: '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: '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: '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: 'text-anchor' stamp: 'StephaneDucasse 4/22/2012 16:50'! hasDocumentAnchorString ^ (self textAnchorType == #document) -> 'Document' translated! ! !Morph methodsFor: 'text-anchor' stamp: 'StephaneDucasse 4/22/2012 16:51'! hasInlineAnchorString ^ (self textAnchorType == #inline)-> 'Inline' translated! ! !Morph methodsFor: 'text-anchor' stamp: 'StephaneDucasse 4/22/2012 16:52'! hasParagraphAnchorString ^ (self textAnchorType == #paragraph) -> 'Paragraph' translated! ! !Morph methodsFor: 'text-anchor' stamp: 'ar 12/16/2001 19:47'! relativeTextAnchorPosition ^self valueOfProperty: #relativeTextAnchorPosition! ! !Morph methodsFor: 'text-anchor' stamp: 'ar 12/16/2001 19:22'! relativeTextAnchorPosition: aPoint ^self setProperty: #relativeTextAnchorPosition toValue: aPoint! ! !Morph methodsFor: 'text-anchor' stamp: 'ar 12/16/2001 18:36'! textAnchorType ^self valueOfProperty: #textAnchorType ifAbsent:[#document]! ! !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: 'thumbnail' stamp: 'dgd 9/12/2004 21:12'! icon "Answer a form with an icon to represent the receiver" ^ self valueOfProperty: #icon! ! !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: 'thumbnail' stamp: 'dgd 9/13/2004 12:43'! iconOrThumbnailOfSize: aNumberOrPoint "Answer an appropiate form to represent the receiver" ^ self iconOrThumbnail scaledIntoFormOfSize: aNumberOrPoint ! ! !Morph methodsFor: 'thumbnail' stamp: 'sw 6/16/1999 11:29'! permitsThumbnailing ^ true! ! !Morph methodsFor: 'undo' stamp: 'md 10/22/2003 15:56'! undoMove: cmd redo: redo owner: formerOwner bounds: formerBounds predecessor: formerPredecessor "Handle undo and redo of move commands in morphic" self owner ifNil: [^Beeper beep]. redo ifFalse: ["undo sets up the redo state first" cmd redoTarget: self selector: #undoMove:redo:owner:bounds:predecessor: arguments: { cmd. true. owner. bounds. owner morphPreceding: self}]. formerOwner ifNotNil: [formerPredecessor ifNil: [formerOwner addMorphFront: self] ifNotNil: [formerOwner addMorph: self after: formerPredecessor]]. self bounds: formerBounds. (self isSystemWindow) ifTrue: [self activate]! ! !Morph methodsFor: 'user interface' stamp: 'tak 3/15/2005 17:36'! becomeModal self currentWorld ifNotNil: [self currentWorld modalWindow: self]! ! !Morph methodsFor: 'user interface' stamp: 'sw 5/29/2000 00:41'! defaultLabelForInspector "Answer the default label to be used for an Inspector window on the receiver." ^ super printString truncateTo: 40! ! !Morph methodsFor: 'user interface' stamp: 'tak 3/15/2005 17:10'! doCancel self delete! ! !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: 'user interface' stamp: 'MarianoMartinezPeck 8/24/2012 15:28'! initialExtent | ext | (ext := self valueOfProperty: #initialExtent) ifNotNil: [^ ext]. ^700@500! ! !Morph methodsFor: 'utilities' stamp: 'sw 10/23/1998 12:00'! addTransparentSpacerOfSize: aPoint self addMorphBack: (self transparentSpacerOfSize: aPoint)! ! !Morph methodsFor: 'utilities' stamp: 'RAA 5/25/2000 09:06'! embedInWindow | window worldToUse | worldToUse := self world. "I'm assuming we are already in a world" window := (SystemWindow labelled: self defaultLabelForInspector) 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: '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: 'utilities' stamp: 'sw 10/23/1998 11:50'! transparentSpacerOfSize: aPoint ^ (Morph new extent: aPoint) color: Color transparent! ! !Morph methodsFor: 'viewer' stamp: 'AlainPlantec 1/14/2010 09:41'! externalName ^ self assureExtension externalName ifNil: [super externalName]! ! !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: 'visual properties' stamp: 'nk 8/28/2003 15:56'! defaultBitmapFillForm ^ImageMorph defaultForm. ! ! !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: '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: '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: '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: '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: '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: '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: '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: '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: '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: 'wiw support' stamp: 'ar 3/18/2001 00:14'! shouldGetStepsFrom: aWorld ^self world == aWorld! ! !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: 'private' stamp: 'nk 10/11/2003 16:08'! privateAddMorph: aMorph atIndex: index | oldIndex myWorld itsWorld oldOwner | ((index >= 1) and: [index <= (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: 'private'! privateBounds: boundsRect "Private!! Use position: and/or extent: instead." fullBounds := nil. bounds := boundsRect.! ! !Morph methodsFor: 'private' stamp: 'jm 5/29/1998 21:28'! privateColor: aColor color := aColor. ! ! !Morph methodsFor: 'private' stamp: 'tk 8/30/1998 09:58'! privateFullBounds: boundsRect "Private!! Computed automatically." fullBounds := boundsRect.! ! !Morph methodsFor: 'private' stamp: 'ar 12/16/2001 21:47'! 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. 1 to: submorphs size do: [:i | (submorphs at: i) privateFullMoveBy: delta]. owner ifNotNil:[ owner isTextMorph ifTrue:[owner adjustTextAnchor: self]].! ! !Morph methodsFor: 'private'! privateOwner: aMorph "Private!! Should only be used by methods that maintain the ower/submorph invariant." owner := aMorph.! ! !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: 'private'! privateSubmorphs "Private!! Use 'submorphs' instead." ^ submorphs! ! !Morph methodsFor: 'private'! privateSubmorphs: aCollection "Private!! Should only be used by methods that maintain the ower/submorph invariant." submorphs := aCollection.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Morph class instanceVariableNames: ''! !Morph class methodsFor: '*Nautilus' stamp: 'BenjaminVanRyseghem 1/2/2013 12:07'! nautilusIcon ^ self nautilusIconClass iconNamed: #morph! ! !Morph class methodsFor: '*Polymorph-Widgets' stamp: 'gvc 5/23/2007 15:48'! theme "Answer the ui theme that provides controls." ^UITheme current! ! !Morph class methodsFor: 'initialize-release'! initialize "Morph initialize" "this empty array object is shared by all morphs with no submorphs:" EmptyArray := Array new. ! ! !Morph class methodsFor: 'initialize-release' stamp: 'IgorStasenko 4/15/2011 17:22'! unload Smalltalk tools fileList unregisterFileReader: self ! ! !Morph class methodsFor: 'instance creation'! newBounds: bounds ^ self new privateBounds: bounds! ! !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: 'instance creation' stamp: 'sw 8/4/97 12:05'! newSticky ^ self new beSticky! ! !Morph class methodsFor: 'misc' stamp: 'nice 1/5/2010 15:59'! 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) ~~ nil and: [(itsOwner submorphs includes: m) not])]) ifTrue: [problemMorphs add: m]]. ^ problemMorphs! ! !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: 'settings' stamp: 'AlainPlantec 12/19/2009 23:12'! cmdGesturesEnabled ^ CmdGesturesEnabled ifNil: [CmdGesturesEnabled := true]! ! !Morph class methodsFor: 'settings' stamp: 'AlainPlantec 12/19/2009 23:12'! cmdGesturesEnabled: aBoolean CmdGesturesEnabled := aBoolean! ! !Morph class methodsFor: 'settings' stamp: 'SeanDeNigris 4/24/2012 19:51'! cycleHalosBothDirections ^ CycleHalosBothDirections ifNil: [ CycleHalosBothDirections := false ].! ! !Morph class methodsFor: 'settings' stamp: 'SeanDeNigris 4/24/2012 19:52'! cycleHalosBothDirections: aBoolean CycleHalosBothDirections := aBoolean.! ! !Morph class methodsFor: 'settings' stamp: 'AlainPlantec 12/10/2009 13:09'! defaultYellowButtonMenuEnabled ^ DefaultYellowButtonMenuEnabled ifNil: [DefaultYellowButtonMenuEnabled := false]! ! !Morph class methodsFor: 'settings' stamp: 'AlainPlantec 12/10/2009 13:02'! defaultYellowButtonMenuEnabled: aBoolean DefaultYellowButtonMenuEnabled := aBoolean! ! !Morph class methodsFor: 'settings' stamp: 'usmanbhatti 3/6/2012 19:23'! halosEnabled ^ HalosEnabled ifNil: [ HalosEnabled := true ]! ! !Morph class methodsFor: 'settings' stamp: 'BenjaminVanRyseghem 3/6/2012 19:38'! halosEnabled: aBoolean HalosEnabled := aBoolean! ! !Morph class methodsFor: 'settings' stamp: 'GuillermoPolito 9/24/2012 21:52'! morphNavigationShortcutsOn: aBuilder "Basic, general navigation shortcut among morphs. #MorphNoCtrl will not work for TextMorphs." (aBuilder shortcut: #navigateFocusForwardCtrl) category: #MorphFocusCtrlNavigation default: Character tab ctrl asShortcut do: [ :target :morph :event | morph navigateFocusForward ]. (aBuilder shortcut: #navigateFocusBackwardCtrl) category: #MorphFocusCtrlNavigation default: Character tab shift ctrl asShortcut do: [ :target :morph :event | morph navigateFocusBackward ]. (aBuilder shortcut: #navigateFocusForward) category: #MorphFocusNavigation default: Character tab asShortcut do: [ :target :morph :event | morph navigateFocusForward ]. (aBuilder shortcut: #navigateFocusBackward) category: #MorphFocusNavigation default: Character tab shift asShortcut do: [ :target :morph :event | morph navigateFocusBackward ]! ! Announcement subclass: #MorphAnnouncement instanceVariableNames: 'morph' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Announcements'! !MorphAnnouncement commentStamp: '' prior: 0! 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 instanceVariableNames: ''! !MorphAnnouncement class methodsFor: 'instance creation' stamp: 'GuillermoPolito 5/1/2012 19:48'! morph: aMorph ^self new morph: aMorph; yourself! ! TestCase subclass: #MorphBugs instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Bugs'! !MorphBugs methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 10/26/2011 15:00'! adhereToEdgeTest "self new adhereToEdgeTest" "self run: #adhereToEdgeTest" | r | r := Morph new openInWorld . self shouldnt: [ [ r adhereToEdge: #eternity ] ensure: [ r delete ] ] raise: Error . r delete . ^true ! ! MorphAnnouncement subclass: #MorphDeleted instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Announcements'! !MorphDeleted commentStamp: '' prior: 0! 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.! DropListMorph subclass: #MorphDropListMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !MorphDropListMorph commentStamp: 'gvc 5/18/2007 12:43' prior: 0! 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: 'GaryChambers 4/24/2012 15:22'! font: aFont "Set the list font" self listFont: aFont! ! !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: 'gvc 9/29/2006 11:58'! updateContentColor: paneColor "Change the content text color." ! ! !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]! ! ComposableModel subclass: #MorphEmbedder instanceVariableNames: 'morph container title' classVariableNames: '' poolDictionaries: '' category: 'CI-Core-SliceSubmitter'! !MorphEmbedder commentStamp: '' prior: 0! A MorphEmbedder is a Spec model which embed a morph into a window! !MorphEmbedder methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 7/6/2012 16:21'! initialize "Initialization code for ChangesViewer" morph := nil asValueHolder. title := self class title. super initialize. ! ! !MorphEmbedder methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 7/18/2012 17:16'! initializeWidgets morph whenChangedDo: [:m | container := m ]! ! !MorphEmbedder methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 7/6/2012 16:21'! title ^ title! ! !MorphEmbedder methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 7/6/2012 16:22'! title: aString title := aString. self updateTitle.! ! !MorphEmbedder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/18/2012 17:16'! initialExtent ^ 800@500! ! !MorphEmbedder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/6/2012 16:06'! morph ^ morph contents! ! !MorphEmbedder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/18/2012 17:14'! morph: aMorph morph contents: aMorph. aMorph hResizing: #spaceFill; vResizing: #spaceFill! ! !MorphEmbedder methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/6/2012 15:59'! result ^ self window ifNil: [ false ] ifNotNil: [:w | w cancelled not ]! ! !MorphEmbedder methodsFor: 'private' stamp: 'BenjaminVanRyseghem 7/6/2012 16:04'! container ^container ifNil: [ container := PanelMorph new color: Color red; vResizing: #spaceFill; hResizing: #spaceFill yourself ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MorphEmbedder class instanceVariableNames: ''! !MorphEmbedder class methodsFor: 'spec' stamp: 'BenjaminVanRyseghem 7/6/2012 15:54'! spec ^ SpecLayout composed add: #container; yourself! ! Object subclass: #MorphEventSubscription instanceVariableNames: 'event selector recipient valueParameter' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Events'! !MorphEventSubscription commentStamp: 'GuillermoPolito 4/22/2012 19:17' prior: 0! 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'! 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 ^ recipient! ! !MorphEventSubscription methodsFor: 'accessing' stamp: 'GuillermoPolito 4/22/2012 18:36'! recipient: anObject recipient := anObject! ! !MorphEventSubscription methodsFor: 'accessing' stamp: 'GuillermoPolito 4/22/2012 18:36'! selector ^ selector! ! !MorphEventSubscription methodsFor: 'accessing' stamp: 'GuillermoPolito 4/22/2012 18:36'! selector: anObject selector := anObject! ! !MorphEventSubscription methodsFor: 'accessing' stamp: 'GuillermoPolito 4/22/2012 18:39'! valueParameter ^ valueParameter! ! !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: '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:42'! doubleClickTimeout: anEvent fromMorph: aMorph ^self notify: anEvent from: aMorph! ! !MorphEventSubscription methodsFor: 'events-triggering' stamp: 'GuillermoPolito 4/22/2012 18:41'! mouseEnter: 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: '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 instanceVariableNames: ''! !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! ! Object subclass: #MorphExtension instanceVariableNames: 'locked visible sticky balloonText externalName eventHandler otherProperties fillStyle layoutPolicy layoutFrame layoutProperties borderStyle cornerStyle actionMap clipSubmorphs' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Kernel'! !MorphExtension commentStamp: '' prior: 0! 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' stamp: 'gvc 9/11/2009 17:41'! actionMap "Answer the value of actionMap" ^actionMap ifNil: [self valueOfProperty: #actionMap ifAbsent: []]! ! !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:52'! balloonText ^ balloonText! ! !MorphExtension methodsFor: 'accessing' stamp: 'di 8/10/1998 12:55'! balloonText: newValue balloonText := newValue! ! !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' stamp: 'gvc 9/11/2009 18:10'! clipSubmorphs "Answer the value of clipSubmorphs" ^clipSubmorphs! ! !MorphExtension methodsFor: 'accessing' stamp: 'gvc 9/11/2009 17:58'! clipSubmorphs: anObject "Set the value of clipSubmorphs" clipSubmorphs := anObject! ! !MorphExtension methodsFor: 'accessing' stamp: 'gvc 9/11/2009 18:10'! cornerStyle "Answer the value of cornerStyle" ^cornerStyle! ! !MorphExtension methodsFor: 'accessing' stamp: 'gvc 9/11/2009 17:23'! cornerStyle: anObject "Set the value of cornerStyle" cornerStyle := anObject! ! !MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:51'! eventHandler "answer the receiver's eventHandler" ^ eventHandler ! ! !MorphExtension methodsFor: 'accessing' stamp: 'di 8/10/1998 12:56'! eventHandler: newValue eventHandler := newValue! ! !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 18:12'! fillStyle "Answer the value of fillStyle" ^ fillStyle! ! !MorphExtension methodsFor: 'accessing' stamp: 'gvc 9/11/2009 16:55'! fillStyle: anObject "Set the value of fillStyle" fillStyle := anObject! ! !MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:38'! locked "answer whether the receiver is Locked" ^ locked! ! !MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:48'! locked: aBoolean "change the receiver's locked property" locked := aBoolean! ! !MorphExtension methodsFor: 'accessing' stamp: 'di 8/14/1998 13:07'! sticky ^ sticky! ! !MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:47'! sticky: aBoolean "change the receiver's sticky property" sticky := aBoolean! ! !MorphExtension methodsFor: 'accessing' stamp: 'dgd 2/16/2003 21:41'! visible "answer whether the receiver is visible" ^ visible! ! !MorphExtension methodsFor: 'accessing' stamp: 'di 8/10/1998 12:55'! visible: newValue visible := newValue! ! !MorphExtension methodsFor: 'accessing - layout properties' stamp: 'gvc 9/11/2009 18:10'! layoutFrame ^layoutFrame! ! !MorphExtension methodsFor: 'accessing - layout properties' stamp: 'gvc 9/11/2009 16:45'! layoutFrame: aLayoutFrame layoutFrame := aLayoutFrame! ! !MorphExtension methodsFor: 'accessing - layout properties' stamp: 'gvc 9/11/2009 18:12'! layoutPolicy ^layoutPolicy! ! !MorphExtension methodsFor: 'accessing - layout properties' stamp: 'gvc 9/11/2009 16:47'! layoutPolicy: aLayoutPolicy layoutPolicy := aLayoutPolicy! ! !MorphExtension methodsFor: 'accessing - layout properties' stamp: 'gvc 9/11/2009 18:12'! layoutProperties ^layoutProperties! ! !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: '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: 'accessing - other properties' stamp: 'md 2/27/2006 08:42'! hasProperty: aSymbol "Answer whether the receiver has the property named aSymbol" | property | otherProperties ifNil: [^ false]. property := otherProperties at: aSymbol ifAbsent: []. property isNil ifTrue: [^ false]. property == false ifTrue: [^ false]. ^ true! ! !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 - other properties' stamp: 'dgd 2/16/2003 21:04'! otherProperties "answer the receiver's otherProperties" ^ otherProperties! ! !MorphExtension methodsFor: 'accessing - other properties' stamp: 'md 2/27/2006 08:37'! removeOtherProperties "Remove the 'other' properties" otherProperties := nil! ! !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: '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 - other properties' stamp: 'MarcusDenker 9/7/2010 16:59'! 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 isNil ifFalse: [props nextPut: #balloonText]. externalName isNil ifFalse: [props nextPut: #externalName]. eventHandler isNil ifFalse: [props nextPut: #eventHandler]. otherProperties ifNotNil: [otherProperties associationsDo: [:a | props nextPut: a key]]. ^props contents sort: [:s1 :s2 | s1 <= s2]! ! !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 - 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 - 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: '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: '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: '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: '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: 'initialization' stamp: 'StephaneDucasse 7/18/2010 16:28'! initialize locked := false. visible := true. sticky := false. ! ! !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: 'other' stamp: 'MarcusDenker 9/7/2010 17:00'! 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 isNil ifFalse: [^ false]. externalName isNil ifFalse: [^ false]. eventHandler isNil ifFalse: [^ false]. otherProperties ifNotNil: [otherProperties isEmpty ifFalse: [^ false]]. ^ true! ! !MorphExtension methodsFor: 'printing' stamp: 'SvenVanCaekenberghe 12/4/2012 19:03'! 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 , ' ] ']. eventHandler ifNotNil: [aStream nextPutAll: ' [eventHandler = ' , eventHandler printString , '] ']. (otherProperties isNil or: [otherProperties isEmpty ]) ifTrue: [^ self]. aStream nextPutAll: ' [other: '. self otherProperties keysDo: [:aKey | aStream nextPutAll: ' (' , aKey , ' -> ' , (self otherProperties at: aKey) printString , ')']. aStream nextPut: $]! ! !MorphExtension methodsFor: 'viewer' stamp: 'di 8/10/1998 14:47'! externalName ^ externalName! ! Morph subclass: #MorphFrameGhost instanceVariableNames: 'target startGap location' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Windows'! !MorphFrameGhost commentStamp: 'AlainPlantec 2/22/2012 23:23' prior: 0! 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 ! !MorphFrameGhost 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! ! !MorphFrameGhost 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! ! !MorphFrameGhost methodsFor: 'accessing' stamp: 'AlainPlantec 2/22/2012 18:56'! target ^ target! ! !MorphFrameGhost methodsFor: 'accessing' stamp: 'AlainPlantec 2/22/2012 23:31'! target: aSystemWindow target := aSystemWindow. self color: (target paneColor alpha: 0.35). self bounds: aSystemWindow bounds. self currentHand newMouseFocus: self! ! !MorphFrameGhost 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! ! !MorphFrameGhost methodsFor: 'event handling' stamp: 'AlainPlantec 2/22/2012 22:12'! draggedTo: aPoint self position: aPoint + startGap ! ! !MorphFrameGhost methodsFor: 'event handling' stamp: 'AlainPlantec 2/22/2012 23:17'! handlesMouseDown: evt ^ true! ! !MorphFrameGhost methodsFor: 'event handling' stamp: 'AlainPlantec 2/22/2012 23:09'! mouseDown: evt "Normally, should not be possible" self delete ! ! !MorphFrameGhost methodsFor: 'event handling' stamp: 'AlainPlantec 2/22/2012 22:29'! mouseMove: evt self isForDragging ifTrue: [self draggedTo: evt position] ifFalse: [self reframedTo: evt position] ! ! !MorphFrameGhost 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! ! !MorphFrameGhost methodsFor: 'event handling' stamp: 'AlainPlantec 2/22/2012 22:18'! reframedTo: aPoint self bounds: (self bounds withSideOrCorner: location setToPoint: aPoint)! ! !MorphFrameGhost methodsFor: 'initialize' stamp: 'AlainPlantec 2/22/2012 23:31'! initialize super initialize. self color: (Color gray alpha: 0.15). self borderWidth: 2. self borderColor: Color gray. ! ! !MorphFrameGhost methodsFor: 'testing' stamp: 'AlainPlantec 2/22/2012 22:28'! isForDragging ^ location isNil! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MorphFrameGhost class instanceVariableNames: ''! !MorphFrameGhost 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! ! !MorphFrameGhost 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 ! ! MorphAnnouncement subclass: #MorphGotFocus instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Announcements'! !MorphGotFocus commentStamp: '' prior: 0! I'm an announcement raised when a morph gets keyboard focus. ! Morph subclass: #MorphHandlingMiddleButton instanceVariableNames: 'menu receivedBlueButtonUp receivedBlueButtonDown' classVariableNames: '' poolDictionaries: '' category: 'SUnit-UITesting'! !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: 'meta-actions' stamp: 'SeanDeNigris 12/14/2011 15:17'! handlerForBlueButtonDown: anEvent ^ self.! ! !MorphHandlingMiddleButton methodsFor: 'testing' stamp: 'SeanDeNigris 12/14/2011 15:21'! wasClickedWithMiddleButton ^ receivedBlueButtonDown and: [ receivedBlueButtonUp ].! ! ListItemWrapper subclass: #MorphListItemWrapper instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Widgets'! !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.! ! !MorphListItemWrapper methodsFor: 'converting' stamp: 'dgd 9/26/2004 18:26'! asString "Answer the string representation of the receiver" ^ item externalName! ! MorphAnnouncement subclass: #MorphLostFocus instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Announcements'! !MorphLostFocus commentStamp: '' prior: 0! I'm an announcement raised when a morph losts keyboard focus.! MorphAnnouncement subclass: #MorphOpened instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Announcements'! !MorphOpened commentStamp: '' prior: 0! 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.! TestCase subclass: #MorphTest instanceVariableNames: 'morph world' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Kernel'! !MorphTest commentStamp: '' prior: 0! This is the unit test for the class Morph. Unit tests are a good way to exercise the functionality of your system in a repeatable and automatic manner. They are therefore recommended if you plan to release anything. For more information, see: - http://www.c2.com/cgi/wiki?UnitTest - http://minnow.cc.gatech.edu/squeak/1547 - the sunit class category! !MorphTest 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 - classification' stamp: 'md 4/16/2003 17:11'! testIsMorph self assert: (morph isMorph).! ! !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 - initialization' stamp: 'md 4/16/2003 17:10'! testOpenInWorld self shouldnt: [morph openInWorld] raise: Error.! ! !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 - 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 - 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). ! ! Announcement subclass: #MorphTreeAnnounce instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-MorphTreeWidget'! MorphTreeNavigationBar subclass: #MorphTreeChunkPager instanceVariableNames: 'atBottom lastIndex pageSizeEditor nextPageAllowed' classVariableNames: '' poolDictionaries: '' category: 'Morphic-MorphTreeWidget-Pagination'! !MorphTreeChunkPager methodsFor: 'accessing' stamp: 'AlainPlantec 1/21/2010 11:44'! atBottom ^ atBottom ifNil: [atBottom := false]! ! !MorphTreeChunkPager methodsFor: 'accessing' stamp: 'AlainPlantec 1/22/2010 10:59'! atBottom: aBoolean atBottom ~= aBoolean ifTrue: [atBottom := aBoolean] ! ! !MorphTreeChunkPager methodsFor: 'accessing' stamp: 'AlainPlantec 1/22/2010 10:38'! computedHeight ^ self nodeList size > self lastIndex ifTrue: [super computedHeight ] ifFalse:[0]! ! !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: 'accessing' stamp: 'tg 1/21/2010 23:26'! currentNodelist ^ self nodeList copyFrom: 1 to: (self lastIndex min: self nodeList size)! ! !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: 'initailize-release' stamp: 'AlainPlantec 1/21/2010 21:54'! updateContents treeMorph vIsScrollable ifFalse: [self atBottom: true]. super updateContents! ! !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: 'navigation' stamp: 'AlainPlantec 1/21/2010 21:42'! fullList self lastIndex < self nodeList size ifTrue: [self nextPage: self nodeList size]! ! !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: '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: '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 ]! ! !MorphTreeChunkPager methodsFor: 'scrolling' stamp: 'AlainPlantec 1/22/2010 16:17'! initialize super initialize. nextPageAllowed := true! ! !MorphTreeChunkPager methodsFor: 'testing' stamp: 'AlainPlantec 1/21/2010 11:44'! notOnLastPage ^ self onLastPage not! ! !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 11:00'! vScrollBarValue: scrollValue | old | old := atBottom. self atBottom: (scrollValue < self verticalScrollbarFrontier) not. old ~= atBottom ifTrue: [self buildPanel] ! ! !MorphTreeChunkPager methodsFor: 'user interface' stamp: 'AlainPlantec 1/22/2010 10:57'! verticalScrollbarFrontier ^ 0.98! ! Object subclass: #MorphTreeColumn instanceVariableNames: 'header container currentWidth rowMorphGetSelector shrinkWrap color isPotentialDropTarget resizable' classVariableNames: '' poolDictionaries: '' category: 'Morphic-MorphTreeWidget'! !MorphTreeColumn methodsFor: 'accessing' stamp: 'AlainPlantec 11/12/2009 08:01'! asDraggableMorph ^ self thumbnailOfSize: self header fullBounds extent ! ! !MorphTreeColumn methodsFor: 'accessing' stamp: 'AlainPlantec 11/12/2009 08:02'! 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 image: f! ! !MorphTreeColumn methodsFor: 'as yet unclassified' 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/17/2009 19:12'! asPotentialDropTarget isPotentialDropTarget := true. self container invalidRect: self visibleBounds! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/17/2009 19:44'! color ^ color ifNil: [self container columnColors at: ((self index \\ 2) + 1)]! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/17/2009 18:52'! color: aColor color := aColor! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/11/2009 09:47'! container ^ container! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/3/2009 16:38'! container: aTreeMorph container := aTreeMorph! ! !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/11/2009 10:15'! currentWidth ^ currentWidth ifNil: [currentWidth := self defaultWidth]! ! !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 18:54'! dataBounds ^ self visibleBounds withTop: self container topHeader bottom! ! !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: 'AlainPlantec 11/11/2009 10:15'! defaultWidth ^ 100! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/18/2009 10:22'! fixedWidth: anInteger currentWidth := anInteger. resizable := false! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/18/2009 10:47'! forceWidthTo: 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/11/2009 20:55'! header: aMorph header := aMorph clipSubmorphs: true; yourself. header model: self! ! !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/1/2010 19:30'! headerButtonLabel: aLabel font: aFont self headerButton. self header label: aLabel font: aFont. ! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 2/1/2010 19:30'! headerButtonLabel: aLabel font: aFont icon: anIconForm target: aReceiver actionSelector: aSelector arguments: aCollection self headerButton. self header label: aLabel font: aFont. self header addMorphFront: (ImageMorph new image: anIconForm). self header actionSelector: aSelector. self header target: aReceiver. self header arguments: aCollection ! ! !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: 'column drawing' stamp: 'AlainPlantec 1/28/2010 08:08'! headerButtonLabel: aLabel icon: anIconForm self headerButtonLabel: aLabel font: nil. self header cellInset: 3@0. self header addMorphFront: (ImageMorph new image: anIconForm)! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/11/2009 21:07'! index ^ self container columns indexOf: self! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/17/2009 19:11'! isPotentialDropTarget ^ isPotentialDropTarget ifNil: [isPotentialDropTarget := false]! ! !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 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: '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 9/30/2011 16:03'! rowMorphFor: aNode | rowMorph | rowMorph := self rowMorphGetSelector ifNil: [aNode rowMorphForColumn: self] ifNotNil: [self rowMorphGetterBlock value: aNode value: self container]. rowMorph ifNotNil: [rowMorph borderWidth: 0] ifNil: [rowMorph := self defaultRowMorph]. ^ rowMorph rowMorphForNode: aNode inColumn: self ! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/9/2009 19:04'! rowMorphGetSelector ^ rowMorphGetSelector! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/9/2009 19:05'! rowMorphGetSelector: aSelector rowMorphGetSelector := aSelector! ! !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: 'AlainPlantec 11/18/2009 11:48'! shrinkWrap ^ shrinkWrap ifNil: [shrinkWrap := false]! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/18/2009 11:48'! shrinkWrap: aBoolean shrinkWrap := aBoolean! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/11/2009 10:16'! startWidth: anInteger currentWidth := anInteger! ! !MorphTreeColumn methodsFor: 'column drawing' stamp: 'AlainPlantec 11/12/2009 07:57'! visibleBounds ^ self header bounds withBottom: self container scroller bottom! ! !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: 'geometry' stamp: 'AlainPlantec 11/4/2009 21:52'! height ^ header ifNil: [0] ifNotNil: [header height]! ! !MorphTreeColumn methodsFor: 'initialize-release' stamp: 'AlainPlantec 11/3/2009 22:16'! release container := nil. header := nil. super release.! ! !MorphTreeColumn methodsFor: 'testing' stamp: 'IgorStasenko 4/6/2011 16:31'! isFirstColumn ^ container columns first = self! ! !MorphTreeColumn methodsFor: 'testing' stamp: 'AlainPlantec 1/23/2010 12:37'! isLastColumn ^ container columns last = self! ! SimpleButtonMorph subclass: #MorphTreeColumnButton instanceVariableNames: 'model' classVariableNames: '' poolDictionaries: '' category: 'Morphic-MorphTreeWidget'! !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: '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: 'AlainPlantec 11/14/2009 08:58'! wantsDroppedMorph: aMorph event: anEvent ^ model container columnDropUnabled and: [(aMorph isKindOf: TransferMorph) and: [(aMorph passenger isKindOf: MorphTreeColumn) and: [aMorph passenger ~= self model]]]! ! !MorphTreeColumnButton methodsFor: 'dropping/grabbing' stamp: 'AlainPlantec 11/12/2009 06:58'! handlesMouseOverDragging: evt ^ true! ! !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: 'dropping/grabbing' stamp: 'AlainPlantec 11/12/2009 07:09'! mouseLeaveDragging: evt self noMorePotentialDropTarget ! ! !MorphTreeColumnButton methodsFor: 'dropping/grabbing' stamp: 'AlainPlantec 11/12/2009 07:09'! mouseUp: evt self noMorePotentialDropTarget. super mouseUp: evt! ! !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: 'event handling' stamp: 'ThierryGoubier 10/24/2012 17:29'! startDrag: anEvent | aTransferMorph | self dragEnabled ifFalse: [^ self]. (anEvent hand hasSubmorphs) ifTrue: [^ self]. oldColor ifNotNil: [ self fillStyle: oldColor. oldColor := nil]. aTransferMorph := TransferMorph withPassenger: self model from: self. aTransferMorph align: aTransferMorph draggedMorph center with: anEvent position. anEvent hand grabMorph: aTransferMorph. anEvent hand releaseMouseFocus: self! ! !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: 'initialization' stamp: 'AlainPlantec 11/11/2009 20:56'! model ^ model! ! !MorphTreeColumnButton methodsFor: 'initialization' stamp: 'AlainPlantec 11/11/2009 20:56'! model: anObject model := anObject! ! Object subclass: #MorphTreeListManager instanceVariableNames: 'keystrokeActionSelector multipleSelection autoMultiSelection potentialDropMorph firstClickedMorph lastClickedMorph columnDropUnabled doubleClickBlock autoDeselection searchedElement lastKeystrokeTime lastKeystrokes lastSelection client isSelectionUpdateFromView isCheckList autoTargetMorph selectedMorphList' classVariableNames: '' poolDictionaries: '' category: 'Morphic-MorphTreeWidget'! !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'! autoDeselection: aBoolean autoDeselection := aBoolean! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 16:18'! autoMultiSelection ^ autoMultiSelection ifNil: [autoMultiSelection := false]! ! !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:42'! client: aMorphList client := aMorphList! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 14:59'! columnDropUnabled ^ columnDropUnabled! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 14:59'! columnDropUnabled: aBoolean columnDropUnabled := aBoolean! ! !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: 'AlainPlantec 10/7/2011 14:59'! firstClickedMorph ^ firstClickedMorph! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 15:00'! firstClickedMorph: aNodeMorph firstClickedMorph := aNodeMorph! ! !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 17:35'! isCheckList ^ isCheckList ifNil: [isCheckList := false]! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 17:35'! isCheckList: aBoolean isCheckList := aBoolean! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 16:11'! isMultiple ^ multipleSelection ifNil: [ multipleSelection := false ]! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 14:59'! keystrokeActionSelector ^ keystrokeActionSelector! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 15:00'! keystrokeActionSelector: aSelectorOrBlock keystrokeActionSelector := aSelectorOrBlock! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 14:59'! lastClickedMorph ^ lastClickedMorph! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 15:00'! lastClickedMorph: aNodeMorph lastClickedMorph := aNodeMorph! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 14:59'! lastKeystrokeTime ^ lastKeystrokeTime! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 14:59'! lastKeystrokeTime: anObject lastKeystrokeTime := anObject! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 14:59'! lastKeystrokes ^ lastKeystrokes! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 14:59'! lastKeystrokes: anObject lastKeystrokes := anObject! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 14:59'! lastSelection ^ lastSelection! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 14:59'! lastSelection: anObject lastSelection := anObject! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 16:05'! listModel ^ client model! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 17:19'! multipleSelection ^ multipleSelection ifNil: [multipleSelection := false]! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 14:59'! multipleSelection: anObject multipleSelection := anObject! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 23:09'! nodeMorphsWithAllNodeItems: aNodeItemList ^ self allNodeMorphs select: [:m | aNodeItemList includes: m complexContents withoutListWrapper]! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 14:59'! potentialDropMorph ^ potentialDropMorph! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 14:59'! potentialDropMorph: anObject potentialDropMorph := anObject! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 14:59'! searchedElement ^ searchedElement! ! !MorphTreeListManager methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 14:59'! searchedElement: anObject searchedElement := anObject! ! !MorphTreeListManager methodsFor: 'client list accessing' stamp: 'AlainPlantec 10/7/2011 23:41'! allNodeMorphs ^ client allNodeMorphs! ! !MorphTreeListManager methodsFor: 'client list accessing' stamp: 'AlainPlantec 10/7/2011 23:24'! commandOrCrontrolKeyPressed: anEvent ^ client commandOrCrontrolKeyPressed: anEvent! ! !MorphTreeListManager methodsFor: 'client list accessing' stamp: 'AlainPlantec 10/7/2011 23:41'! numSelectionsInView ^ client numSelectionsInView! ! !MorphTreeListManager methodsFor: 'client list accessing' stamp: 'AlainPlantec 10/7/2011 23:22'! scrollToShow: aRectangle client scrollToShow: aRectangle! ! !MorphTreeListManager methodsFor: 'initialize-release' stamp: 'AlainPlantec 10/7/2011 17:40'! initialize super initialize. lastKeystrokeTime := 0. lastKeystrokes := ''. lastSelection := 0! ! !MorphTreeListManager methodsFor: 'keyboard managing' stamp: 'AlainPlantec 11/5/2011 11:06'! 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. 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: 'keyboard managing' stamp: 'SvenVanCaekenberghe 1/8/2012 14:46'! 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 item 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: 'keyboard managing' stamp: 'AlainPlantec 10/7/2011 23:52'! keyStroke: anEvent | char args | char := anEvent keyValue asCharacter. (self arrowEvent: anEvent key: char) ifTrue: [^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: 'keyboard managing' stamp: 'AlainPlantec 10/8/2011 23:21'! setSelectionIndexFromKeyboard: index multiSelection: multiSelect event: anEvent "Called internally to select the index-th item." | targetMorph nodes | 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]]. lastClickedMorph := firstClickedMorph := targetMorph. anEvent shiftPressed ifTrue: [lastClickedMorph highlightForMouseDown: true]. self selectionChanged. self scrollToShow: targetMorph ! ! !MorphTreeListManager methodsFor: 'mouse managing' stamp: 'AlainPlantec 10/8/2011 14:15'! doubleClick: anEvent on: aMorph doubleClickBlock ifNil: [^false]. doubleClickBlock value. ^ true! ! !MorphTreeListManager methodsFor: 'mouse managing' stamp: 'AlainPlantec 10/8/2011 22:40'! mouseDown: event on: aTargetMorph "Changed to take keybaord focus." | targetMorph | ((self autoMultiSelection) and: [event shiftPressed not]) ifTrue: [ firstClickedMorph := aTargetMorph. lastClickedMorph := aTargetMorph. aTargetMorph selected ifTrue: [self removeFromSelection: aTargetMorph] ifFalse: [self addToSelection: aTargetMorph]]. (event shiftPressed not or: [firstClickedMorph isNil]) ifTrue: [firstClickedMorph := aTargetMorph] ! ! !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: 'AlainPlantec 10/7/2011 23:24'! mouseUp: event on: aNodeMorph | path cmdOrCtrl | "No change if model is locked" 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])]]. self selectionUpdateFromViewWhile: [ | selHolder | selHolder := self newSelectionHolderWithNodePath: path. self listModel selection: selHolder]. lastClickedMorph := aNodeMorph. self selectionChanged. ! ! !MorphTreeListManager methodsFor: 'selection accessing' stamp: 'AlainPlantec 10/7/2011 15:53'! selectedMorph ^ self selectedMorphList ifNotEmpty: [ :l | l last] ifEmpty: [] ! ! !MorphTreeListManager methodsFor: 'selection accessing' stamp: 'AlainPlantec 10/8/2011 23:50'! selectedMorphList ^ selectedMorphList ifNil: [selectedMorphList := LinkedList new]! ! !MorphTreeListManager methodsFor: 'selection change' stamp: 'AlainPlantec 10/7/2011 21:53'! addAllToSelection: aCollection self searchedElement: nil. aCollection do: [:m | m highlight. m selected: true]. ! ! !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: 'AlainPlantec 10/7/2011 22:48'! autoAction ^ firstClickedMorph ifNotNil: [ firstClickedMorph selected ifTrue: [#addToSelection:] ifFalse: [#removeFromSelection:]]. ! ! !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: '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: '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: '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: 'AlainPlantec 10/7/2011 16:55'! isSelectionUpdateFromView ^ isSelectionUpdateFromView ifNil: [isSelectionUpdateFromView := false] ! ! !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: '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: 'selection change' stamp: 'AlainPlantec 10/7/2011 23:10'! selectAll | selHolder | self allNodeMorphs isEmpty ifTrue: [^ self]. self isMultiple ifFalse: [^ self]. self addAllToSelection: self allNodeMorphs. self selectionChanged. self selectionUpdateFromViewWhile: [ selHolder := self newSelectionHolderWithNodePath: (self allNodeMorphs last path collect: [:m | m complexContents]). self listModel selection: selHolder]. ! ! !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 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: 'AlainPlantec 10/7/2011 21:55'! selectMorph: aNodeMorph multiple: withMultipleSelection | path mult | 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: 'AlainPlantec 10/7/2011 21:53'! selectedItems: aNodeItemCollection self listModel okToDiscardEdits ifFalse: [^ self]. self emptySelection. self addAllToSelection: (self nodeMorphsWithAllNodeItems: aNodeItemCollection). lastClickedMorph ifNil: [lastClickedMorph := self selectedMorphList ifEmpty: [] ifNotEmpty: [self selectedMorphList last]]! ! !MorphTreeListManager methodsFor: 'selection change' stamp: 'AlainPlantec 10/7/2011 16:09'! selectionChanged client selectionChanged ! ! !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: 'ThierryGoubier 9/30/2012 12:44'! setSelectedMorph: aMorph | path | path := aMorph ifNotNil: [aMorph path collect: [:m | m complexContents]]. lastClickedMorph := aMorph. self emptySelection. aMorph isNil ifFalse: [self addToSelection: lastClickedMorph]. self selectionUpdateFromViewWhile: [ | selHolder | selHolder := self newSelectionHolderWithNodePath: path. self listModel selection: selHolder] ! ! !MorphTreeListManager methodsFor: 'selection change' stamp: 'AlainPlantec 10/7/2011 21:52'! shiftSelectMorph: aNodeMorph | m | m := aNodeMorph ifNil: [self allNodeMorphs last]. self emptySelection. self searchedElement: nil. self from: firstClickedMorph to: m do: [:nd | self addToSelection: nd]. lastClickedMorph := m. ^ m path collect: [:p | p complexContents]! ! !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 17:02'! updateSelectionFromModel (self listModel selection) ifNotNil: [:selHolder | self isSelectionUpdateFromView ifTrue: [ self listModel selectionChanged. self selectionChanged] ifFalse: [selHolder updateView: client forModel: self listModel]]. ! ! Model subclass: #MorphTreeModel instanceVariableNames: 'selection announcer rootItems autoMultiSelection headerLabel multiSelection wrapBlockOrSelector isCheckList' classVariableNames: '' poolDictionaries: '' category: 'Morphic-MorphTreeWidget'! !MorphTreeModel commentStamp: '' prior: 0! I'm the base class for tree models. See ClassListExample for basic usage.! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/10/2011 22:56'! announcer ^ announcer ifNil: [announcer := Announcer new]! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/11/2011 11:28'! autoMultiSelection ^ autoMultiSelection ifNil: [autoMultiSelection := false]! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/11/2011 10:56'! autoMultiSelection: aBoolean autoMultiSelection := aBoolean ! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/11/2011 11:08'! beCheckList self isCheckList: true ! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/30/2011 17:08'! collapseAll self changed: #(#rootNodes #collapseAll). ! ! !MorphTreeModel methodsFor: 'accessing'! deeplyDetect: aBlock self rootNodes do: [:sub | (sub deeplyDetect: aBlock) ifNotNil: [:found | ^ found]]. ^ nil ! ! !MorphTreeModel methodsFor: 'accessing'! expandAll self changed: #(#rootNodes #expandAll )! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/30/2011 17:08'! expandAllFromNode: aNode self changed: {#rootNodes. #expandAllFromNode:. aNode} ! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/11/2011 10:57'! headerLabel: aString headerLabel := aString! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/11/2011 11:03'! isCheckList ^ isCheckList ifNil: [isCheckList := false]! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/11/2011 11:03'! isCheckList: aBoolean ^ isCheckList := aBoolean! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/11/2011 10:57'! keyStroke: anEvent anEvent keyString = '' ifTrue: [ self selectAll ]. anEvent keyString = '' ifTrue: [ self deselectAll ]! ! !MorphTreeModel methodsFor: 'accessing'! keyStroke: anEvent from: aTreeView! ! !MorphTreeModel methodsFor: 'accessing'! menu: menu shifted: b ^ menu! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/11/2011 11:28'! multiSelection ^ multiSelection ifNil: [multiSelection := false]! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/11/2011 10:57'! multiSelection: aBoolean multiSelection := aBoolean! ! !MorphTreeModel methodsFor: 'accessing'! okToDiscardEdits ^ self canDiscardEdits or: [self promptForCancel]! ! !MorphTreeModel methodsFor: 'accessing'! 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: 'AlainPlantec 10/11/2011 10:53'! rootItems ^ rootItems ifNil: [ rootItems := {} ]! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/11/2011 10:54'! rootItems: aCollection rootItems := aCollection. ! ! !MorphTreeModel methodsFor: 'accessing'! rootNodeClassFromItem: anItem ^ MorphTreeNodeModel! ! !MorphTreeModel methodsFor: 'accessing'! rootNodeFromItem: anItem ^ (self rootNodeClassFromItem: anItem) with: anItem model: self! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/10/2011 11:25'! rootNodes ^ (self rootItems ifNil: [^nil]) collect: [:ci | self rootNodeFromItem: ci]. ! ! !MorphTreeModel methodsFor: 'accessing'! selectAllNodePaths: aCollectionOfNodePath self selection: (MorphTreeMorphMultipleSelection new selectedNodePathList: aCollectionOfNodePath)! ! !MorphTreeModel methodsFor: 'accessing'! selectItems: aListOfItems self changed: {#selectItems. aListOfItems}! ! !MorphTreeModel methodsFor: 'accessing'! selectNodePath: aNodePath self selection: (MorphTreeMorphSingleSelection new selectedNodePath: aNodePath)! ! !MorphTreeModel methodsFor: 'accessing'! selectedItem ^ self selectedNode ifNotNil: [:node | node item]! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/2/2011 16:08'! selectedItems ^ selection ifNil: [OrderedCollection new] ifNotNil: [selection selectedItems]! ! !MorphTreeModel methodsFor: 'accessing'! selectedNode ^ self selectedNodePath ifNotNil: [:path | path ifEmpty: [nil] ifNotEmpty: [path last]]! ! !MorphTreeModel methodsFor: 'accessing'! selectedNodePath ^ self selection ifNotNil: [:s | s lastSelectedNodePath]! ! !MorphTreeModel methodsFor: 'accessing'! selection: aSelection self setSelection: aSelection. self changed: #selection. ! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/10/2011 11:30'! treeMorphClass ^ MorphTreeMorph ! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/11/2011 10:57'! wrapBlockOrSelector ^ wrapBlockOrSelector ifNil: [wrapBlockOrSelector := #printString]! ! !MorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/11/2011 10:57'! wrapBlockOrSelector: aBlockOrSelector wrapBlockOrSelector := aBlockOrSelector! ! !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: 'announcing' stamp: 'AlainPlantec 10/11/2011 11:51'! onSelectionChangeSend: aSelector to: anObject self announcer on: MorphTreeSelectionChanged send: aSelector to: anObject! ! !MorphTreeModel methodsFor: 'dialog' stamp: 'AlainPlantec 10/2/2011 16:59'! dialogWindowIn: aWindow title: aTitle ^ self dialogWindowIn: aWindow title: aTitle selectedtems: Array new! ! !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 methodsFor: 'dialog' stamp: 'AlainPlantec 10/11/2011 10:57'! headerLabel ^ headerLabel! ! !MorphTreeModel methodsFor: 'dialog' stamp: 'AlainPlantec 10/7/2011 10:58'! openDialogWindowIn: aWindow title: aTitle ^ self openDialogWindowIn: aWindow title: aTitle selectedtems: Array new! ! !MorphTreeModel methodsFor: 'dialog' stamp: 'AlainPlantec 10/9/2011 14:22'! openDialogWindowIn: aWindow title: aTitle selectedtems: aCollection | dialog treeMorph | dialog := self dialogWindowIn: aWindow title: aTitle selectedtems: aCollection. aWindow openModal: dialog. ^ dialog cancelled ifFalse: [self selectedItems] ! ! !MorphTreeModel methodsFor: 'selecting' stamp: 'AlainPlantec 9/29/2011 00:08'! deselectAll self changed: #deselectAll! ! !MorphTreeModel methodsFor: 'selecting' stamp: 'AlainPlantec 9/29/2011 00:08'! selectAll self changed: #selectAll! ! !MorphTreeModel methodsFor: 'selecting' stamp: 'AlainPlantec 11/18/2009 08:17'! selection ^ selection. ! ! !MorphTreeModel methodsFor: 'selecting' stamp: 'AlainPlantec 10/11/2011 11:48'! selectionChanged self announcer announce: (MorphTreeSelectionChanged new selection: self selection)! ! !MorphTreeModel methodsFor: 'selecting' stamp: 'AlainPlantec 1/29/2010 09:33'! setSelection: aSelection selection := aSelection. ! ! !MorphTreeModel methodsFor: 't - accessing'! chunkSize: anIntegerOrNil self setPageSize: anIntegerOrNil. self changed: #chunkSize ! ! !MorphTreeModel methodsFor: 't - accessing'! defaultChunkSize ^ nil! ! !MorphTreeModel methodsFor: 't - accessing'! defaultPageSize ^ nil! ! !MorphTreeModel methodsFor: 't - accessing'! pageSize: anIntegerOrNil self setPageSize: anIntegerOrNil. self changed: #pageSize ! ! !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: '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 class instanceVariableNames: ''! !MorphTreeModel class methodsFor: 'accessing' stamp: 'FernandoOlivero 4/12/2011 10:18'! theme ^ UITheme current ! ! !MorphTreeModel class methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 10/11/2011 11:11'! itemsList: itemsList ^ self new rootItems: itemsList; yourself! ! !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: '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: 'examples' stamp: 'AlainPlantec 10/11/2011 11:11'! checkListExample2 "self checkListExample2" | model | model := self new rootItems: Morph methodDict values. model wrapBlockOrSelector: #selector; autoMultiSelection: true; headerLabel: 'Plop'; beCheckList. ^ (model openDialogWindowIn: World title: 'All Morph methods') ! ! !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]! ! ScrollPane subclass: #MorphTreeMorph instanceVariableNames: 'columns potentialDropMorph rowInset columnInset columnResizers withHLines preferedPaneColor indentGap expandedToggleImage notExpandedToggleImage resizerWidth gapAfterToggle hasToggleAtRoot topHeader topHeaderBackground unboundLastColumn columnDropUnabled columnColors rowColors nodeList iconBlock treeLineWidth lineColorBlock treeLineDashes listManager mouseOverAllowed maxNodeWidth' classVariableNames: '' poolDictionaries: '' category: 'Morphic-MorphTreeWidget'! !MorphTreeMorph commentStamp: 'AlainPlantec 2/13/2010 07:41' prior: 0! 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: '*Keymapping-Core' stamp: 'ThierryGoubier 9/15/2012 22:30'! initializeShortcuts: aKMDispatcher super initializeShortcuts: aKMDispatcher. aKMDispatcher attachCategory: #MorphFocusNavigation! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 1/31/2010 22:26'! allNodeMorphs "all list morphs" ^ scroller submorphs ! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 10/10/2011 11:04'! currentNodelist "The nodeList currently viewed " ^ self nodeList! ! !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 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: '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: '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: 'accessing' stamp: 'AlainPlantec 10/8/2011 17:42'! getList "Answer the full list to be displayed." ^ model rootNodes. ! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 9/30/2011 16:14'! hasIconBlock ^ iconBlock notNil! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 10/29/2009 10:07'! hasToggleAtRoot ^ hasToggleAtRoot ifNil: [hasToggleAtRoot := self roots anySatisfy: [:s | s hasToggle]] ! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/1/2010 09:02'! iconBlock ^ iconBlock ifNil: [[:node | node icon]]! ! !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: 'accessing' stamp: 'AlainPlantec 11/15/2009 21:58'! indentingItemClass ^ MorphTreeNodeMorph! ! !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: 'accessing' stamp: 'AlainPlantec 10/7/2011 16:16'! keystrokeActionSelector: aSelector self listManager keystrokeActionSelector: aSelector! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 10/7/2011 18:02'! listManager ^ listManager ifNil: [listManager := MorphTreeListManager new client: self] ! ! !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: 'accessing' stamp: 'AlainPlantec 1/18/2010 17:49'! nodeList ^ nodeList ifNil: [nodeList := self getList] ! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 1/18/2010 17:31'! nodeList: aCollection nodeList := aCollection. ! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 10/1/2011 12:49'! nodeListSelector ^ #rootNodes ! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/5/2010 23:04'! nodeMorphOfNode: aNode ^ self allNodeMorphs detect: [:m | m complexContents = aNode] ifNone: []! ! !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: 'accessing' stamp: 'AlainPlantec 10/6/2011 16:58'! roots "Answer the receiver's roots" ^ self rootsFrom: self allNodeMorphs ! ! !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: 'accessing' stamp: 'AlainPlantec 11/8/2009 18:41'! topHeader ^ topHeader ! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/9/2009 15:25'! topHeaderBackground ^ topHeaderBackground ifNil: [topHeaderBackground := Color transparent]! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/9/2009 10:54'! topHeaderBackground: aFillStyle topHeaderBackground := aFillStyle! ! !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 2/3/2010 10:04'! treeLineDashes ^ treeLineDashes ifNil: [treeLineDashes := self theme treeLineDashes] ! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/3/2010 10:04'! treeLineDashes: anArrayOfInteger treeLineDashes := anArrayOfInteger ! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 10/29/2009 10:08'! withHLines ^ withHLines ifNil: [withHLines := false]! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 10/29/2009 10:08'! withHLines: aBoolean withHLines := aBoolean! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/2/2010 16:31'! withTreeLines ^ self treeLineWidth > 0! ! !MorphTreeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/2/2010 16:33'! withTreeLines: aBoolean self treeLineWidth: 1! ! !MorphTreeMorph methodsFor: 'accessing colors' stamp: 'AlainPlantec 10/11/2011 00:19'! adoptPaneColor: paneColor "Pass on to the selection, the border" super adoptPaneColor: paneColor. paneColor ifNil: [^self]. self color: (self preferedPaneColor ifNil: [paneColor veryMuchLighter]). ! ! !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: '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 colors' stamp: 'AlainPlantec 11/17/2009 19:47'! columnColorForOdd: oddColor columnColors at: 1 put: nil. columnColors at: 2 put: oddColor. ! ! !MorphTreeMorph methodsFor: 'accessing colors' stamp: 'AlainPlantec 11/17/2009 19:40'! columnColors ^ columnColors ! ! !MorphTreeMorph methodsFor: 'accessing colors' stamp: 'AlainPlantec 2/3/2010 09:46'! lineColor: aColor lineColorBlock := [:node | aColor] ! ! !MorphTreeMorph methodsFor: 'accessing colors' stamp: 'AlainPlantec 2/3/2010 09:45'! lineColorBlock ^ lineColorBlock ! ! !MorphTreeMorph methodsFor: 'accessing colors' stamp: 'AlainPlantec 2/3/2010 09:45'! lineColorBlock: aValuable lineColorBlock := aValuable ! ! !MorphTreeMorph methodsFor: 'accessing colors' stamp: 'AlainPlantec 2/3/2010 09:44'! 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." | colored | ^ lineColorBlock ifNotNil: [lineColorBlock value: aNode] ifNil: [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 colors' stamp: 'AlainPlantec 10/29/2009 10:08'! preferedPaneColor ^ preferedPaneColor! ! !MorphTreeMorph methodsFor: 'accessing colors' stamp: 'AlainPlantec 10/29/2009 10:08'! preferedPaneColor: aColor self color: (preferedPaneColor := aColor). ! ! !MorphTreeMorph methodsFor: 'accessing colors' stamp: 'AlainPlantec 4/28/2011 22:32'! rowColorForEven: evenColor rowColors at: 1 put: evenColor. ! ! !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 4/28/2011 22:32'! rowColorForOdd: oddColor rowColors at: 2 put: oddColor. ! ! !MorphTreeMorph methodsFor: 'accessing colors' stamp: 'AlainPlantec 11/20/2009 16:59'! rowColors ^ rowColors! ! !MorphTreeMorph methodsFor: 'as yet unclassified' 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:23'! addColumn: aTreeColumn "add a column" self addColumn: aTreeColumn afterIndex: self columns size! ! !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: '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: '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: '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: '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: '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: '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: 'column handling' stamp: 'AlainPlantec 2/12/2010 21:34'! columns: aListOfTreeColumn "set the columns - as a consequence, the topHeader is update (if present) and column resizers are added" columns := aListOfTreeColumn asOrderedCollection. aListOfTreeColumn do: [:col | col container: self]. self buildTopHeader . self addColumnResizers. ! ! !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 9/30/2011 17:22'! 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 @ topHeader top corner: (scroller right) @ topHeader bottom)]. ^ controlBounds ! ! !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: '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: '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: '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 22:04'! removeColumn: aTreeColumn "Remove a column - rough implementation" self removeColumnAtIndex: (self columns indexOf: aTreeColumn)! ! !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: '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: '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/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: '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: '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: 'drawing' stamp: 'AlainPlantec 10/6/2011 10:19'! drawOn: aCanvas super drawOn: aCanvas. self columns do: [:col | col drawColumnOn: aCanvas]. ! ! !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: '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: 'dropping/grabbing' stamp: 'AlainPlantec 2/12/2010 21:46'! forbidColumnDrop "Do not allow column drag and drop" columnDropUnabled := false! ! !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: '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: 'dropping/grabbing' stamp: 'AlainPlantec 2/12/2010 21:22'! resetPotentialDropMorph "release the current drop morph candidate" potentialDropMorph ifNotNil: [ potentialDropMorph resetHighlightForDrop. potentialDropMorph := nil] ! ! !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: 'enumeration' stamp: 'alain.plantec 10/24/2009 23:08'! childrenDo: aBlock self roots do: aBlock! ! !MorphTreeMorph methodsFor: 'event handling' stamp: 'alain.plantec 10/12/2009 23:25'! handlesKeyboard: evt ^true! ! !MorphTreeMorph methodsFor: 'event handling' stamp: 'AlainPlantec 10/9/2011 15:08'! handlesMouseOver: evt ^ self mouseOverAllowed ! ! !MorphTreeMorph methodsFor: 'event handling' stamp: 'alain.plantec 10/12/2009 23:25'! handlesMouseOverDragging: evt ^self dropEnabled! ! !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: '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: 'event handling' stamp: 'AlainPlantec 10/9/2011 15:07'! mouseOverAllowed ^ mouseOverAllowed ifNil: [mouseOverAllowed := false]! ! !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: 'events-processing' stamp: 'AlainPlantec 11/1/2009 22:28'! commandOrCrontrolKeyPressed: anEvent ^ (OSPlatform current platformFamily ~= #MacOSX) ifTrue: [anEvent controlKeyPressed] ifFalse: [anEvent commandKeyPressed]! ! !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: '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: '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: 'events-processing' stamp: 'AlainPlantec 10/9/2011 15:07'! mouseDown: event "Changed to take keybaord focus." | targetMorph selectors | 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: '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: '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: '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: 'events-processing' stamp: 'AlainPlantec 10/9/2011 00:41'! mouseMove: evt | targetMorph | 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: '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: 'events-processing' stamp: 'AlainPlantec 10/10/2011 22:17'! mouseStillDownStepRate "At what rate do I want to receive #mouseStillDown: notifications?" ^10! ! !MorphTreeMorph methodsFor: 'events-processing' stamp: 'AlainPlantec 10/9/2011 15:08'! mouseUp: event "Fixed up highlight problems." | nodeMorph wasHigh selHolder | 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: '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: 'ThierryGoubier 10/24/2012 17:47'! 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. itemMorph ~= self listManager selectedMorph ifTrue: [self listManager setSelectedMorph: itemMorph]. passenger := self model dragPassengerFor: itemMorph inMorph: self. passenger ifNotNil: [ aTransferMorph := TransferMorph withPassenger: 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: 'events-processing' stamp: 'alain.plantec 10/12/2009 23:25'! takesKeyboardFocus "Answer whether the receiver can normally take keyboard focus." ^true! ! !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: 'events-processing' stamp: 'CamilloBruni 2/4/2012 14:45'! yellowButtonEvent: anEvent (self scrollerSubMorphFromPoint: anEvent position) ifNotNil: [:sel | sel selected ifFalse: [self listManager setSelectedMorph: sel]. ^ self yellowButtonActivity: anEvent shiftPressed ]. ^ false! ! !MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: 'AlainPlantec 10/9/2011 19:41'! collapseAll self updateContentsWithPreviouslyExpanded: Array new. ! ! !MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: 'AlainPlantec 1/31/2010 22:23'! currentlyExpanded ^ self expandedNodesFrom: (self allNodeMorphs). ! ! !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: '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: 'expanding-collapsing' stamp: 'AlainPlantec 2/17/2010 13:31'! expandAll "Expand all of the roots!!" Cursor wait showWhile: [ self roots reverseDo: [:m | self expandAllSilently: m]. self innerWidgetChanged]! ! !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: '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: 'expanding-collapsing' stamp: 'AlainPlantec 2/17/2010 15:56'! expandAllFromNode: aNode Cursor wait showWhile: [ self expandAll: ((self nodeMorphOfNode: aNode) ifNil: [^self]). self adjustSubmorphPositions] ! ! !MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: 'MarcusDenker 10/28/2010 14:03'! expandAllSilently: aMorph | subs | aMorph isExpanded ifFalse: [aMorph expand]. aMorph childrenDo: [:ch | self expandAllSilently: ch]. ! ! !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: 'expanding-collapsing' stamp: 'AlainPlantec 2/2/2010 22:24'! expandAllTo: aLevel self roots do: [:m | self expand: m to: aLevel]. self innerWidgetChanged! ! !MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: 'AlainPlantec 11/9/2009 17:55'! expandRoots "Expand all the receiver's roots" self roots do: [:each | (each canExpand and: [each isExpanded not]) ifTrue: [each toggleExpandedState]]. self innerWidgetChanged! ! !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: 'expanding-collapsing' stamp: 'alain.plantec 10/12/2009 23:25'! expandedForm "Answer the form to use for expanded items." ^self theme treeExpandedForm! ! !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: 'expanding-collapsing' stamp: 'AlainPlantec 1/22/2010 18:38'! expandedNodesFrom: aMorpList ^ (aMorpList select: [ :each | each isExpanded]) collect: [ :each | each complexContents]. ! ! !MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: 'AlainPlantec 10/29/2009 10:07'! expandedToggleImage ^ expandedToggleImage ifNil: [expandedToggleImage := ImageMorph new image: self expandedForm]. ! ! !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: '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: 'expanding-collapsing' stamp: 'AlainPlantec 10/29/2009 10:08'! notExpandedToggleImage ^ notExpandedToggleImage ifNil: [notExpandedToggleImage := ImageMorph new image: self notExpandedForm]. ! ! !MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: 'AlainPlantec 10/29/2009 10:08'! toggleImageHeight ^ self expandedToggleImage height max: self notExpandedToggleImage height.! ! !MorphTreeMorph methodsFor: 'expanding-collapsing' stamp: 'AlainPlantec 10/29/2009 10:08'! toggleImageWidth ^ self expandedToggleImage width max: self notExpandedToggleImage width.! ! !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: '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: 'geometry' stamp: 'AlainPlantec 10/11/2011 00:37'! extent: newExtent super extent: newExtent. self resizerChanged. ! ! !MorphTreeMorph methodsFor: 'geometry' stamp: 'AlainPlantec 1/31/2010 22:56'! gapAfterToggle "horizontal space after the toggle" ^ gapAfterToggle ifNil: [gapAfterToggle := 5]! ! !MorphTreeMorph methodsFor: 'geometry' stamp: 'AlainPlantec 1/31/2010 22:57'! gapAfterToggle: anInteger "set the horizontal space after the toggle" gapAfterToggle := anInteger. ! ! !MorphTreeMorph methodsFor: 'geometry' stamp: 'AlainPlantec 10/29/2009 10:07'! indentGap ^ indentGap ifNil: [indentGap := 20]! ! !MorphTreeMorph methodsFor: 'geometry' stamp: 'AlainPlantec 11/15/2009 18:16'! indentGap: anInteger indentGap := anInteger. ! ! !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: 'geometry' stamp: 'AlainPlantec 10/11/2011 10:25'! maxNodeWidth ^ maxNodeWidth ifNil: [maxNodeWidth := 0]! ! !MorphTreeMorph methodsFor: 'geometry' stamp: 'AlainPlantec 11/3/2009 17:29'! minResizerOffset ^ 20! ! !MorphTreeMorph methodsFor: 'geometry' stamp: 'AlainPlantec 11/17/2009 16:25'! minResizerX ^ scroller left + self minResizerOffset! ! !MorphTreeMorph methodsFor: 'geometry' stamp: 'AlainPlantec 1/27/2010 11:25'! resizerWidth ^ resizerWidth ifNil:[resizerWidth := 3]! ! !MorphTreeMorph methodsFor: 'geometry' stamp: 'AlainPlantec 11/15/2009 18:16'! resizerWidth: anInteger resizerWidth := anInteger. ! ! !MorphTreeMorph methodsFor: 'geometry' stamp: 'AlainPlantec 1/25/2010 08:34'! rowInset ^ rowInset ifNil: [rowInset := 0] ! ! !MorphTreeMorph methodsFor: 'geometry' stamp: 'AlainPlantec 1/25/2010 08:34'! rowInset: anInteger rowInset := anInteger. ! ! !MorphTreeMorph methodsFor: 'geometry' stamp: 'AlainPlantec 2/2/2010 16:31'! treeLineWidth ^ treeLineWidth ifNil: [treeLineWidth := self theme treeLineWidth] ! ! !MorphTreeMorph methodsFor: 'geometry' stamp: 'AlainPlantec 2/2/2010 16:30'! treeLineWidth: anInteger treeLineWidth := anInteger! ! !MorphTreeMorph methodsFor: 'initialize - release' 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: '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: '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: 'scrolling' stamp: 'AlainPlantec 10/10/2011 20:06'! newTransformMorph ^ MorphTreeTransformMorph new ! ! !MorphTreeMorph methodsFor: 'scrolling' stamp: 'AlainPlantec 10/11/2011 13:26'! scrollDeltaHeight ^ super scrollDeltaHeight ! ! !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: '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/7/2011 17:12'! autoDeselection: trueOrFalse "Enable/disable autoDeselect (see class comment)" self listManager autoDeselection: trueOrFalse! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'AlainPlantec 10/7/2011 16:18'! autoMultiSelection ^ self listManager autoMultiSelection! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'AlainPlantec 10/7/2011 16:19'! autoMultiSelection: aBoolean self listManager autoMultiSelection: aBoolean! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'AlainPlantec 10/11/2011 11:06'! beCheckList self isCheckList: true. ! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'AlainPlantec 10/7/2011 16:25'! beMultiple self listManager multipleSelection: true! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'AlainPlantec 10/8/2011 13:50'! beSingle self listManager multipleSelection: false! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'AlainPlantec 10/7/2011 21:34'! deselectAll self listManager deselectAll! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'AlainPlantec 10/8/2011 23:48'! emptySelection self listManager emptySelection! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'AlainPlantec 10/11/2011 11:06'! isCheckList: aBoolean self listManager isCheckList: aBoolean. ! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'AlainPlantec 11/18/2009 07:29'! isSingle ^ self isMultiple not! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'AlainPlantec 10/7/2011 17:17'! multiSelection: aBoolean self listManager multipleSelection: aBoolean! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'BenjaminVanRyseghem 4/4/2011 16:34'! secondarySelectionColor ^ self theme settings secondarySelectionColor! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'AlainPlantec 10/7/2011 21:34'! selectAll self listManager selectAll! ! !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: 'selection' stamp: 'AlainPlantec 10/7/2011 21:43'! selectedItems: aNodeItemCollection self listManager selectedItems: aNodeItemCollection! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'AlainPlantec 10/7/2011 18:29'! selectedMorph ^ self listManager selectedMorph! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'AlainPlantec 10/8/2011 23:50'! selectedMorphList ^ self listManager selectedMorphList! ! !MorphTreeMorph methodsFor: 'selection' stamp: 'AlainPlantec 2/12/2011 19:32'! selectionChanged self changed ! ! !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: '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: 'selection' stamp: 'AlainPlantec 12/18/2009 22:20'! selectionColorToUse "Answer the colour to use for selected items." ^self valueOfProperty: #selectionColorToUse ifAbsent: [self theme settings selectionColor] ! ! !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: '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: 'sorting' stamp: 'AlainPlantec 10/8/2011 09:41'! itemSortBlock: aValuable self deprecated: 'Moved into the TreeModel' on: 'Oct 8 2011' in: 'Pharo1.4'. ! ! !MorphTreeMorph methodsFor: 'sorting' stamp: 'AlainPlantec 10/8/2011 09:36'! nodeSortBlock: aValuable self deprecated: 'Moved into the TreeModel' on: 'Oct 8 2011' in: 'Pharo1.4'. ! ! !MorphTreeMorph methodsFor: 'sorting' stamp: 'AlainPlantec 10/8/2011 17:40'! sortingSelector: aSelectorWithNoArgs self deprecated: 'Le list/tree can be sorted by the model itself' on: 'Oct 8 2011' in: 'Pharo1.4'. ! ! !MorphTreeMorph methodsFor: 'submorphs-add/remove' stamp: 'AlainPlantec 10/9/2011 00:10'! 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]. "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 ! ! !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: 'submorphs-add/remove' stamp: 'AlainPlantec 10/6/2011 22:24'! addSubmorphsFromNodeList self addSubmorphsFromNodeList: self currentNodelist previouslyExpanded: #() ! ! !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: 'updating' stamp: 'AlainPlantec 10/11/2011 10:22'! adjustSubmorphPositions maxNodeWidth := 0. ^ self adjustSubmorphPositionsOf: self allNodeMorphs startIdx: 1 startPos: 0@0 ! ! !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: '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: '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: 'updating' stamp: 'AlainPlantec 10/3/2011 00:29'! innerWidgetChanged self setScrollDeltas. self updateColumnMorphsWidth. self adjustSubmorphPositions. ! ! !MorphTreeMorph methodsFor: 'updating' stamp: 'AlainPlantec 10/9/2011 17:00'! insertNewMorphs: morphList scroller addAllMorphs: morphList. ! ! !MorphTreeMorph methodsFor: 'updating' stamp: 'ThierryGoubier 10/1/2012 13:07'! noteRemovalOfAll: aCollection "TODO: update the selection as well" scroller removeAllMorphsIn: aCollection. self selectedMorphList do: [:each | (aCollection includes: each) ifTrue: [self listManager removeFromSelection: each]]. self adjustSubmorphPositions ! ! !MorphTreeMorph methodsFor: 'updating' stamp: 'AlainPlantec 10/3/2011 11:11'! privateUpdateColumnMorphs self resetRootInfo. self updateTopHeader. self innerWidgetChanged. ! ! !MorphTreeMorph methodsFor: 'updating' stamp: 'AlainPlantec 11/15/2009 18:02'! removeTopHeader topHeader ifNotNil: [self removeMorph: topHeader. topHeader := nil] ! ! !MorphTreeMorph methodsFor: 'updating' stamp: 'AlainPlantec 10/29/2009 10:08'! resetRootInfo hasToggleAtRoot := nil.! ! !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: 'updating' stamp: 'AlainPlantec 10/10/2011 11:23'! update: aSymbol aSymbol == #selection ifTrue: [^ self listManager updateSelectionFromModel]. ((aSymbol isKindOf: Array) and: [aSymbol size > 1 and: [aSymbol first == #selectItems and: [aSymbol second isCollection]]]) ifTrue: [^ self selectedItems: aSymbol second]. aSymbol == self nodeListSelector ifTrue: [^ self updateList]. aSymbol == #selectAll ifTrue: [^ self listManager selectAll]. aSymbol == #deselectAll ifTrue: [^ self listManager deselectAll]. ((aSymbol isKindOf: Array) and: [aSymbol size > 1 and: [aSymbol first == self nodeListSelector and: [ aSymbol second == #openPath]]]) "allow directed path opening where multiple trees exist" ifTrue: [^(self allNodeMorphs at: 1 ifAbsent: [^self]) openPath: (aSymbol allButFirst: 2)]. ((aSymbol isKindOf: Array) and: [aSymbol size > 1 and: [aSymbol first == self nodeListSelector and: [ aSymbol second == #openItemPath]]]) "allow directed path opening where multiple trees exist" ifTrue: [^ (self allNodeMorphs at: 1 ifAbsent: [^self]) openItemPath: (aSymbol allButFirst: 2)]. ((aSymbol isKindOf: Array) and: [aSymbol size > 1 and: [aSymbol first == self nodeListSelector and: [ aSymbol second == #expandAllFromNode:]]]) ifTrue: [^ self expandAllFromNode: aSymbol third]. ((aSymbol isKindOf: Array) and: [aSymbol size > 1 and: [aSymbol first == self nodeListSelector and: [ aSymbol second == #closeItemPath]]]) "allow directed path closing where multiple trees exist" ifTrue: [^ (self allNodeMorphs at: 1 ifAbsent: [^self]) closeItemPath: (aSymbol allButFirst: 2)]. ((aSymbol isKindOf: Array) and: [aSymbol notEmpty and: [aSymbol first == #openPath]]) ifTrue: [^(self allNodeMorphs at: 1 ifAbsent: [^self]) openPath: aSymbol allButFirst]. ((aSymbol isKindOf: Array) and: [aSymbol size = 2 and: [aSymbol first = self nodeListSelector and: [ aSymbol second == #expandRoots]]]) ifTrue: [^self expandRoots]. ((aSymbol isKindOf: Array) and: [aSymbol size = 2 and: [aSymbol first = self nodeListSelector]]) ifTrue: [aSymbol second = #expandAll ifTrue: [^ self expandAll]. aSymbol second = #collapseAll ifTrue: [^ self collapseAll]]! ! !MorphTreeMorph methodsFor: 'updating' stamp: 'AlainPlantec 10/6/2011 10:46'! updateColumnMorphs self privateUpdateColumnMorphs ! ! !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/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: '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: '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: 'updating' stamp: 'AlainPlantec 10/8/2011 22:55'! updateFromSelection: aSelection aSelection selectedNodePathList do: [:path | self selectNodePath: path]. self scrollSelectionIntoView! ! !MorphTreeMorph methodsFor: 'updating' stamp: 'AlainPlantec 1/22/2010 19:04'! updateList self updateContentsWithPreviouslyExpanded: self currentlyExpanded ! ! !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 class instanceVariableNames: ''! !MorphTreeMorph class methodsFor: 'instance creation' stamp: 'AlainPlantec 2/17/2010 22:37'! on: anObject ^ self new model: anObject ! ! MorphTreeMorphSelection subclass: #MorphTreeMorphMultipleSelection instanceVariableNames: 'selectedNodePathList' classVariableNames: '' poolDictionaries: '' category: 'Morphic-MorphTreeWidget'! !MorphTreeMorphMultipleSelection methodsFor: 'accessing' stamp: 'AlainPlantec 9/27/2011 13:55'! addNodePath: aPath self selectedNodePathList add: aPath! ! !MorphTreeMorphMultipleSelection methodsFor: 'accessing' stamp: 'AlainPlantec 9/27/2011 23:01'! empty self selectedNodePathList: OrderedCollection new ! ! !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:06'! removeNode: aNode self selectedNodePathList remove: aNode path ifAbsent: [] ! ! !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 ]! ! !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 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:13'! selectedNodes ^ OrderedCollection withAll: self selectedNodeList ! ! Object subclass: #MorphTreeMorphSelection instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-MorphTreeWidget'! !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 9/27/2011 23:00'! empty 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 11/26/2009 07:26'! lastSelectedNodePath ^ self subclassResponsibility! ! !MorphTreeMorphSelection methodsFor: 'accessing' stamp: 'AlainPlantec 9/27/2011 23:04'! removeNode: aNode self subclassResponsibility ! ! !MorphTreeMorphSelection methodsFor: 'accessing' stamp: 'AlainPlantec 11/25/2009 18:11'! selectedItemOrItemsOrNil ^ self lastSelectedNode isNil ifTrue: [ nil ] ifFalse: [ self lastSelectedNode item ]! ! !MorphTreeMorphSelection methodsFor: 'accessing' stamp: 'AlainPlantec 9/27/2011 13:28'! selectedItems ^ self selectedNodes collect: [:n | n item] ! ! !MorphTreeMorphSelection methodsFor: 'accessing' stamp: 'AlainPlantec 12/1/2009 06:36'! selectedNodePathList ^ self subclassResponsibility! ! !MorphTreeMorphSelection methodsFor: 'accessing' stamp: 'AlainPlantec 9/27/2011 13:28'! selectedNodes ^ self lastSelectedNode ifNotNil: [:l | OrderedCollection with: l] ifNil: [OrderedCollection new]! ! !MorphTreeMorphSelection methodsFor: 'view updating' stamp: 'AlainPlantec 10/7/2011 17:02'! updateView: aTreeMorph forModel: aTreeModel aTreeMorph updateFromSelection: self. aTreeModel selectionChanged! ! MorphTreeMorphSelection subclass: #MorphTreeMorphSingleSelection instanceVariableNames: 'selectedNodePath' classVariableNames: '' poolDictionaries: '' category: 'Morphic-MorphTreeWidget'! !MorphTreeMorphSingleSelection methodsFor: 'accessing' stamp: 'AlainPlantec 9/27/2011 13:54'! addNodePath: aPath self selectedNodePath: aPath! ! !MorphTreeMorphSingleSelection methodsFor: 'accessing' stamp: 'AlainPlantec 9/27/2011 23:00'! empty 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:05'! removeNode: aNode self selectedNodePath = aNode path ifTrue: [self selectedNodePath: nil]! ! !MorphTreeMorphSingleSelection methodsFor: 'accessing' stamp: 'AlainPlantec 11/26/2009 07:24'! selectedNodePath ^ selectedNodePath! ! !MorphTreeMorphSingleSelection methodsFor: 'accessing' stamp: 'AlainPlantec 11/26/2009 07:11'! selectedNodePath: aSelectionPath selectedNodePath := aSelectionPath! ! !MorphTreeMorphSingleSelection methodsFor: 'accessing' stamp: 'AlainPlantec 12/1/2009 08:31'! selectedNodePathList ^ self selectedNodePath ifNil: [#()] ifNotNil: [Array with: self selectedNodePath]! ! BorderedMorph subclass: #MorphTreeNavigationBar instanceVariableNames: 'treeMorph pageSize computedHeight withSearch pageSearchText' classVariableNames: '' poolDictionaries: '' category: 'Morphic-MorphTreeWidget-Pagination'! !MorphTreeNavigationBar commentStamp: '' prior: 0! 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: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/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/19/2010 18:52'! buildPanel self subclassResponsibility! ! !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: 'MarcusDenker 10/28/2010 14:03'! computedBounds | bw tb tsb tbw li 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 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: 'accessing' stamp: 'AlainPlantec 1/19/2010 18:44'! nodeList ^ treeMorph nodeList! ! !MorphTreeNavigationBar methodsFor: 'accessing' stamp: 'AlainPlantec 1/19/2010 18:45'! pageSearchText ^ pageSearchText ifNil: [pageSearchText := '']! ! !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'! pageSize ^ pageSize! ! !MorphTreeNavigationBar methodsFor: 'accessing' stamp: 'AlainPlantec 1/19/2010 18:45'! pageSize: anInteger pageSize := anInteger! ! !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/19/2010 18:45'! pagerColor ^ treeMorph pagerColor! ! !MorphTreeNavigationBar methodsFor: 'accessing' stamp: 'AlainPlantec 1/22/2010 08:49'! preferedFont ^ self balloonFont ! ! !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/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 treeMorph := aTreeMorph. ! ! !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:47'! withSearch ^ withSearch ifNil: [withSearch := false]! ! !MorphTreeNavigationBar methodsFor: 'accessing' stamp: 'AlainPlantec 1/19/2010 18:47'! withSearch: aBoolean withSearch := aBoolean. self buildPanel! ! !MorphTreeNavigationBar methodsFor: 'initalize-release' 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: 'navigation' stamp: 'AlainPlantec 1/22/2010 10:27'! computedHeightFromContents | h | h := 0. self submorphsDo: [:sm | h := h max: sm height]. ^ h ! ! !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: 'navigation' stamp: 'AlainPlantec 1/21/2010 21:56'! updateForNewPageSize: aPageSize pageSize := aPageSize max: 1. self changed: #pageSize! ! !MorphTreeNavigationBar methodsFor: 'user interface' stamp: 'AlainPlantec 1/21/2010 11:45'! vScrollBarValue: scrollValue ! ! !MorphTreeNavigationBar methodsFor: 'private' stamp: 'AlainPlantec 1/22/2010 14:46'! handlesMouseDown: anEvent ^ true! ! !MorphTreeNavigationBar methodsFor: 'private' stamp: 'AlainPlantec 1/22/2010 14:45'! mouseDown: anEvent! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MorphTreeNavigationBar class instanceVariableNames: ''! !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'! 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'! 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: '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'! 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'! 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: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: 'instance creation' stamp: 'AlainPlantec 1/19/2010 18:47'! on: aTreeMorph pageSize: aPageSize ^ self new treeMorph: aTreeMorph pageSize: aPageSize! ! ListItemWrapper subclass: #MorphTreeNodeModel instanceVariableNames: 'parentNode' classVariableNames: '' poolDictionaries: '' category: 'Morphic-MorphTreeWidget'! !MorphTreeNodeModel commentStamp: '' prior: 0! 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: 'accessing' stamp: 'AlainPlantec 2/8/2010 09:39'! childNodeClassFromItem: anItem ^ self class! ! !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/19/2010 15:43'! childrenItems ^ Array new! ! !MorphTreeNodeModel methodsFor: 'accessing' stamp: 'AlainPlantec 11/20/2009 21:25'! color ^ nil! ! !MorphTreeNodeModel methodsFor: 'accessing' stamp: 'AlainPlantec 1/19/2010 15:26'! contents ^ self childrenItems collect: [:ci | self childNodeFromItem: ci ]! ! !MorphTreeNodeModel methodsFor: 'accessing' stamp: 'AlainPlantec 11/25/2009 11:12'! enabled ^ true! ! !MorphTreeNodeModel methodsFor: 'accessing' stamp: 'AlainPlantec 1/18/2010 21:21'! includesSubstringAnywhere: aString ^ (Array with: self asString) includesSubstringAnywhere: aString! ! !MorphTreeNodeModel methodsFor: 'accessing' stamp: 'AlainPlantec 2/3/2010 09:52'! level ^ parentNode ifNil: [1] ifNotNil: [parentNode level + 1]! ! !MorphTreeNodeModel methodsFor: 'accessing' stamp: 'AlainPlantec 11/24/2009 14:07'! model: anObject model := anObject! ! !MorphTreeNodeModel methodsFor: 'accessing' stamp: 'AlainPlantec 1/15/2010 13:41'! parentNode ^ parentNode! ! !MorphTreeNodeModel methodsFor: 'accessing' stamp: 'AlainPlantec 1/16/2010 14:49'! parentNode: aNode parentNode := aNode! ! !MorphTreeNodeModel methodsFor: 'accessing' stamp: 'AlainPlantec 2/5/2010 23:00'! path ^ self pathIn: OrderedCollection new.! ! !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 10/11/2011 00:55'! rowMorphForColumn: aTreeColumn ^ self item ifNotNil: [:i | self asString asMorph] ! ! !MorphTreeNodeModel methodsFor: 'printing' stamp: 'AlainPlantec 10/8/2011 23:37'! printOn: aStream aStream nextPutAll: 'Node('. self item printOn: aStream. aStream nextPut: $)! ! Morph subclass: #MorphTreeNodeMorph instanceVariableNames: 'parent index indentLevel isExpanded complexContents firstChild container nextSibling controls lineColor selected' classVariableNames: '' poolDictionaries: '' category: 'Morphic-MorphTreeWidget'! !MorphTreeNodeMorph commentStamp: '' prior: 0! I draw the node part of a tree.! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'alain.plantec 3/7/2009 09:29'! balloonText ^complexContents balloonText ifNil: [super balloonText]! ! !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: 'accessing' stamp: 'AlainPlantec 9/28/2011 23:37'! checkGap ^ 2! ! !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 9/28/2011 23:39'! checkWidth ^ 10! ! !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 2/5/2010 09:16'! color ^ complexContents color ifNil: [self index ifNotNil: [container rowColors at: ((self index \\ 2) + 1)]]! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 12/2/2009 17:27'! columnMorphAt: anIndex ^ controls at: anIndex ! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'alain.plantec 3/7/2009 09:29'! complexContents ^complexContents! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/9/2009 19:36'! controls ^ controls! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'alain.plantec 3/7/2009 09:29'! firstChild ^firstChild! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'IgorStasenko 4/6/2011 16:48'! icon "answer the receiver's icon" ^ container iconBlock value: self complexContents. ! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'alain.plantec 3/10/2009 13:16'! indentGap ^ container indentGap * indentLevel! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'alain.plantec 3/7/2009 09:29'! indentLevel ^indentLevel! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/5/2010 21:58'! index ^ index ! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/20/2009 17:19'! index: anInteger index := anInteger! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'alain.plantec 3/7/2009 09:29'! isExpanded: aBoolean isExpanded := aBoolean! ! !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: '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: '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: 'accessing' stamp: 'alain.plantec 3/7/2009 09:29'! nextSibling ^nextSibling! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'alain.plantec 3/7/2009 09:29'! nextSibling: anotherMorph nextSibling := anotherMorph! ! !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: 'alain.plantec 10/23/2009 15:35'! parent ^ parent! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'alain.plantec 10/23/2009 15:36'! parent: aNodeMorph parent := aNodeMorph! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 10/29/2009 16:44'! path ^ parent ifNil: [OrderedCollection with: self] ifNotNil: [(parent path) add: self; yourself]! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/12/2009 06:42'! rowMorphAt: anIndex ^ self submorphs seconds submorphs at: anIndex! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 9/28/2011 09:44'! selected ^ selected ifNil: [selected := false]! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 10/8/2011 23:49'! selected: aBoolean selected = aBoolean ifTrue: [^ self]. aBoolean ifTrue: [container selectedMorphList add: self] ifFalse: [selected ifNotNil: [container selectedMorphList remove: self]]. selected := aBoolean. ! ! !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 10/10/2011 09:12'! sensitiveToggleRectangle ^(bounds left + self indentGap) @ bounds top extent: (container toggleImageWidth + container gapAfterToggle) @ bounds height! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 10/8/2011 23:43'! setSelectedSilently: aBoolean selected := aBoolean. ! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 10/9/2011 18:25'! spacerWidth | sRect baseRect | sRect := bounds. baseRect := self mustTakeIntoAccountCheckSpace ifTrue: [self checkRectangle] ifFalse: [self toggleRectangle]. (self mustTakeIntoAccountToggleSpace or: [self mustTakeIntoAccountCheckSpace]) ifTrue: [sRect := sRect withLeft: baseRect right + container gapAfterToggle] ifFalse: [sRect := sRect withLeft: baseRect left]. ^ sRect left - bounds left. ! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'alain.plantec 3/7/2009 09:29'! theme "Answer the ui theme that provides controls. Done directly here to avoid performance hit of looking up in window." ^UITheme current! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/11/2011 15:45'! toggleImageForm ^ isExpanded ifTrue: [container expandedFormForMorph: self] ifFalse: [container notExpandedFormForMorph: self] ! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 10/10/2011 10:46'! toggleRectangle ^(bounds left + self indentGap) @ bounds top extent: (container toggleImageWidth) @ bounds height! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/3/2010 10:05'! treeLineDashes ^ container treeLineDashes! ! !MorphTreeNodeMorph methodsFor: 'accessing' stamp: 'alain.plantec 3/7/2009 09:29'! withoutListWrapper ^complexContents withoutListWrapper! ! !MorphTreeNodeMorph methodsFor: 'change reporting' stamp: 'AlainPlantec 10/10/2011 23:43'! invalidRect: aRectangle ! ! !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: 'drawing' stamp: 'AlainPlantec 9/28/2011 23:28'! drawCheckOn: aCanvas in: aRectangle | center offset dRect | center := aRectangle center. offset := ((self checkWidth) / 2.0) truncated. dRect := (center x - offset) @ (center y - offset) corner: (center x + offset) @ (center y + offset). self selected ifTrue: [ aCanvas frameAndFillRectangle: dRect fillColor: Color gray borderWidth: 1 borderColor: Color black] ifFalse: [ aCanvas frameAndFillRectangle: dRect fillColor: Color white borderWidth: 1 borderColor: Color black]! ! !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 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: '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: '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: 'drawing' stamp: 'AlainPlantec 9/29/2011 13:41'! drawMouseDownHighlightOn: aCanvas "Draw with a dotted border." self highlightedForMouseDown ifTrue: [ container ifNil: [^super drawMouseDownHighlightOn: aCanvas]. aCanvas frameRectangle: self selectionFrame width: 1 colors: {container mouseDownHighlightColor. Color transparent} dashes: #(1 1)]! ! !MorphTreeNodeMorph methodsFor: 'drawing' stamp: 'AlainPlantec 10/10/2011 22:07'! 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 in: self checkRectangle]. ! ! !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: '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: 'initialization' stamp: 'AlainPlantec 10/11/2011 00:03'! initRow self buildRowMorph. self layoutChanged ! ! !MorphTreeNodeMorph methodsFor: 'initialization' stamp: 'IgorStasenko 4/6/2011 17:00'! initWithContents: anObject prior: priorMorph forList: hostList indentLevel: newLevel container := hostList. self cellInset: (container resizerWidth @ 0). complexContents := anObject. isExpanded := false. nextSibling := firstChild := nil. priorMorph ifNotNil: [priorMorph nextSibling: self]. indentLevel := newLevel. self initRow ! ! !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: 'layout' stamp: 'AlainPlantec 10/9/2011 18:38'! fullBounds fullBounds ifNotNil: [^ fullBounds]. ^ submorphs ifEmpty: [bounds] ifNotEmpty: [ self doLayoutIn: self layoutBounds. fullBounds]! ! !MorphTreeNodeMorph methodsFor: 'layout' stamp: 'AlainPlantec 10/9/2011 18:22'! layoutBounds "Return the bounds for laying out children of the receiver" | lb | lb := super layoutBounds. container ifNil: [ ^ lb ]. ^ lb withLeft: lb left + self spacerWidth ! ! !MorphTreeNodeMorph methodsFor: 'mouse events' stamp: 'AlainPlantec 10/7/2011 18:05'! handleMouseUp: anEvent (container commandOrCrontrolKeyPressed: anEvent) ifTrue: [^ container listManager mouseUp: anEvent on: self]. ^ super handleMouseUp: anEvent! ! !MorphTreeNodeMorph methodsFor: 'printing' stamp: 'AlainPlantec 10/8/2011 23:37'! printOn: aStream aStream nextPutAll: 'NodeMorph('. complexContents printOn: aStream. aStream nextPut: $)! ! !MorphTreeNodeMorph methodsFor: 'testing' stamp: 'alain.plantec 3/7/2009 09:29'! canExpand ^complexContents hasContents! ! !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: 'testing' stamp: 'alain.plantec 10/23/2009 12:15'! hasToggle ^ self canExpand! ! !MorphTreeNodeMorph methodsFor: 'testing' stamp: 'AlainPlantec 10/10/2011 09:12'! inToggleArea: aPoint ^self sensitiveToggleRectangle containsPoint: aPoint! ! !MorphTreeNodeMorph methodsFor: 'testing' stamp: 'alain.plantec 3/7/2009 09:29'! isExpanded ^isExpanded! ! !MorphTreeNodeMorph methodsFor: 'testing' stamp: 'alain.plantec 3/7/2009 09:29'! isFirstItem ^owner submorphs first == self! ! !MorphTreeNodeMorph methodsFor: 'testing' stamp: 'AlainPlantec 9/28/2011 09:58'! isSelected "^ container selectedMorphList includes: self" ^ self selected! ! !MorphTreeNodeMorph methodsFor: 'testing' stamp: 'alain.plantec 3/7/2009 09:29'! isSoleItem ^self isFirstItem and: [ owner submorphs size = 1 ]! ! !MorphTreeNodeMorph methodsFor: 'testing' stamp: 'AlainPlantec 10/7/2011 17:36'! mustTakeIntoAccountCheckSpace ^container listManager isCheckList! ! !MorphTreeNodeMorph methodsFor: 'testing' stamp: 'AlainPlantec 10/28/2009 22:57'! mustTakeIntoAccountToggleSpace ^ indentLevel > 0 or: [ container hasToggleAtRoot]! ! !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: 'updating' stamp: 'AlainPlantec 11/15/2009 17:18'! adoptPaneColor: aColor! ! !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: 'updating' stamp: 'alain.plantec 3/7/2009 09:29'! childrenDo: aBlock firstChild ifNotNil: [ firstChild withSiblingsDo: [ :aNode | aBlock value: aNode]. ]! ! !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: '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: '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: '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: '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: '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/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: 'updating' stamp: 'AlainPlantec 2/5/2010 22:50'! recursiveAddTo: aCollection firstChild ifNotNil: [firstChild withSiblingsDo: [ :aNode | aNode recursiveAddTo: aCollection]]. aCollection add: self. ! ! !MorphTreeNodeMorph methodsFor: 'updating' stamp: 'alain.plantec 3/7/2009 09:29'! recursiveDelete firstChild ifNotNil: [ firstChild withSiblingsDo: [ :aNode | aNode recursiveDelete]. ]. self delete ! ! !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: 'updating' stamp: 'AlainPlantec 11/15/2009 17:18'! themeChanged! ! !MorphTreeNodeMorph methodsFor: 'updating' stamp: 'AlainPlantec 10/10/2011 23:51'! toggleExpandedState | toDelete | isExpanded := 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: '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: 'updating' stamp: 'AlainPlantec 10/31/2009 08:51'! updateChildren self childrenDo: [:child | child parent: self] ! ! !MorphTreeNodeMorph methodsFor: 'updating' stamp: 'AlainPlantec 10/7/2011 21:05'! updateChildrenRecursively self childrenDo: [:child | child parent: self. child updateChildrenRecursively] ! ! !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: 'updating' stamp: 'AlainPlantec 10/11/2011 01:12'! withSiblingsDo: aBlock | node | node := self. [node isNil] whileFalse: [ aBlock value: node. node := node nextSibling].! ! MorphTreeNavigationBar subclass: #MorphTreePager instanceVariableNames: 'currentPageFirstIndex' classVariableNames: '' poolDictionaries: '' category: 'Morphic-MorphTreeWidget-Pagination'! !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: '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'! 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: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/19/2010 09:11'! currentPageFirstIndex ^ currentPageFirstIndex ifNil: [currentPageFirstIndex := 1]! ! !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: '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: '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: '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:15'! previousPage self currentPageFirstIndex > 1 ifTrue: [currentPageFirstIndex := (currentPageFirstIndex - pageSize) max: 1. self showCurrentPage]! ! !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 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: '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:12'! hasSeveralPages ^ self lastPage > 1! ! !MorphTreePager methodsFor: 'testing' stamp: 'AlainPlantec 1/19/2010 09:13'! notOnFirstPage ^ self onFirstPage not ! ! !MorphTreePager methodsFor: 'testing' stamp: 'AlainPlantec 1/19/2010 09:13'! notOnLastPage ^ self onLastPage not! ! !MorphTreePager methodsFor: 'testing' stamp: 'AlainPlantec 1/19/2010 09:14'! onFirstPage ^ self currentPageFirstIndex = 1! ! !MorphTreePager methodsFor: 'testing' stamp: 'AlainPlantec 1/19/2010 09:14'! onLastPage ^ self currentPageLastIndex = self nodeList size! ! !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: 'private' stamp: 'AlainPlantec 1/19/2010 10:37'! currentNodelist ^ self nodeList copyFrom: self currentPageFirstIndex to: self currentPageLastIndex! ! AbstractResizerMorph subclass: #MorphTreeResizerMorph instanceVariableNames: 'traceMorph oldColor index container' classVariableNames: '' poolDictionaries: '' category: 'Morphic-MorphTreeWidget'! !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: '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: 'Polymorph-Widgets' stamp: 'alain.plantec 3/9/2009 12:55'! shouldDraw ^ true! ! !MorphTreeResizerMorph methodsFor: 'Polymorph-Widgets' stamp: 'AlainPlantec 11/17/2009 16:47'! themeChanged "Update the fill style." self fillStyle: self normalFillStyle. super themeChanged! ! !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 11/17/2009 16:57'! getOldColor ^ oldColor ifNil: [Color transparent]! ! !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: 'alain.plantec 3/10/2009 14:09'! normalizedX: x ^ x! ! !MorphTreeResizerMorph methodsFor: 'as yet unclassified' stamp: 'alain.plantec 3/10/2009 14:09'! normalizedY: y ^y! ! !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: 'alain.plantec 3/9/2009 12:53'! resizeCursor ^ Cursor resizeForEdge: #left! ! !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: 'as yet unclassified' stamp: 'alain.plantec 3/11/2009 07:45'! splitsTopAndBottom ^ false! ! !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: 'dependents access' stamp: 'AlainPlantec 11/3/2009 22:25'! delete super delete. self release. ! ! !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: '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:01'! mouseEnter: anEvent self canResizeColumn ifFalse: [^ self]. (owner notNil and: [owner bounds containsPoint: anEvent position]) ifTrue: [super mouseEnter: anEvent]! ! !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 instanceVariableNames: ''! !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! ! MorphTreeAnnounce subclass: #MorphTreeSelectionChanged instanceVariableNames: 'selection' classVariableNames: '' poolDictionaries: '' category: 'Morphic-MorphTreeWidget'! !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! ! TransformMorph subclass: #MorphTreeTransformMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-MorphTreeWidget'! !MorphTreeTransformMorph methodsFor: 'change reporting' stamp: 'AlainPlantec 2/17/2010 16:02'! privateInvalidateMorph: aMorph ! ! !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: '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: 'drawing' stamp: 'AlainPlantec 10/10/2011 22:04'! drawRawColorOn: aCanvas forSubmorph: aSubMorph | c frame | frame := (aSubMorph fullBounds withRight: owner right + owner scroller offset x ). 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: 'IgorStasenko 12/22/2012 02:44'! 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]. ! ! !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/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: '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). ! ! !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: '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: 'initialization' stamp: 'AlainPlantec 10/11/2011 00:07'! initialize super initialize. self smoothingOn! ! !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: '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: '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: 'testing' stamp: 'AlainPlantec 10/10/2011 17:44'! wantsSteps ^ false! ! !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. ! ! ListItemWrapper subclass: #MorphWithSubmorphsWrapper instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Explorer'! !MorphWithSubmorphsWrapper commentStamp: 'ls 3/1/2004 17:32' prior: 0! 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 ]! ! Object subclass: #MorphWrapper instanceVariableNames: 'layout morph' classVariableNames: '' poolDictionaries: '' category: 'Spec-Widgets-Utilities'! !MorphWrapper commentStamp: '' prior: 0! 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: 'StephaneDucasse 12/21/2012 11:26'! frame: rectangle layout := rectangle asLayoutFrame! ! !MorphWrapper methodsFor: 'accessing'! fullFrame: anObject layout := anObject! ! !MorphWrapper methodsFor: 'accessing'! morph: anObject morph := anObject! ! !MorphWrapper methodsFor: 'adding'! addIn: aContainer aContainer addMorph: morph fullFrame: layout! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MorphWrapper class instanceVariableNames: ''! !MorphWrapper class methodsFor: 'instance creation'! morph: morph layout: layout ^ self new layout: layout; morph: morph; yourself! ! MessageSend subclass: #MorphicAlarm instanceVariableNames: 'scheduledTime numArgs' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Events'! !MorphicAlarm commentStamp: 'LaurentLaffont 3/4/2011 22:45' prior: 0! 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:44'! scheduledTime "Return the time (in milliseconds) that the receiver is scheduled to be executed" ^scheduledTime! ! !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: '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 instanceVariableNames: ''! !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.! ! AbstractBindings subclass: #MorphicBindings instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Spec-Bindings'! !MorphicBindings commentStamp: '' prior: 0! MorphicBindings is the class holding the bindings between Spec and Morphic! !MorphicBindings methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 7/31/2012 15:26'! initializeClassesDictionary ^ IdentityDictionary new at: #List put: #PluggableListMorph; at: #IconList put: #PluggableIconListMorph; at: #Text put: #PluggableTextMorph; at: #Button put: #PluggableButtonMorph; at: #Panel put: #PanelMorph; at: #Checkbox put: #CheckboxMorph; at: #DropList put: #DropListMorph; at: #TextField put: #PluggableTextFieldMorph; at: #Label put: #LabelMorph; at: #MultiColumnList put: #PluggableMultiColumnListMorph; at: #Tree put: #PluggableTreeMorph; at: #Slider put: #PluggableSliderMorph; at: #FrameLayout put: #LayoutFrame; at: #Window put: #StandardWindow; at: #DialogWindow put: #SpecDialogWindow; yourself! ! !MorphicBindings methodsFor: 'initialization' stamp: 'StephaneDucasse 12/21/2012 13:15'! initializeSelectorsDictionary ^ IdentityDictionary new at: #addSplitters put: #yourself; at: #add: put: #ensureLayoutAndAddMorph:; at: #layout: put: #layoutFrame:; at: #fractions:offsets: put: #fractions:offsets:; "deprecated in 2.0" at: #values: put: #fromArray:; at: #useProportionalLayout put: #changeProportionalLayout; at: #vSpaceFill put: #(vResizing: spaceFill); at: #hSpaceFill put: #(hResizing: spaceFill); at: #vShrinkWrap put: #(vResizing: shrinkWrap); at: #hShrinkWrap put: #(hResizing: shrinkWrap); at: #vRigid put: #(vResizing: rigid); at: #hRigid put: #(hResizing: rigid); at: #removeSubWidgets put: #removeAllMorphs; yourself! ! AbstractBindings subclass: #MorphicBindingsWithSplitters instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Spec-Bindings'! !MorphicBindingsWithSplitters commentStamp: '' prior: 0! MorphicBindingsWithSplitters is like MorphicBindings with splitters support in addition! !MorphicBindingsWithSplitters methodsFor: 'initialization'! initializeClassesDictionary ^ IdentityDictionary new at: #Panel put: #PanelMorphWithSplitters; yourself! ! !MorphicBindingsWithSplitters methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 3/23/2012 16:58'! initializeSelectorsDictionary ^ IdentityDictionary new at: #addSplitters put: #addPaneSplitters; yourself! ! Object subclass: #MorphicEvent instanceVariableNames: 'timeStamp source windowIndex' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Events'! !MorphicEvent commentStamp: '' prior: 0! 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: 'accessing' stamp: 'ar 10/10/2000 21:28'! cursorPoint "Backward compatibility. Use #position instead" ^ self position! ! !MorphicEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 16:48'! hand "Return the source that generated the event" ^source! ! !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: '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 01:19'! wasHandled "Return true if this event was handled. May be ignored for some types of events." ^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: 'accessing' stamp: 'JMM 7/20/2004 22:10'! windowIndex ^windowIndex! ! !MorphicEvent methodsFor: 'accessing' stamp: 'JMM 7/20/2004 22:10'! windowIndex: aValue windowIndex := aValue! ! !MorphicEvent methodsFor: 'comparing' stamp: 'ar 9/13/2000 15:36'! = anEvent anEvent isMorphicEvent ifFalse:[^false]. ^self type = anEvent type! ! !MorphicEvent methodsFor: 'comparing' stamp: 'ar 9/13/2000 15:36'! hash ^self type hash! ! !MorphicEvent methodsFor: 'dispatching' stamp: 'ar 9/15/2000 21:12'! sentTo: anObject "Dispatch the receiver into anObject" ^anObject handleUnknownEvent: self! ! !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: '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: 'initialize' stamp: 'ar 10/24/2000 16:21'! type: eventType readFrom: aStream "Read a MorphicEvent from the given stream." ! ! !MorphicEvent methodsFor: 'testing' stamp: 'ar 9/22/2000 10:36'! isDraggingEvent ^false! ! !MorphicEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 19:17'! isDropEvent ^false! ! !MorphicEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 19:19'! isKeyboard ^false! ! !MorphicEvent methodsFor: 'testing' stamp: 'ar 10/10/2000 21:27'! isKeystroke ^false! ! !MorphicEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:37'! isMorphicEvent ^true! ! !MorphicEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 19:19'! isMouse ^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: 'testing' stamp: 'JMM 10/6/2004 21:35'! isWindowEvent ^false! ! !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: 'private' stamp: 'ar 10/25/2000 21:26'! setHand: aHand source := aHand! ! !MorphicEvent methodsFor: 'private' stamp: 'ar 10/25/2000 20:53'! setTimeStamp: stamp timeStamp := stamp.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MorphicEvent class instanceVariableNames: ''! !MorphicEvent class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 11/25/2012 03:25'! readFrom: aStream "Read a MorphicEvent from the given stream." | typeString | typeString := String streamContents: [:s | | c | [(c := aStream next) isLetter] whileTrue: [s nextPut: c]]. typeString = 'mouseMove' ifTrue:[^MouseMoveEvent type: #mouseMove readFrom: aStream]. typeString = 'mouseDown' ifTrue:[^MouseButtonEvent type: #mouseDown readFrom: aStream]. typeString = 'mouseUp' ifTrue:[^MouseButtonEvent type: #mouseUp readFrom: aStream]. typeString = 'keystroke' ifTrue:[^KeyboardEvent type: #keystroke readFrom: aStream]. typeString = 'keyDown' ifTrue:[^KeyboardEvent type: #keyDown readFrom: aStream]. typeString = 'keyUp' ifTrue:[^KeyboardEvent type: #keyUp readFrom: aStream]. typeString = 'mouseOver' ifTrue:[^MouseEvent type: #mouseOver readFrom: aStream]. typeString = 'mouseEnter' ifTrue:[^MouseEvent type: #mouseEnter readFrom: aStream]. typeString = 'mouseLeave' ifTrue:[^MouseEvent type: #mouseLeave readFrom: aStream]. typeString = 'unknown' ifTrue:[^MorphicUnknownEvent type: #unknown readFrom: aStream]. ^nil ! ! !MorphicEvent class methodsFor: 'instance creation' stamp: 'marcus.denker 8/24/2008 21:39'! type: eventType readFrom: aStream ^self basicNew type: eventType readFrom: aStream! ! Object subclass: #MorphicEventDispatcher instanceVariableNames: 'lastType lastDispatch' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Events'! !MorphicEventDispatcher commentStamp: '' prior: 0! 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 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: '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! ! !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: '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 ! ! Object subclass: #MorphicEventHandler instanceVariableNames: 'subscriptions' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Events'! !MorphicEventHandler commentStamp: 'GuillermoPolito 4/22/2012 19:16' prior: 0! 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: 'access' stamp: 'GuillermoPolito 4/22/2012 17:55'! allRecipients ^subscriptions collect: #recipients! ! !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: '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 19:24'! addSubscription: aSubscription toEvent: eventName (subscriptions includesKey: eventName) ifFalse: [ subscriptions at: eventName put: Set new. ]. (subscriptions at: eventName) add: aSubscription.! ! !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 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:57'! doubleClickTimeout: event fromMorph: sourceMorph ^self notifyMorphsOfEvent: event ofType: #doubleClickTimeout from: sourceMorph! ! !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:57'! keyStroke: event fromMorph: sourceMorph ^self notifyMorphsOfEvent: event ofType: #keyStroke from: sourceMorph! ! !MorphicEventHandler methodsFor: 'events' stamp: 'GuillermoPolito 4/22/2012 18:56'! keyUp: event fromMorph: sourceMorph ^self notifyMorphsOfEvent: event ofType: #keyUp 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'! mouseEnter: event fromMorph: sourceMorph ^self notifyMorphsOfEvent: event ofType: #mouseEnter from: sourceMorph! ! !MorphicEventHandler methodsFor: 'events' stamp: 'GuillermoPolito 4/22/2012 18:56'! mouseEnterDragging: event fromMorph: sourceMorph ^self notifyMorphsOfEvent: event ofType: #mouseEnterDragging 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: 'events' stamp: 'GuillermoPolito 4/22/2012 18:56'! mouseLeaveDragging: event fromMorph: sourceMorph ^self notifyMorphsOfEvent: event ofType: #mouseLeaveDragging 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: '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'! mouseUp: event fromMorph: sourceMorph ^self notifyMorphsOfEvent: event ofType: #mouseUp 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:55'! startDrag: event fromMorph: sourceMorph ^self notifyMorphsOfEvent: event ofType: #startDrag from: sourceMorph! ! !MorphicEventHandler methodsFor: 'initialization' stamp: 'GuillermoPolito 4/22/2012 18:47'! initialize subscriptions := Dictionary new.! ! !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: '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: '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:01'! handlesClickOrDrag: evt ^(self existsSubscriptionsFor: #click) or: [ (self existsSubscriptionsFor: #doubleClick) or: [(self existsSubscriptionsFor: #startDrag)]].! ! !MorphicEventHandler methodsFor: 'testing' stamp: 'GuillermoPolito 4/22/2012 19:03'! handlesGestureStart: evt ^self existsSubscriptionsFor: #gestureStart! ! !MorphicEventHandler methodsFor: 'testing' stamp: 'GuillermoPolito 4/22/2012 19:08'! handlesKeyDown: evt ^self existsSubscriptionsFor: #keyDown! ! !MorphicEventHandler methodsFor: 'testing' stamp: 'GuillermoPolito 4/22/2012 19:09'! handlesKeyStroke: evt ^self existsSubscriptionsFor: #keyStroke! ! !MorphicEventHandler methodsFor: 'testing' stamp: 'GuillermoPolito 4/22/2012 19:08'! handlesKeyUp: evt ^self existsSubscriptionsFor: #keyUp! ! !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: '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: 'testing' stamp: 'GuillermoPolito 4/22/2012 19:06'! handlesMouseMove: evt ^self existsSubscriptionsFor: #mouseMove! ! !MorphicEventHandler methodsFor: 'testing' stamp: 'GuillermoPolito 4/22/2012 19:07'! handlesMouseOver: evt ^(self existsSubscriptionsFor: #mouseEnter) or: [ self existsSubscriptionsFor: #mouseLeave ]! ! !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:08'! handlesMouseStillDown: evt ^self existsSubscriptionsFor: #mouseStillDown.! ! !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 ] ].! ! TestCase subclass: #MorphicEventHandlerTest instanceVariableNames: 'morph' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Event'! !MorphicEventHandlerTest methodsFor: 'running' stamp: 'GuillermoPolito 4/22/2012 19:15'! setUp morph := Morph new. morph eventHandler: MorphicEventHandler new! ! !MorphicEventHandlerTest methodsFor: 'running' stamp: 'GuillermoPolito 4/22/2012 18:34'! tearDown morph := nil! ! !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 4/22/2012 18:34'! testDoubleClickFromMorph morph eventHandler on: #doubleClick send: #value to: true. self assert: ((morph doubleClick: nil) == true)! ! !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: '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-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)! ! BorderedMorph subclass: #MorphicModel instanceVariableNames: 'model open accessor' classVariableNames: 'KeyboardFocusOnMouseDown MouseOverForKeyboardFocus' poolDictionaries: '' category: 'Morphic-Kernel'! !MorphicModel commentStamp: '' prior: 0! 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: 'accessing'! model ^ model! ! !MorphicModel methodsFor: 'accessing' stamp: 'sw 10/23/1999 22:36'! modelOrNil ^ model! ! !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: 'classification' stamp: 'ar 10/5/2000 16:40'! isMorphicModel ^true! ! !MorphicModel methodsFor: 'drag and drop' stamp: 'di 6/22/97 23:16'! isOpen "Support drag/drop and other edits." ^ open! ! !MorphicModel methodsFor: 'geometry'! newBounds: newBounds self bounds: newBounds! ! !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: '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: 'dgd 2/14/2003 22:28'! defaultColor "answer the default color/fill style for the receiver" ^ Color transparent! ! !MorphicModel methodsFor: 'initialization' stamp: 'StephaneDucasse 7/22/2011 18:29'! initialize "initialize the state of the receiver" super initialize. 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: 'initialization' stamp: 'StephaneDucasse 7/22/2011 18:28'! model: anObject accessor: selector model := anObject. accessor := selector. open := false.! ! !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: '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: '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: 'settings' stamp: 'AlainPlantec 12/10/2009 14:30'! keyboardFocusOnMouseDown ^ self class keyboardFocusOnMouseDown! ! !MorphicModel methodsFor: 'settings' stamp: 'AlainPlantec 12/10/2009 14:52'! mouseOverForKeyboardFocus ^ self class mouseOverForKeyboardFocus! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MorphicModel class instanceVariableNames: ''! !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]! ! !MorphicModel class methodsFor: 'settings' stamp: 'AlainPlantec 12/10/2009 14:53'! mouseOverForKeyboardFocus: aBoolean MouseOverForKeyboardFocus := aBoolean! ! !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! ! DisplayTransform subclass: #MorphicTransform instanceVariableNames: 'offset angle scale' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Transformations'! !MorphicTransform commentStamp: '' prior: 0! 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'! angle ^ angle! ! !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: 'accessing'! offset ^ offset ! ! !MorphicTransform methodsFor: 'accessing'! scale ^ scale! ! !MorphicTransform methodsFor: 'accessing'! withAngle: a "Return a copy of me with a different Angle" ^ self copy setAngle: a! ! !MorphicTransform methodsFor: 'accessing'! withOffset: a "Return a copy of me with a different Offset" ^ self copy setOffset: a! ! !MorphicTransform methodsFor: 'accessing'! withScale: a "Return a copy of me with a different Scale" ^ self copy setScale: a! ! !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: 'converting' stamp: 'ar 11/2/1998 20:14'! asMatrixTransform2x3 ^((MatrixTransform2x3 withRotation: angle radiansToDegrees negated) composedWithLocal: (MatrixTransform2x3 withScale: scale)) offset: offset negated! ! !MorphicTransform methodsFor: 'converting' stamp: 'di 10/26/1999 17:03'! asMorphicTransform ^ self! ! !MorphicTransform methodsFor: 'initialize' stamp: 'lr 7/4/2009 10:42'! setIdentiy scale := 1.0. offset := 0 @ 0. angle := 0.0! ! !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: '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: 'testing' stamp: 'ar 11/2/1998 19:51'! isMorphicTransform ^true! ! !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: '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: '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: '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: 'transformations' stamp: 'di 10/2/1998 08:54'! invertRect: aRectangle self error: 'method name changed to emphasize enclosing bounds'. ^ self invertBoundsRect: aRectangle! ! !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: '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 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: 'transforming points' stamp: 'ar 11/2/1998 16:32'! localPointToGlobal: aPoint "Transform aPoint from global coordinates into local coordinates" ^self invert: aPoint! ! !MorphicTransform methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! setAngle: aFloat angle := aFloat! ! !MorphicTransform methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! setOffset: aPoint offset := aPoint! ! !MorphicTransform methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! setOffset: aPoint angle: a scale: s offset := aPoint. angle := a. scale := s! ! !MorphicTransform methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! setScale: aFloat scale := aFloat! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MorphicTransform class instanceVariableNames: ''! !MorphicTransform class methodsFor: 'instance creation'! identity ^ self offset: 0@0 angle: 0.0 scale: 1.0! ! !MorphicTransform class methodsFor: 'instance creation'! new ^ self offset: 0@0 ! ! !MorphicTransform class methodsFor: 'instance creation'! offset: aPoint ^ self offset: aPoint angle: 0.0 scale: 1.0! ! !MorphicTransform class methodsFor: 'instance creation'! offset: aPoint angle: a scale: s ^ self basicNew setOffset: aPoint angle: a scale: s! ! TestCase subclass: #MorphicUIBugTest instanceVariableNames: 'cases' classVariableNames: '' poolDictionaries: '' category: 'Tests-Bugs'! !MorphicUIBugTest commentStamp: 'wiz 1/3/2007 13:57' prior: 0! A MorphicUIBugTest is a class for testing the shortcomings and repairs of the MorphicUI manager. . Instance Variables cases: 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: '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 6/11/2007 20:34'! setUp "default. tests will add morphs to list. Teardown will delete." cases := #() .! ! !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: '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 .! ! UIManager subclass: #MorphicUIManager uses: TEasilyThemed instanceVariableNames: 'interactiveParser' classVariableNames: 'UIProcess' poolDictionaries: '' category: 'Polymorph-Widgets-Themes'! !MorphicUIManager commentStamp: 'StephaneDucasse 6/5/2011 22:19' prior: 0! 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: 'accessing' stamp: 'pavel.krivanek 11/21/2008 17:30'! interactiveParser "Answer the value of interactiveParser" ^ interactiveParser! ! !MorphicUIManager methodsFor: 'accessing' stamp: 'pavel.krivanek 11/21/2008 17:30'! interactiveParser: anObject "Set the value of interactiveParser" interactiveParser := anObject! ! !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: 'accessing' stamp: 'FernandoOlivero 5/9/2011 13:14'! preferredCornerStyle ^ self theme preferredCornerStyle! ! !MorphicUIManager methodsFor: 'controls'! newAlphaImage: aForm help: helpText "Answer an alpha image morph." ^self theme newAlphaImageIn: self image: aForm help: helpText! ! !MorphicUIManager methodsFor: 'controls'! 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: 'controls'! 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: 'controls'! 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: 'controls'! 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'! 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: 'controls'! 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'! 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'! 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'! 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'! 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'! 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'! 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'! 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'! 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: 'controls'! 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'! 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'! 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'! 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'! 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'! 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: 'controls'! 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'! 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'! newButtonLabel: aString "Answer a new button text label." ^self newButtonLabelFor: nil label: aString getEnabled: nil! ! !MorphicUIManager methodsFor: 'controls'! newButtonLabelFor: aModel label: aString getEnabled: enabledSel "Answer a new button text label." ^self theme newButtonLabelIn: self for: aModel label: aString getEnabled: enabledSel! ! !MorphicUIManager methodsFor: 'controls'! newCancelButton "Answer a new cancel button." ^self newCancelButtonFor: self! ! !MorphicUIManager methodsFor: 'controls'! newCancelButtonFor: aModel "Answer a new cancel button." ^self theme newCancelButtonIn: self for: aModel! ! !MorphicUIManager methodsFor: 'controls'! 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'! 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'! 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'! newCloseButton "Answer a new close button." ^self newCloseButtonFor: self ! ! !MorphicUIManager methodsFor: 'controls'! newCloseButtonFor: aModel "Answer a new close button." ^self theme newCloseButtonIn: self for: aModel! ! !MorphicUIManager methodsFor: 'controls'! newCloseControlFor: aModel action: aValuable help: helpText "Answer a new cancel button." ^self theme newCloseControlIn: self for: aModel action: aValuable help: helpText! ! !MorphicUIManager methodsFor: 'controls'! 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'! 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'! 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'! newColumn: controls "Answer a morph laid out with a column of controls." ^self theme newColumnIn: self for: controls! ! !MorphicUIManager methodsFor: 'controls'! newDialogPanel "Answer a new main dialog panel." ^self theme newDialogPanelIn: self! ! !MorphicUIManager methodsFor: 'controls'! 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: 'controls'! 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: 'controls'! 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: 'controls'! 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'! 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'! newEmbeddedMenu "Answer a new menu." ^self theme newEmbeddedMenuIn: self for: self! ! !MorphicUIManager methodsFor: 'controls'! newExpander: aString "Answer an expander with the given label." ^self theme newExpanderIn: self label: aString forAll: #()! ! !MorphicUIManager methodsFor: 'controls'! newExpander: aString for: aControl "Answer an expander with the given label and control." ^self theme newExpanderIn: self label: aString forAll: {aControl}! ! !MorphicUIManager methodsFor: 'controls'! newExpander: aString forAll: controls "Answer an expander with the given label and controls." ^self theme newExpanderIn: self label: aString forAll: controls! ! !MorphicUIManager methodsFor: 'controls'! 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'! 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'! 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: 'controls'! newGroupbox "Answer a plain groupbox." ^self theme newGroupboxIn: self! ! !MorphicUIManager methodsFor: 'controls'! newGroupbox: aString "Answer a groupbox with the given label." ^self theme newGroupboxIn: self label: aString! ! !MorphicUIManager methodsFor: 'controls'! newGroupbox: aString for: control "Answer a groupbox with the given label and control." ^self theme newGroupboxIn: self label: aString for: control! ! !MorphicUIManager methodsFor: 'controls'! newGroupbox: aString forAll: controls "Answer a groupbox with the given label and controls." ^self theme newGroupboxIn: self label: aString forAll: controls! ! !MorphicUIManager methodsFor: 'controls'! newGroupboxFor: control "Answer a plain groupbox with the given control." ^self theme newGroupboxIn: self for: control! ! !MorphicUIManager methodsFor: 'controls'! newGroupboxForAll: controls "Answer a plain groupbox with the given controls." ^self theme newGroupboxIn: self forAll: controls! ! !MorphicUIManager methodsFor: 'controls'! 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'! newHSVSelector: aColor help: helpText "Answer a hue-saturation-volume selector with the given color." ^self theme newHSVSelectorIn: self color: aColor help: helpText! ! !MorphicUIManager methodsFor: 'controls'! 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: 'controls'! newImage: aForm "Answer a new image." ^self theme newImageIn: self form: aForm! ! !MorphicUIManager methodsFor: 'controls'! newImage: aForm size: aPoint "Answer a new image." ^self theme newImageIn: self form: aForm size: aPoint! ! !MorphicUIManager methodsFor: 'controls'! 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: 'controls'! 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'! newLabel: aString "Answer a new text label." ^self newLabelFor: nil label: aString getEnabled: nil! ! !MorphicUIManager methodsFor: 'controls'! newLabelFor: aModel getLabel: labelSel getEnabled: enabledSel "Answer a new text label." ^self theme newLabelIn: self for: aModel getLabel: labelSel getEnabled: enabledSel! ! !MorphicUIManager methodsFor: 'controls'! newLabelFor: aModel label: aString getEnabled: enabledSel "Answer a new text label." ^self theme newLabelIn: self for: aModel label: aString getEnabled: enabledSel! ! !MorphicUIManager methodsFor: 'controls'! 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'! 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'! 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'! 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: 'controls'! 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: 'controls'! newMenu "Answer a new menu." ^self theme newMenuIn: self for: self! ! !MorphicUIManager methodsFor: 'controls'! newMenuFor: aModel "Answer a new menu." ^self theme newMenuIn: self for: aModel! ! !MorphicUIManager methodsFor: 'controls'! 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'! 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: 'controls'! 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'! 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: 'controls'! 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'! 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: 'controls'! newNoButton "Answer a new No button." ^self newNoButtonFor: self! ! !MorphicUIManager methodsFor: 'controls'! newNoButtonFor: aModel "Answer a new No button." ^self theme newNoButtonIn: self for: aModel! ! !MorphicUIManager methodsFor: 'controls'! newOKButton "Answer a new OK button." ^self newOKButtonFor: self! ! !MorphicUIManager methodsFor: 'controls'! newOKButtonFor: aModel "Answer a new OK button." ^self newOKButtonFor: aModel getEnabled: nil! ! !MorphicUIManager methodsFor: 'controls'! newOKButtonFor: aModel getEnabled: enabledSel "Answer a new OK button." ^self theme newOKButtonIn: self for: aModel getEnabled: enabledSel! ! !MorphicUIManager methodsFor: 'controls'! 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: 'controls'! newPanel "Answer a new panel." ^self theme newPanelIn: self! ! !MorphicUIManager methodsFor: 'controls'! newPluggableDialogWindow "Answer a new pluggable dialog." ^self newPluggableDialogWindow: 'Dialog'! ! !MorphicUIManager methodsFor: 'controls'! newPluggableDialogWindow: title "Answer a new pluggable dialog with the given content." ^self newPluggableDialogWindow: title for: nil! ! !MorphicUIManager methodsFor: 'controls'! newPluggableDialogWindow: title for: contentMorph "Answer a new pluggable dialog with the given content." ^self theme newPluggableDialogWindowIn: self title: title for: contentMorph! ! !MorphicUIManager methodsFor: 'controls'! 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'! 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: 'controls'! newRow "Answer a morph laid out as a row." ^self theme newRowIn: self for: #()! ! !MorphicUIManager methodsFor: 'controls'! newRow: controls "Answer a morph laid out with a row of controls." ^self theme newRowIn: self for: controls! ! !MorphicUIManager methodsFor: 'controls'! newSVSelector: aColor help: helpText "Answer a saturation-volume selector with the given color." ^self theme newSVSelectorIn: self color: aColor help: helpText! ! !MorphicUIManager methodsFor: 'controls'! newScrollPaneFor: aMorph "Answer a new scroll pane morph to scroll the given morph." ^self theme newScrollPaneIn: self for: aMorph! ! !MorphicUIManager methodsFor: 'controls'! newSeparator "Answer an horizontal separator." ^self theme newSeparatorIn: self! ! !MorphicUIManager methodsFor: 'controls'! 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: 'controls'! 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'! 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: 'controls'! newStack "Answer a morph laid out as a stack." ^self theme newStackIn: self for: #()! ! !MorphicUIManager methodsFor: 'controls'! newStack: controls "Answer a morph laid out with a stack of controls." ^self theme newStackIn: self for: controls! ! !MorphicUIManager methodsFor: 'controls'! newString: aStringOrText "Answer a new embossed string." ^self theme newStringIn: self label: aStringOrText font: self theme labelFont style: #plain! ! !MorphicUIManager methodsFor: 'controls'! newString: aStringOrText font: aFont style: aStyle "Answer a new embossed string." ^self theme newStringIn: self label: aStringOrText font: aFont style: aStyle! ! !MorphicUIManager methodsFor: 'controls'! newString: aStringOrText style: aStyle "Answer a new embossed string." ^self theme newStringIn: self label: aStringOrText font: self theme labelFont style: aStyle! ! !MorphicUIManager methodsFor: 'controls'! newTabGroup: labelsAndPages "Answer a tab group with the given tab labels associated with pages." ^self theme newTabGroupIn: self for: labelsAndPages! ! !MorphicUIManager methodsFor: 'controls'! newText: aStringOrText "Answer a new text." ^self theme newTextIn: self text: aStringOrText! ! !MorphicUIManager methodsFor: 'controls'! 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'! 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: 'controls'! 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'! 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: 'controls'! 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'! 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'! 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: 'controls'! 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: 'controls'! newToolDockingBar "Answer a tool docking bar." ^self theme newToolDockingBarIn: self! ! !MorphicUIManager methodsFor: 'controls'! newToolSpacer "Answer a tool spacer." ^self theme newToolSpacerIn: self! ! !MorphicUIManager methodsFor: 'controls'! newToolbar "Answer a toolbar." ^self theme newToolbarIn: self! ! !MorphicUIManager methodsFor: 'controls'! newToolbar: controls "Answer a toolbar with the given controls." ^self theme newToolbarIn: self for: controls! ! !MorphicUIManager methodsFor: 'controls'! newToolbarHandle "Answer a toolbar handle." ^self theme newToolbarHandleIn: self! ! !MorphicUIManager methodsFor: 'controls'! 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'! newVerticalSeparator "Answer a vertical separator." ^self theme newVerticalSeparatorIn: self! ! !MorphicUIManager methodsFor: 'controls'! newWindowFor: aModel title: titleString "Answer a new window morph." ^self theme newWindowIn: self for: aModel title: titleString! ! !MorphicUIManager methodsFor: 'controls'! newWorkArea "Answer a new work area morph." ^self theme newWorkAreaIn: self! ! !MorphicUIManager methodsFor: 'controls'! newYesButton "Answer a new Yes button." ^self newYesButtonFor: self! ! !MorphicUIManager methodsFor: 'controls'! newYesButtonFor: aModel "Answer a new yes button." ^self theme newYesButtonIn: self for: aModel! ! !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: 'events' stamp: 'Pavel.Krivanek 10/28/2008 11:22'! onEventSensorStartup: anEventSensor anEventSensor flushAllButDandDEvents! ! !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: '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: 'global state' stamp: 'FernandoOlivero 5/1/2011 11:40'! world ^ ActiveWorld ! ! !MorphicUIManager methodsFor: 'services'! abort: aStringOrText "Open an error dialog." ^self abort: aStringOrText title: 'Error' translated! ! !MorphicUIManager methodsFor: 'services'! abort: aStringOrText title: aString "Open an error dialog." ^self theme abortIn: self text: aStringOrText title: aString! ! !MorphicUIManager methodsFor: 'services'! alert: aStringOrText "Open an alert dialog." ^self alert: aStringOrText title: 'Alert' translated! ! !MorphicUIManager methodsFor: 'services'! alert: aStringOrText title: aString "Open an alert dialog." ^self alert: aStringOrText title: aString configure: [:d | ]! ! !MorphicUIManager methodsFor: 'services'! 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: 'services'! 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: 'services'! chooseColor "Answer the result of a color selector dialog ." ^self chooseColor: Color black! ! !MorphicUIManager methodsFor: 'services'! 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: 'services'! 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: 'services'! chooseDirectory: title "Answer the result of a file dialog with the given title, answer a directory." ^self chooseDirectory: title path: nil! ! !MorphicUIManager methodsFor: 'services'! 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: 'services'! chooseDropList: aStringOrText list: aList "Open a drop list chooser dialog." ^self chooseDropList: aStringOrText title: 'Choose' translated list: aList! ! !MorphicUIManager methodsFor: 'services'! chooseDropList: aStringOrText title: aString list: aList "Open a drop list chooser dialog." ^self theme chooseDropListIn: self text: aStringOrText title: aString list: aList! ! !MorphicUIManager methodsFor: 'services'! 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: 'services'! chooseFont "Answer the result of a font selector dialog." ^self chooseFont: nil! ! !MorphicUIManager methodsFor: 'services'! 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: '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: '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: '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: '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: '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: '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'! deny: aStringOrText "Open a denial dialog." ^self deny: aStringOrText title: 'Access Denied' translated! ! !MorphicUIManager methodsFor: 'services'! deny: aStringOrText title: aString "Open a denial dialog." ^self theme denyIn: self text: aStringOrText title: aString! ! !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: '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: 'services'! fileOpen: title "Answer the result of a file open dialog with the given title." ^self fileOpen: title extensions: nil! ! !MorphicUIManager methodsFor: 'services'! 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: 'services'! 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: 'services'! 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: 'services'! fileSave: title "Answer the result of a file save dialog with the given title." ^self fileSave: title extensions: nil path: nil! ! !MorphicUIManager methodsFor: 'services'! 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: 'services'! 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: 'services'! 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'! longMessage: aStringOrText title: aString "Open a (long) message dialog." ^self theme longMessageIn: self text: aStringOrText title: aString! ! !MorphicUIManager methodsFor: 'services'! message: aStringOrText "Open a message dialog." ^self message: aStringOrText title: 'Information' translated! ! !MorphicUIManager methodsFor: 'services'! message: aStringOrText title: aString "Open a message dialog." ^self theme messageIn: self text: aStringOrText title: aString! ! !MorphicUIManager methodsFor: 'services'! proceed: aStringOrText "Open a proceed dialog." ^self proceed: aStringOrText title: 'Proceed' translated! ! !MorphicUIManager methodsFor: 'services'! 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'! question: aStringOrText "Open a question dialog." ^self question: aStringOrText title: 'Question' translated! ! !MorphicUIManager methodsFor: 'services'! 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: 'services'! questionWithoutCancel: aStringOrText "Open a question dialog." ^self questionWithoutCancel: aStringOrText title: 'Question' translated! ! !MorphicUIManager methodsFor: 'services'! 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: 'services'! textEntry: aStringOrText "Open a text entry dialog." ^self textEntry: aStringOrText title: 'Entry' translated! ! !MorphicUIManager methodsFor: 'services'! textEntry: aStringOrText title: aString "Open a text entry dialog." ^self textEntry: aStringOrText title: aString entryText: ''! ! !MorphicUIManager methodsFor: 'services'! textEntry: aStringOrText title: aString entryText: defaultEntryText "Open a text entry dialog." ^self theme textEntryIn: self text: aStringOrText title: aString entryText: defaultEntryText! ! !MorphicUIManager methodsFor: 'settings' stamp: 'stephaneDucasse 5/8/2010 20:00'! interactiveParserFor: requestor "during Morphic loading the interactive parser must be disabled" (interactiveParser = false) ifTrue: [ ^ false ]. "can be nil" ^ requestor notNil! ! !MorphicUIManager methodsFor: 'theme'! theme "Answer the ui theme that provides controls." ^UITheme current! ! !MorphicUIManager methodsFor: 'ui process' stamp: 'CamilloBruni 11/21/2012 00:56'! defer: aBlock " Evaluate the given Block in the UI thread as soon as there is nothing scheduled." WorldState addDeferredUIMessage: aBlock! ! !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: '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: 'ui process' stamp: 'StephaneDucasse 5/18/2012 18:11'! spawnNewProcess UIProcess := [ [World doOneCycle. Processor yield. false] whileFalse: []. ] newProcess priority: Processor userSchedulingPriority. UIProcess name: 'Morphic UI process'. UIProcess resume! ! !MorphicUIManager methodsFor: 'ui process' stamp: 'MarcusDenker 12/2/2011 16:31'! terminateUIProcess UIProcess suspend; terminate. UIProcess := nil "?"! ! !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: '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: '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: '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: '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: '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: '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: '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: '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: '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: 'JuanVuletich 11/1/2010 15:17'! currentWorld ActiveWorld ifNotNil: [^ActiveWorld]. ^World! ! !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: 'ui requests' stamp: 'JuanVuletich 10/26/2010 14:51'! explorer: anObjectExplorer for: anObject withLabel: label | window listMorph | anObjectExplorer rootObject: anObject. window := (SystemWindow labelled: label) model: anObjectExplorer. window addMorph: (listMorph := SimpleHierarchicalListMorph on: anObjectExplorer list: #getList selected: #getCurrentSelection changeSelected: #noteNewSelection: menu: #genericMenu: keystroke: #explorerKey:from:) frame: (0@0 corner: 1@0.8). window addMorph: ((PluggableTextMorph on: anObjectExplorer text: #trash accept: #trash: readSelection: #contentsSelection menu: #codePaneMenu:shifted:) askBeforeDiscardingEdits: false) frame: (0@0.8 corner: 1@1). listMorph autoDeselect: false. ^ window! ! !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: 'ui requests' stamp: 'pavel.krivanek 2/24/2007 20:14'! fileExistsDefaultAction: anException ^ anException fileClass fileExistsUserHandling: anException fileName! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'Pavel.Krivanek 10/28/2008 10:46'! fontFromUser: priorFont ^ StrikeFont fromUser: priorFont allowKeyboard: true! ! !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: '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: 'MarcusDenker 12/2/2011 16:44'! lowSpaceWatcherDefaultAction: preemptedProcess self interruptName: 'Space is low' preemptedProcess: preemptedProcess! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'JuanVuletich 10/26/2010 18:17'! menuClass ^MenuMorph! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'JuanVuletich 10/22/2010 09:10'! messageNames: aMessageNames inMorphicWindowWithInitialSearchString: initialString "Answer a morphic window with the given initial search string, nil if none" "MessageNames openMessageNames" | window selectorListView secondDivider horizDivider searchPane searchButton searchTextMorph searchColumn| window := (StandardWindow labelled: 'Message Names' translated) model: aMessageNames. secondDivider := 0.5. horizDivider := 0.5. searchTextMorph := window newTextEntryFor: aMessageNames getText: #searchString setText: #searchString:from: help: nil. searchTextMorph ghostText: 'type here, then click Search' translated; vResizing: #spaceFill; hResizing: #spaceFill; askBeforeDiscardingEdits: false. searchButton := window newButtonFor: aMessageNames action: #doSearchFrom: label: 'Search' translated help: 'Type some letters into the pane at right, and then press this Search button (or hit RETURN) and all method selectors that match what you typed will appear in the list pane below. Click on any one of them, and all the implementors of that selector will be shown in the right-hand pane, and you can view and edit their code without leaving this tool.' translated. searchButton arguments: {searchTextMorph}. searchPane := window newRow: {searchButton. searchTextMorph}. initialString isEmptyOrNil ifFalse: [searchTextMorph setText: initialString]. selectorListView := window newListFor: aMessageNames list: #selectorList selected: #selectorListIndex changeSelected: #selectorListIndex: help: nil. selectorListView getMenuSelector: #selectorListMenu:; keystrokeActionSelector: #selectorListKey:from:; menuTitleSelector: #selectorListMenuTitle; useSquareCorners. searchColumn := window newColumn: {searchPane. selectorListView}. searchColumn cellInset: ProportionalSplitterMorph splitterWidth. window addMorph: searchColumn frame: (0 @ 0 corner: horizDivider @ secondDivider); addMorph: aMessageNames buildMorphicMessageList frame: (horizDivider @ 0 corner: 1@ secondDivider); rememberKeyboardFocus: searchTextMorph. aMessageNames addLowerPanesTo: window at: (0 @ secondDivider corner: 1@1) with: nil. initialString isEmptyOrNil ifFalse: [aMessageNames searchString: initialString]. ^ window! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'JuanVuletich 10/18/2010 09:51'! messageSet: aMessageSet inMorphicWindowLabeled: labelString | window listFraction | window := (SystemWindow labelled: labelString) model: aMessageSet. listFraction := 0.4. window addMorph: aMessageSet buildMorphicMessageList frame: (0@0 extent: 1@listFraction). aMessageSet addLowerPanesTo: window at: (0@listFraction corner: 1@1) with: nil. window setUpdatablePanesFrom: #(messageList). ^ window! ! !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: '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: 'StephaneDucasse 2/25/2011 17:53'! newMenuIn: aThemedMorph for: aModel "Answer a new menu." "UIManager default" ^self theme newMenuIn: aThemedMorph for: aModel! ! !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: '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: '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: '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: '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: '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: '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: '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: '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: 'pavel.krivanek 2/24/2007 13:22'! restoreDisplay World fullRepaintNeeded! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'StephaneDucasse 1/2/2012 21:30'! restoreDisplayAfter: aBlock aBlock value. World activeHand waitButton. World fullRepaintNeeded.! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'IgorStasenko 4/15/2011 17:25'! syntaxErrorNotificationDefaultAction: anException ^Smalltalk tools debugSyntaxError: anException! ! !MorphicUIManager methodsFor: 'ui requests' stamp: 'IgorStasenko 4/15/2011 17:25'! 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 debugError: anException.! ! !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: 'private' stamp: 'SeanDeNigris 8/30/2012 11:26'! activate SystemProgressMorph enable.! ! !MorphicUIManager methodsFor: 'private' stamp: 'SeanDeNigris 8/30/2012 11:26'! deactivate SystemProgressMorph disable.! ! !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: '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 class uses: TEasilyThemed classTrait instanceVariableNames: ''! !MorphicUIManager class methodsFor: 'accessing' stamp: 'alain.plantec 5/30/2008 13:55'! isActiveManager "Answer whether I should act as the active ui manager" ^ true! ! MorphicEvent subclass: #MorphicUnknownEvent instanceVariableNames: 'type argument' classVariableNames: '' poolDictionaries: 'EventSensorConstants' category: 'Morphic-Events'! !MorphicUnknownEvent methodsFor: 'accessing' stamp: 'ar 10/25/2000 20:04'! argument ^argument! ! !MorphicUnknownEvent methodsFor: 'accessing' stamp: 'ar 10/25/2000 20:04'! argument: arg argument := arg! ! !MorphicUnknownEvent methodsFor: 'accessing' stamp: 'ar 10/25/2000 19:55'! position ^0@0! ! !MorphicUnknownEvent methodsFor: 'accessing' stamp: 'ar 10/25/2000 19:55'! type ^type! ! !MorphicUnknownEvent methodsFor: 'initialize' stamp: 'ar 10/26/2000 01:20'! type: eventType readFrom: aStream | typeAndArg | timeStamp := Integer readFrom: aStream. aStream skip: 1. typeAndArg := Object readFrom: aStream. type := typeAndArg first. argument := typeAndArg last.! ! !MorphicUnknownEvent methodsFor: 'printing' stamp: 'ar 10/26/2000 01:19'! storeOn: aStream aStream nextPutAll: 'unknown'. aStream space. self timeStamp storeOn: aStream. aStream space. {type. argument} storeOn: aStream.! ! !MorphicUnknownEvent methodsFor: 'private' stamp: 'ar 10/25/2000 19:59'! setType: evtType argument: arg type := evtType. argument := arg.! ! !MorphicUnknownEvent methodsFor: 'private' stamp: 'ar 10/25/2000 19:58'! setType: evtType argument: arg hand: evtHand stamp: stamp type := evtType. argument := arg. source := evtHand. timeStamp := stamp.! ! MouseEvent subclass: #MouseButtonEvent instanceVariableNames: 'whichButton' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Events'! !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: '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: '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: 'initialize' stamp: 'ar 10/24/2000 16:29'! type: eventType readFrom: aStream super type: eventType readFrom: aStream. aStream skip: 1. whichButton := Integer readFrom: aStream.! ! !MouseButtonEvent methodsFor: 'printing' stamp: 'ar 10/24/2000 16:29'! storeOn: aStream super storeOn: aStream. aStream space. whichButton storeOn: aStream.! ! !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.! ! Object subclass: #MouseClickState instanceVariableNames: 'clickClient clickState firstClickDown firstClickUp firstClickTime clickSelector dblClickSelector dblClickTime dblClickTimeoutSelector dragSelector dragThreshold' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Kernel'! !MouseClickState commentStamp: '' prior: 0! 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: 'as yet unclassified' 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]! ! !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: '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.! ! UserInputEvent subclass: #MouseEvent instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Events'! !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: 'NS 5/19/2003 15:17'! anyButtonPressed "Answer true if any mouse button is being pressed." ^ buttons anyMask: self class anyButton! ! !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: '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: '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: '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: '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: 'comparing' stamp: 'ar 9/15/2000 22:47'! hash ^ position hash + buttons hash! ! !MouseEvent methodsFor: 'converting' stamp: 'pmm 3/13/2010 11:33'! asMouseEnter ^self shallowCopy setType: #mouseEnter! ! !MouseEvent methodsFor: 'converting' stamp: 'pmm 3/13/2010 11:33'! asMouseLeave ^self shallowCopy setType: #mouseLeave! ! !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: '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: '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: 'initialize' stamp: 'ar 10/25/2000 22:08'! type: eventType readFrom: aStream | x y | type := eventType. timeStamp := Integer readFrom: aStream. aStream skip: 1. x := Integer readFrom: aStream. aStream skip: 1. y := Integer readFrom: aStream. aStream skip: 1. buttons := Integer readFrom: aStream. position := x@y. ! ! !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: '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: 'testing' stamp: 'ar 10/5/2000 19:43'! isDraggingEvent source ifNil:[^false]. source hasSubmorphs ifTrue:[^true]. self anyButtonPressed ifTrue:[^true]. ^false! ! !MouseEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:30'! isMouse ^true! ! !MouseEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:32'! isMouseDown ^self type == #mouseDown! ! !MouseEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:32'! isMouseEnter ^self type == #mouseEnter! ! !MouseEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:32'! isMouseLeave ^self type == #mouseLeave! ! !MouseEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:32'! isMouseMove ^self type == #mouseMove! ! !MouseEvent methodsFor: 'testing' stamp: 'ar 9/13/2000 15:32'! isMouseUp ^self type == #mouseUp! ! !MouseEvent methodsFor: 'testing' stamp: 'gvc 1/28/2008 13:14'! isMouseWheel "Answer whether the receiver is a mouse wheel event." ^false! ! !MouseEvent methodsFor: 'private' stamp: 'ar 10/10/2000 21:15'! setType: aSymbol "For quick conversion between event types" type := aSymbol.! ! !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 class instanceVariableNames: ''! !MouseEvent class methodsFor: 'constants' stamp: 'NS 5/19/2003 15:16'! anyButton ^ 7! ! !MouseEvent class methodsFor: 'constants' stamp: 'NS 5/19/2003 15:16'! blueButton ^ 1! ! !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 subclass: #MouseMoveEvent instanceVariableNames: 'startPoint trail' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Events'! !MouseMoveEvent methodsFor: 'accessing' stamp: 'ar 9/15/2000 22:51'! endPoint "Return the point where the movement ended." ^position! ! !MouseMoveEvent methodsFor: 'accessing' stamp: 'ar 9/13/2000 16:25'! startPoint "Return the point where the movement started." ^startPoint! ! !MouseMoveEvent methodsFor: 'accessing' stamp: 'ar 10/24/2000 16:33'! trail "Return any immediate points that have been assembled along the move" ^trail ifNil:[#()]! ! !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: 'comparing' stamp: 'ar 9/15/2000 22:49'! hash ^ position hash + startPoint hash + buttons hash! ! !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: 'initialize' stamp: 'ar 10/24/2000 16:31'! type: eventType readFrom: aStream | x y | super type: eventType readFrom: aStream. aStream skip: 1. x := Integer readFrom: aStream. aStream skip: 1. y := Integer readFrom: aStream. startPoint := x@y.! ! !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: '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: '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: '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.! ! Object subclass: #MouseOverHandler instanceVariableNames: 'mouseOverMorphs enteredMorphs overMorphs leftMorphs' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Events'! !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 13:33'! handleAsMouseEnter: anEvent | asMouseEnterEvent | asMouseEnterEvent := anEvent asMouseEnter. enteredMorphs := enteredMorphs contents. enteredMorphs reverseDo: [ :anEnteredMorph | self inform: asMouseEnterEvent to: anEnteredMorph originatedFrom: anEvent ifNotFocusedDo: [] ]! ! !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 11:56'! hasLeftMorphsChanged ^(leftMorphs isEmpty and: [ enteredMorphs position = 0 ]) not! ! !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: '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 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 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:32'! keepLeftMorphsOrder leftMorphs size > 1 ifTrue: [ leftMorphs := mouseOverMorphs intersection: leftMorphs ] ! ! !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:38'! transform: anEvent from: originalEvent andSendTo: aMorph | transformedEvent | transformedEvent := anEvent transformedBy: (aMorph transformedFrom: originalEvent hand). ^ aMorph handleEvent: transformedEvent! ! !MouseOverHandler methodsFor: 'initialization' stamp: 'HernanWilkinson 6/4/2009 14:10'! initialize mouseOverMorphs := #(). self initializeTrackedMorphs ! ! !MouseOverHandler methodsFor: 'initialization' stamp: 'HernanWilkinson 6/12/2009 13:48'! initializeTrackedMorphs leftMorphs := OrderedCollection new. overMorphs := WriteStream on: #(). enteredMorphs := WriteStream on: #(). ! ! MouseEvent subclass: #MouseWheelEvent instanceVariableNames: 'direction' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Events'! !MouseWheelEvent commentStamp: 'gvc 9/23/2008 11:46' prior: 0! 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/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: 'as yet unclassified' stamp: 'gvc 1/28/2008 13:14'! isMouseWheel "Answer whether the receiver is a mouse wheel event." ^true! ! !MouseWheelEvent methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'gvc 1/25/2008 17:42'! sentTo: anObject "Dispatch the receiver into anObject" type == #mouseWheel ifTrue:[^anObject handleMouseWheel: self]. ^super sentTo: anObject. ! ! !MouseWheelEvent methodsFor: 'as yet unclassified' 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.! ! ReadWriteStream subclass: #MultiByteBinaryOrTextStream instanceVariableNames: 'isBinary converter' classVariableNames: '' poolDictionaries: '' category: 'Collections-Streams'! !MultiByteBinaryOrTextStream commentStamp: '' prior: 0! It is similar to MultiByteFileStream, but works on in memory stream.! !MultiByteBinaryOrTextStream methodsFor: 'accessing' stamp: 'yo 11/11/2002 13:16'! ascii isBinary := false ! ! !MultiByteBinaryOrTextStream methodsFor: 'accessing' stamp: 'yo 11/11/2002 13:16'! binary isBinary := true ! ! !MultiByteBinaryOrTextStream methodsFor: 'accessing' stamp: 'nk 8/2/2004 17:02'! converter converter ifNil: [converter := self class defaultConverter]. ^ converter ! ! !MultiByteBinaryOrTextStream methodsFor: 'accessing' stamp: 'yo 8/7/2003 09:12'! converter: aConverter converter := aConverter. ! ! !MultiByteBinaryOrTextStream methodsFor: 'accessing' stamp: 'yo 11/11/2002 13:25'! isBinary ^ isBinary! ! !MultiByteBinaryOrTextStream methodsFor: 'accessing' stamp: 'yo 11/11/2002 16:33'! text isBinary := false ! ! !MultiByteBinaryOrTextStream methodsFor: 'converting' stamp: 'yo 11/11/2002 13:16'! asBinaryOrTextStream ^ self ! ! !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: '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: 'properties-setting' stamp: 'yo 11/14/2002 13:49'! setFileTypeToObject "do nothing. We don't have a file type"! ! !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 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: 'public' stamp: 'ar 4/12/2005 17:34'! next: anInteger | multiString | "self halt." 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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: 'private' stamp: 'EstebanLorenzano 8/17/2012 16:40'! guessConverter ^ (self originalContents includesSubstring: #[27 36] asString) ifTrue: [CompoundTextConverter new] ifFalse: [self class defaultConverter ]! ! !MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'yo 11/11/2002 16:01'! basicNext ^ super next ! ! !MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'md 10/20/2004 15:32'! basicNext: anInteger ^ super next: anInteger. ! ! !MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'yo 11/11/2002 13:21'! basicNext: n into: aString ^ super next: n into: aString. ! ! !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: 'private basic' stamp: 'yo 11/11/2002 13:21'! basicNextInto: aString ^ super nextInto: aString. ! ! !MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'yo 11/11/2002 13:21'! basicNextPut: char ^ super nextPut: char. ! ! !MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'yo 11/11/2002 13:21'! basicNextPutAll: aString ^ super nextPutAll: aString. ! ! !MultiByteBinaryOrTextStream methodsFor: 'private basic' stamp: 'yo 11/11/2002 13:21'! basicPeek ^ super peek ! ! !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'! basicPosition: pos ^ super position: pos. ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MultiByteBinaryOrTextStream class instanceVariableNames: ''! !MultiByteBinaryOrTextStream class methodsFor: 'defaults' stamp: 'yo 2/25/2005 20:04'! defaultConverter ^ Latin1TextConverter new. ! ! !MultiByteBinaryOrTextStream class methodsFor: 'instance creation' stamp: 'ykoubo 9/28/2003 19:59'! on: aCollection encoding: encodingName | aTextConverter | encodingName isNil ifTrue: [aTextConverter := TextConverter default] ifFalse: [aTextConverter := TextConverter newForEncoding: encodingName]. ^ (self on: aCollection) converter: aTextConverter! ! !MultiByteBinaryOrTextStream class methodsFor: 'instance creation' stamp: 'yo 11/23/2003 20:32'! with: aCollection encoding: encodingName | aTextConverter | encodingName isNil ifTrue: [aTextConverter := TextConverter default] ifFalse: [aTextConverter := TextConverter newForEncoding: encodingName]. ^ (self with: aCollection) converter: aTextConverter! ! StandardFileStream subclass: #MultiByteFileStream instanceVariableNames: 'converter lineEndConvention wantsLineEndConversion' classVariableNames: 'Cr CrLf Lf LineEndDefault LineEndStrings LookAheadCount' poolDictionaries: '' category: 'Files-Kernel'! !MultiByteFileStream commentStamp: '' prior: 0! 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: 'accessing' stamp: 'yo 2/21/2004 02:57'! ascii super ascii. self detectLineEndConvention. ! ! !MultiByteFileStream methodsFor: 'accessing' stamp: 'nice 5/10/2009 00:14'! binary super binary. self lineEndConvention: nil! ! !MultiByteFileStream methodsFor: 'accessing' stamp: 'nice 5/10/2009 00:17'! converter converter ifNil: [self converter: TextConverter defaultSystemConverter]. ^ converter ! ! !MultiByteFileStream methodsFor: 'accessing' stamp: 'nice 5/10/2009 00:18'! converter: aConverter converter := aConverter. self installLineEndConventionInConverter ! ! !MultiByteFileStream methodsFor: 'accessing' stamp: 'yo 8/6/2003 11:56'! fileInEncodingName: aString self converter: (TextConverter newForEncoding: aString). super fileIn. ! ! !MultiByteFileStream methodsFor: 'accessing' stamp: 'nk 9/5/2004 12:57'! lineEndConvention ^lineEndConvention! ! !MultiByteFileStream methodsFor: 'accessing' stamp: 'nice 11/28/2009 13:06'! lineEndConvention: aSymbol (lineEndConvention := aSymbol) ifNotNil: [wantsLineEndConversion := true]. self installLineEndConventionInConverter! ! !MultiByteFileStream methodsFor: 'crlf private' stamp: 'yo 2/24/2004 13:38'! bareNext ^ self converter nextFromStream: self. ! ! !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: '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: '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: 'crlf private' stamp: 'ul 11/25/2009 01:22'! doConversion ^wantsLineEndConversion == true and: [ lineEndConvention notNil ]! ! !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: 'crlf private' stamp: 'ul 11/25/2009 01:22'! wantsLineEndConversion ^wantsLineEndConversion == true ! ! !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: '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: '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: 'open/close' stamp: 'nice 5/10/2009 00:18'! reset super reset. converter ifNil: [ self converter: UTF8TextConverter new. ]. ! ! !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: '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: '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: '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: '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: '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: '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 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: '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: '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: '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: '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: '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: '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: '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: 'remnant' stamp: 'yo 8/28/2002 11:06'! accepts: aSymbol ^ converter accepts: aSymbol. ! ! !MultiByteFileStream methodsFor: 'remnant' stamp: 'kph 3/1/2009 15:50'! wantsLineEndConversion: aBoolean wantsLineEndConversion := aBoolean. lineEndConvention ifNil: [ self detectLineEndConvention ]. ! ! !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: '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: '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: 'private basic' stamp: 'yo 8/28/2002 11:07'! basicNext: n into: aString ^ super next: n into: aString. ! ! !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 basic' stamp: 'yo 8/28/2002 11:07'! basicNextInto: aString ^ super nextInto: aString. ! ! !MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:07'! basicNextPut: char ^ super nextPut: char. ! ! !MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:07'! basicNextPutAll: aString ^ super nextPutAll: aString. ! ! !MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:07'! basicPeek ^ super peek ! ! !MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:08'! basicPosition ^ super position. ! ! !MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:08'! basicPosition: pos ^ super position: pos. ! ! !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: 'private basic' stamp: 'yo 8/28/2002 11:08'! basicSetToEnd ^ super setToEnd. ! ! !MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:08'! basicSkip: n ^ super skip: n. ! ! !MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:08'! basicUpTo: delim ^ super upTo: delim. ! ! !MultiByteFileStream methodsFor: 'private basic' stamp: 'yo 8/28/2002 11:09'! basicVerbatim: aString ^ super verbatim: aString. ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MultiByteFileStream class instanceVariableNames: ''! !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: 'yo 2/21/2004 02:45'! defaultToCR "MultiByteFileStream defaultToCR" LineEndDefault := #cr. ! ! !MultiByteFileStream class methodsFor: 'class initialization' stamp: 'yo 2/21/2004 02:45'! defaultToCRLF "MultiByteFileStream defaultToCRLF" LineEndDefault := #crlf.! ! !MultiByteFileStream class methodsFor: 'class initialization' stamp: 'yo 2/21/2004 02:46'! defaultToLF "MultiByteFileStream defaultToLF" LineEndDefault := #lf. ! ! !MultiByteFileStream class methodsFor: 'class initialization' stamp: 'CamilloBruni 5/7/2012 11:30'! 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: [^ (OSPlatform isMacOSX or: [OSPlatform 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: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:44'! startUp self guessDefaultLineEndConvention. ! ! !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. ! ! TestCase subclass: #MultiByteFileStreamTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Multilingual-Tests-TextConversion'! !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! ! !MultiByteFileStreamTest methodsFor: 'support' stamp: 'HenrikSperreJohansen 5/19/2011 09:53'! lineEndTestFile ^'lineEndTesting.txt'! ! !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: 'SeanDeNigris 7/12/2012 08:44'! tearDown 'foobug6933' asFileReference delete. self lineEndTestFile asFileReference delete.! ! !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: '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: 'testing' stamp: 'SvenVanCaekenberghe 12/3/2012 22:11'! testReadIntoStartingAtCount | testString filename buffer | testString := 'élève en Français'. filename := 'test-file-' , 99 atRandom printString , '.txt'. filename asFileReference ensureDeleted. 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 ensureDeleted ]! ! PluggableCanvas subclass: #MultiCanvas instanceVariableNames: 'canvases extent depth' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Support'! !MultiCanvas commentStamp: '' prior: 0! A canvas which forwards drawing commands to sub-canvases.! !MultiCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 20:48'! addCanvas: aCanvas canvases add: aCanvas! ! !MultiCanvas methodsFor: 'accessing' stamp: 'RAA 11/7/2000 17:46'! clipRect ^super clipRect ifNil: [ 0@0 extent: 5000@5000 ].! ! !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'! depth ^depth! ! !MultiCanvas methodsFor: 'accessing' stamp: 'ls 4/8/2000 22:35'! extent ^extent! ! !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: 'initialization' stamp: 'ls 4/8/2000 22:35'! depth: newDepth "set the extent to be used with this canvas" depth := newDepth.! ! !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: 'initialization' stamp: 'alain.plantec 5/28/2009 10:11'! initialize super initialize. canvases := Set new. extent := 600@400. depth := 32. ! ! !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] ]. ! ! MultiCharacterScanner subclass: #MultiCharacterBlockScanner instanceVariableNames: 'characterPoint characterIndex lastCharacter lastCharacterExtent lastSpaceOrTabExtent nextLeftMargin specialWidth' classVariableNames: '' poolDictionaries: 'TextConstants' category: 'Text-Scanning'! !MultiCharacterBlockScanner methodsFor: '*FreeType-override' stamp: 'tween 4/6/2007 12:52'! crossedX "Text display has wrapping. The scanner just found a character past the x location of the cursor. We know that the cursor is pointing at a character or before one." | leadingTab currentX | characterIndex == nil ifFalse: [ "If the last character of the last line is a space, and it crosses the right margin, then locating the character block after it is impossible without this hack." characterIndex > text size ifTrue: [ lastIndex := characterIndex. characterPoint := (nextLeftMargin ifNil: [leftMargin]) @ (destY + line lineHeight). ^true]]. characterPoint x <= (destX + (lastCharacterExtent x // 2)) ifTrue: [lastCharacter := (text at: lastIndex). characterPoint := destX @ destY. ^true]. lastIndex >= line last ifTrue: [lastCharacter := (text at: line last). characterPoint := destX @ destY. ^true]. "Pointing past middle of a character, return the next character." lastIndex := lastIndex + 1. lastCharacter := text at: lastIndex. currentX := destX + lastCharacterExtent x + kern. self lastCharacterExtentSetX: (font widthOf: lastCharacter). characterPoint := currentX @ destY. lastCharacter = Space ifFalse: [^ true]. "Yukky if next character is space or tab." alignment = Justified ifTrue: [self lastCharacterExtentSetX: (lastCharacterExtent x + (line justifiedPadFor: (spaceCount + 1) font: font)). ^ true]. true ifTrue: [^ true]. "NOTE: I find no value to the following code, and so have defeated it - DI" "See tabForDisplay for illumination on the following awfulness." leadingTab := true. line first to: lastIndex - 1 do: [:index | (text at: index) ~= Tab ifTrue: [leadingTab := false]]. (alignment ~= Justified or: [leadingTab]) ifTrue: [self lastCharacterExtentSetX: (textStyle nextTabXFrom: currentX leftMargin: leftMargin rightMargin: rightMargin) - currentX] ifFalse: [self lastCharacterExtentSetX: (((currentX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount))) - currentX) max: 0)]. ^ true! ! !MultiCharacterBlockScanner methodsFor: 'scanning' stamp: 'nice 12/28/2009 20:14'! characterBlockAtPoint: aPoint index: index in: textLine "This method is the Morphic characterBlock finder. It combines MVC's characterBlockAtPoint:, -ForIndex:, and buildCharcterBlock:in:" | 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]. (text isEmpty or: [(characterPoint y < line top or: [characterPoint x < line left]) or: [characterIndex notNil and: [characterIndex < line first]]]) ifTrue: [^ (CharacterBlock new stringIndex: line first text: text topLeft: line leftMargin@line top extent: 0 @ textStyle lineGrid) textLine: line]. destX := leftMargin := line leftMarginForAlignment: alignment. destY := line top. runLength := text runLengthFor: line first. characterIndex ifNotNil: [lineStop := characterIndex "scanning for index"] ifNil: [lineStop := line last "scanning for point"]. runStopIndex := lastIndex + (runLength - 1) min: lineStop. lastCharacterExtent := 0 @ line lineHeight. spaceCount := 0. [false] whileFalse: [stopCondition := self scanCharactersFrom: lastIndex to: runStopIndex in: text string rightX: characterPoint x stopConditions: stopConditions kern: kern. "see setStopConditions for stopping conditions for character block operations." self lastCharacterExtentSetX: (specialWidth ifNil: [font widthOf: (text at: lastIndex)] ifNotNil: [specialWidth]). (self perform: stopCondition) ifTrue: [characterIndex ifNil: [ "Result for characterBlockAtPoint: " (stopCondition ~~ #cr and: [ lastIndex == line last and: [ aPoint x > ((characterPoint x) + (lastCharacterExtent x / 2)) ]]) ifTrue: [ "Correct for right half of last character in line" ^ (CharacterBlock new stringIndex: lastIndex + 1 text: text topLeft: characterPoint + (lastCharacterExtent x @ 0) + (font descentKern @ 0) extent: 0 @ lastCharacterExtent y) textLine: line ]. ^ (CharacterBlock new stringIndex: lastIndex text: text topLeft: characterPoint + (font descentKern @ 0) extent: lastCharacterExtent - (font baseKern @ 0)) textLine: line] ifNotNil: ["Result for characterBlockForIndex: " ^ (CharacterBlock new stringIndex: characterIndex text: text topLeft: characterPoint + ((font descentKern) - kern @ 0) extent: lastCharacterExtent) textLine: line]]]! ! !MultiCharacterBlockScanner methodsFor: 'scanning' stamp: 'sd 2/4/2008 21:22'! indentationLevel: anInteger super indentationLevel: anInteger. nextLeftMargin := leftMargin. indentationLevel timesRepeat: [ nextLeftMargin := textStyle nextTabXFrom: nextLeftMargin leftMargin: leftMargin rightMargin: rightMargin]! ! !MultiCharacterBlockScanner methodsFor: 'scanning' stamp: 'sd 2/4/2008 21:22'! placeEmbeddedObject: anchoredMorph "Workaround: The following should really use #textAnchorType" anchoredMorph relativeTextAnchorPosition ifNotNil:[^true]. (super placeEmbeddedObject: anchoredMorph) ifFalse: [^ false]. specialWidth := anchoredMorph width. ^ true! ! !MultiCharacterBlockScanner methodsFor: 'stop conditions' stamp: 'nice 11/16/2009 14:52'! 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. baselineY := line lineHeight. lastCharacter := nil. 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]. self lastCharacterExtentSetX: 0. ^ true]. lastCharacter := CR. characterPoint := destX @ destY. self lastCharacterExtentSetX: rightMargin - destX. ^true! ! !MultiCharacterBlockScanner methodsFor: 'stop conditions' stamp: 'sd 2/4/2008 21:22'! 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)). characterIndex ~~ nil ifTrue: [lineStop := characterIndex "scanning for index"] ifFalse: [lineStop := line last "scanning for point"]. (runStopIndex := lastIndex + (runLength - 1)) > lineStop ifTrue: [runStopIndex := lineStop]. self setStopConditions. ^false]. lastCharacter := text at: lastIndex. characterPoint := destX @ destY. ((lastCharacter = Space and: [alignment = Justified]) or: [lastCharacter = Tab and: [lastSpaceOrTabExtent notNil]]) ifTrue: [lastCharacterExtent := lastSpaceOrTabExtent]. 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: [self characterPointSetX: destX - lastCharacterExtent x. ^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. lastCharacter := nil. self lastCharacterExtentSetX: 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. lastCharacter := nil. self lastCharacterExtentSetX: 0. ^true]. "just off end of line without crossing x" lastIndex := lastIndex + 1. ^true! ! !MultiCharacterBlockScanner methodsFor: 'stop conditions' stamp: 'tween 4/6/2007 12:52'! paddedSpace "When the line is justified, the spaces will not be the same as the font's space character. A padding of extra space must be considered in trying to find which character the cursor is pointing at. Answer whether the scanning has crossed the cursor." | pad | pad := 0. spaceCount := spaceCount + 1. pad := line justifiedPadFor: spaceCount font: font. lastSpaceOrTabExtent := lastCharacterExtent copy. self lastSpaceOrTabExtentSetX: spaceWidth + pad. (destX + lastSpaceOrTabExtent x) >= characterPoint x ifTrue: [lastCharacterExtent := lastSpaceOrTabExtent copy. ^self crossedX]. lastIndex := lastIndex + 1. destX := destX + lastSpaceOrTabExtent x. ^ false ! ! !MultiCharacterBlockScanner methodsFor: 'stop conditions' stamp: 'sd 2/4/2008 21:22'! setFont specialWidth := nil. super setFont! ! !MultiCharacterBlockScanner methodsFor: 'stop conditions' stamp: 'ar 10/18/2004 14:31'! setStopConditions "Set the font and the stop conditions for the current run." self setFont. self setConditionArray: (alignment = Justified ifTrue: [#paddedSpace]). ! ! !MultiCharacterBlockScanner methodsFor: 'stop conditions' stamp: 'nice 11/17/2009 03:28'! tab | currentX | currentX := (alignment = Justified and: [self leadingTab not]) ifTrue: "imbedded tabs in justified text are weird" [destX + (textStyle tabWidth - (line justifiedTabDeltaFor: spaceCount)) max: destX] ifFalse: [textStyle nextTabXFrom: destX leftMargin: leftMargin rightMargin: rightMargin]. lastSpaceOrTabExtent := lastCharacterExtent copy. self lastSpaceOrTabExtentSetX: (currentX - destX max: 0). currentX >= characterPoint x ifTrue: [lastCharacterExtent := lastSpaceOrTabExtent copy. ^ self crossedX]. destX := currentX. lastIndex := lastIndex + 1. ^false! ! !MultiCharacterBlockScanner methodsFor: 'private' stamp: 'sd 2/4/2008 21:22'! buildCharacterBlockIn: para | lineIndex runLength lineStop done stopCondition | "handle nullText" (para numberOfLines = 0 or: [text size = 0]) ifTrue: [^ CharacterBlock new stringIndex: 1 "like being off end of string" text: para text topLeft: (para leftMarginForDisplayForLine: 1 alignment: (alignment ifNil:[textStyle alignment])) @ para compositionRectangle top extent: 0 @ textStyle lineGrid]. "find the line" lineIndex := para lineIndexOfTop: characterPoint y. destY := para topAtLineIndex: lineIndex. line := para lines at: lineIndex. rightMargin := para rightMarginForDisplay. (lineIndex = para numberOfLines and: [(destY + line lineHeight) < characterPoint y]) ifTrue: ["if beyond lastLine, force search to last character" self characterPointSetX: rightMargin] ifFalse: [characterPoint y < (para compositionRectangle) top ifTrue: ["force search to first line" characterPoint := (para compositionRectangle) topLeft]. characterPoint x > rightMargin ifTrue: [self characterPointSetX: rightMargin]]. destX := (leftMargin := para leftMarginForDisplayForLine: lineIndex alignment: (alignment ifNil:[textStyle alignment])). nextLeftMargin:= para leftMarginForDisplayForLine: lineIndex+1 alignment: (alignment ifNil:[textStyle alignment]). lastIndex := line first. self setStopConditions. "also sets font" runLength := (text runLengthFor: line first). characterIndex == nil ifTrue: [lineStop := line last "characterBlockAtPoint"] ifFalse: [lineStop := characterIndex "characterBlockForIndex"]. (runStopIndex := lastIndex + (runLength - 1)) > lineStop ifTrue: [runStopIndex := lineStop]. lastCharacterExtent := 0 @ line lineHeight. spaceCount := 0. done := false. self handleIndentation. [done] whileFalse: [stopCondition := self scanCharactersFrom: lastIndex to: runStopIndex in: text string rightX: characterPoint x stopConditions: stopConditions kern: kern. "see setStopConditions for stopping conditions for character block operations." self lastCharacterExtentSetX: (font widthOf: (text at: lastIndex)). (self perform: stopCondition) ifTrue: [characterIndex == nil ifTrue: ["characterBlockAtPoint" ^ CharacterBlock new stringIndex: lastIndex text: text topLeft: characterPoint + (font descentKern @ 0) extent: lastCharacterExtent] ifFalse: ["characterBlockForIndex" ^ CharacterBlock new stringIndex: lastIndex text: text topLeft: characterPoint + ((font descentKern) - kern @ 0) extent: lastCharacterExtent]]]! ! !MultiCharacterBlockScanner methodsFor: 'private' stamp: 'sd 2/4/2008 21:22'! characterPointSetX: xVal characterPoint := xVal @ characterPoint y! ! !MultiCharacterBlockScanner methodsFor: 'private' stamp: 'sd 2/4/2008 21:22'! lastCharacterExtentSetX: xVal lastCharacterExtent := xVal @ lastCharacterExtent y! ! !MultiCharacterBlockScanner methodsFor: 'private' stamp: 'sd 2/4/2008 21:22'! lastSpaceOrTabExtentSetX: xVal lastSpaceOrTabExtent := xVal @ lastSpaceOrTabExtent y! ! Object subclass: #MultiCharacterScanner instanceVariableNames: 'destX lastIndex destY stopConditions text textStyle alignment leftMargin rightMargin font line runStopIndex spaceCount spaceWidth emphasisCode kern indentationLevel wantsColumnBreaks presentation presentationLine numOfComposition baselineY firstDestX pendingKernX lastWidth' classVariableNames: 'DefaultStopConditions NilCondition PaddedSpaceCondition SpaceCondition' poolDictionaries: 'TextConstants' category: 'Text-Scanning'! !MultiCharacterScanner methodsFor: '*FreeType-override' stamp: 'nice 11/17/2009 03:29'! plainTab "This is the basic method of adjusting destX for a tab." destX := (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]. pendingKernX := 0.! ! !MultiCharacterScanner methodsFor: 'initialize' stamp: 'alain.plantec 5/28/2009 10:11'! initialize super initialize. destX := destY := leftMargin := 0.! ! !MultiCharacterScanner methodsFor: 'initialize' stamp: 'ul 3/8/2010 04:55'! initializeStringMeasurer stopConditions := TextStopConditions new ! ! !MultiCharacterScanner methodsFor: 'initialize' stamp: 'sd 2/4/2008 21:22'! wantsColumnBreaks: aBoolean wantsColumnBreaks := aBoolean! ! !MultiCharacterScanner methodsFor: 'multilingual scanning' stamp: 'HenrikSperreJohansen 6/15/2010 19:32'! addCharToPresentation: char lastWidth := self widthOf: char inFont: font. destX := destX + lastWidth. ! ! !MultiCharacterScanner methodsFor: 'multilingual scanning' 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. ! ! !MultiCharacterScanner methodsFor: 'multilingual scanning' stamp: 'HenrikSperreJohansen 6/15/2010 19:33'! removeLastCharFromPresentation destX := destX - lastWidth.! ! !MultiCharacterScanner methodsFor: 'multilingual scanning' stamp: 'yo 1/1/2003 10:43'! widthOf: char inFont: aFont (char isMemberOf: CombinedChar) ifTrue: [ ^ aFont widthOf: char base. ] ifFalse: [ ^ aFont widthOf: char. ]. ! ! !MultiCharacterScanner methodsFor: 'scanner methods' stamp: 'yo 12/30/2002 22:59'! combinableChar: char for: prevEntity ! ! !MultiCharacterScanner methodsFor: 'scanner methods' stamp: 'yo 12/20/2002 11:46'! isBreakableAt: index in: sourceString in: encodingClass ^ encodingClass isBreakableAt: index in: sourceString. ! ! !MultiCharacterScanner methodsFor: 'scanner methods' stamp: 'MarcusDenker 7/9/2012 21:44'! scanJapaneseCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta | ascii encoding f nextDestX maxAscii startEncoding | lastIndex := startIndex. lastIndex > stopIndex ifTrue: [lastIndex := stopIndex. ^ stops endOfRun]. startEncoding := (sourceString at: startIndex) leadingChar. font ifNil: [font := (TextSharedInformation at: #DefaultMultiStyle) fontArray at: 1]. font isFontSet ifTrue: [ f := [font fontArray at: startEncoding + 1] on: Exception do: [:ex | nil]. f ifNil: [ f := font fontArray at: 1]. maxAscii := f maxAscii. "xTable := f xTable. maxAscii := xTable size - 2." spaceWidth := f widthOf: Space. ] ifFalse: [ maxAscii := font maxAscii. ]. [lastIndex <= stopIndex] whileTrue: [ "self halt." encoding := (sourceString at: lastIndex) leadingChar. encoding ~= startEncoding ifTrue: [lastIndex := lastIndex - 1. ^ stops endOfRun]. ascii := (sourceString at: lastIndex) charCode. ascii > maxAscii ifTrue: [ascii := maxAscii]. (encoding = 0 and: [ascii < stops size and: [(stops at: ascii + 1) ~~ nil]]) ifTrue: [^ stops at: ascii + 1]. (self isBreakableAt: lastIndex in: sourceString in: (EncodedCharSet charsetAt: encoding)) ifTrue: [ self registerBreakableIndex. ]. nextDestX := destX + (font widthOf: (sourceString at: lastIndex)). nextDestX > rightX ifTrue: [firstDestX ~= destX ifTrue: [^ stops crossedX]]. destX := nextDestX + kernDelta. lastIndex := lastIndex + 1. ]. lastIndex := stopIndex. ^ stops endOfRun! ! !MultiCharacterScanner methodsFor: 'scanning' stamp: 'BenjaminVanRyseghem 2/19/2013 18:58'! basicScanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta "Primitive. This is the inner loop of text display--but see scanCharactersFrom: to:rightX: which would get the string, stopConditions and displaying from the instance. March through source String from startIndex to stopIndex. If any character is flagged with a non-nil entry in stops, then return the corresponding value. Determine width of each character from xTable, indexed by map. If dextX would exceed rightX, then return stops at: 258. Advance destX by the width of the character. If stopIndex has been reached, then return stops at: 257. Optional. See Object documentation whatIsAPrimitive." | ascii nextDestX char floatDestX widthAndKernedWidth nextChar atEndOfRun | lastIndex := startIndex. floatDestX := destX. widthAndKernedWidth := Array new: 2. atEndOfRun := false. [lastIndex <= stopIndex] whileTrue: [ char := (sourceString at: lastIndex). ascii := char asciiValue. (ascii < stops size and: [(stops at: ascii + 1) notNil]) ifTrue: [^ stops at: ascii + 1]. (self isBreakableAt: lastIndex in: sourceString in: Latin1Environment) ifTrue: [ self registerBreakableIndex ]. "Note: The following is querying the font about the width since the primitive may have failed due to a non-trivial mapping of characters to glyphs or a non-existing xTable." nextChar := (lastIndex + 1 <= stopIndex) ifTrue:[sourceString at: lastIndex + 1] ifFalse:[ atEndOfRun := true. "if there is a next char in sourceString, then get the kern and store it in pendingKernX" lastIndex + 1 <= sourceString size ifTrue:[sourceString at: lastIndex + 1] ifFalse:[ nil]]. font widthAndKernedWidthOfLeft: char right: nextChar into: widthAndKernedWidth. nextDestX := floatDestX + (widthAndKernedWidth at: 1). nextDestX > rightX ifTrue: [^stops crossedX]. floatDestX := floatDestX + kernDelta + (widthAndKernedWidth at: 2). atEndOfRun ifTrue:[ pendingKernX := (widthAndKernedWidth at: 2) - (widthAndKernedWidth at: 1). floatDestX := floatDestX - pendingKernX]. destX := floatDestX. lastIndex := lastIndex + 1]. lastIndex := stopIndex. ^ stops endOfRun! ! !MultiCharacterScanner methodsFor: 'scanning' stamp: 'tween 4/6/2007 11:17'! columnBreak pendingKernX := 0. ^true! ! !MultiCharacterScanner methodsFor: 'scanning' stamp: 'sd 2/4/2008 21:22'! embeddedObject | savedIndex | savedIndex := lastIndex. text attributesAt: lastIndex do:[:attr| attr anchoredMorph ifNotNil:[ "Following may look strange but logic gets reversed. If the morph fits on this line we're not done (return false for true) and if the morph won't fit we're done (return true for false)" (self placeEmbeddedObject: attr anchoredMorph) ifFalse:[^true]]]. lastIndex := savedIndex + 1. "for multiple(!!) embedded morphs" ^false! ! !MultiCharacterScanner methodsFor: 'scanning' stamp: 'yo 12/18/2002 13:53'! handleIndentation self indentationLevel timesRepeat: [ self plainTab]! ! !MultiCharacterScanner methodsFor: 'scanning' stamp: 'yo 12/18/2002 13:53'! indentationLevel "return the number of tabs that are currently being placed at the beginning of each line" ^indentationLevel ifNil:[0]! ! !MultiCharacterScanner methodsFor: 'scanning' stamp: 'sd 2/4/2008 21:22'! indentationLevel: anInteger "set the number of tabs to put at the beginning of each line" indentationLevel := anInteger! ! !MultiCharacterScanner methodsFor: 'scanning' stamp: 'yo 12/18/2002 13:53'! leadingTab "return true if only tabs lie to the left" line first to: lastIndex do: [:i | (text at: i) == Tab ifFalse: [^ false]]. ^ true! ! !MultiCharacterScanner methodsFor: 'scanning' stamp: 'MarcusDenker 11/20/2012 09:59'! measureString: aString inFont: aFont from: startIndex to: stopIndex "WARNING: In order to use this method the receiver has to be set up using #initializeStringMeasurer" destX := destY := lastIndex := 0. baselineY := aFont ascent. font := aFont. " added Dec 03, 2004 " " map := aFont characterToGlyphMap." self scanCharactersFrom: startIndex to: stopIndex in: aString rightX: 999999 stopConditions: stopConditions kern: 0. ^destX! ! !MultiCharacterScanner methodsFor: 'scanning' stamp: 'HenrikSperreJohansen 6/15/2010 19:32'! placeEmbeddedObject: anchoredMorph "Place the anchoredMorph or return false if it cannot be placed. In any event, advance destX by its width." | w | "Workaround: The following should really use #textAnchorType" anchoredMorph relativeTextAnchorPosition ifNotNil:[^true]. destX := destX + (w := anchoredMorph width). (destX > rightMargin and: [(leftMargin + w) <= rightMargin]) ifTrue: ["Won't fit, but would on next line" ^ false]. lastIndex := lastIndex + 1. ^ true! ! !MultiCharacterScanner methodsFor: 'scanning' stamp: 'BenjaminVanRyseghem 2/19/2013 17:18'! scanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta | startEncoding selector | sourceString isByteString ifTrue: [ ^ self basicScanCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta ]. sourceString isWideString ifFalse: [ ^ stops endOfRun ]. startIndex > stopIndex ifTrue: [ lastIndex := stopIndex. ^ stops endOfRun ]. startEncoding := (sourceString at: startIndex) leadingChar. selector := (EncodedCharSet charsetAt: startEncoding) scanSelector. ^ self perform: selector withArguments: (Array with: startIndex with: stopIndex with: sourceString with: rightX with: stops with: kernDelta). ! ! !MultiCharacterScanner methodsFor: 'scanning' stamp: 'MarcusDenker 7/9/2012 21:44'! scanMultiCharactersFrom: startIndex to: stopIndex in: sourceString rightX: rightX stopConditions: stops kern: kernDelta | ascii encoding f nextDestX maxAscii startEncoding floatDestX widthAndKernedWidth nextChar atEndOfRun | lastIndex := startIndex. lastIndex > stopIndex ifTrue: [lastIndex := stopIndex. ^ stops endOfRun]. startEncoding := (sourceString at: startIndex) leadingChar. font ifNil: [font := (TextSharedInformation at: #DefaultMultiStyle) fontArray at: 1]. font isFontSet ifTrue: [ f := [font fontArray at: startEncoding + 1] on: Exception do: [:ex | nil]. f ifNil: [ f := font fontArray at: 1]. maxAscii := f maxAscii. spaceWidth := f widthOf: Space. ] ifFalse: [ maxAscii := font maxAscii. ]. floatDestX := destX. widthAndKernedWidth := Array new: 2. atEndOfRun := false. [lastIndex <= stopIndex] whileTrue: [ encoding := (sourceString at: lastIndex) leadingChar. encoding ~= startEncoding ifTrue: [lastIndex := lastIndex - 1. ^ stops endOfRun]. ascii := (sourceString at: lastIndex) charCode. ascii > maxAscii ifTrue: [ascii := maxAscii]. (encoding = 0 and: [ascii < stops size and: [(stops at: ascii + 1) ~~ nil]]) ifTrue: [^ stops at: ascii + 1]. (self isBreakableAt: lastIndex in: sourceString in: Latin1Environment) ifTrue: [ self registerBreakableIndex. ]. 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: (sourceString at: lastIndex) right: nextChar into: widthAndKernedWidth. nextDestX := floatDestX + (widthAndKernedWidth at: 1). nextDestX > rightX ifTrue: [destX ~= firstDestX ifTrue: [^stops crossedX]]. floatDestX := floatDestX + kernDelta + (widthAndKernedWidth at: 2). atEndOfRun ifTrue:[ pendingKernX := (widthAndKernedWidth at: 2) - (widthAndKernedWidth at: 1). floatDestX := floatDestX - pendingKernX]. destX := floatDestX . lastIndex := lastIndex + 1. ]. lastIndex := stopIndex. ^ stops endOfRun! ! !MultiCharacterScanner methodsFor: 'private' stamp: 'sd 2/4/2008 21:22'! addEmphasis: code "Set the bold-ital-under-strike emphasis." emphasisCode := emphasisCode bitOr: code! ! !MultiCharacterScanner methodsFor: 'private' stamp: 'sd 2/4/2008 21:22'! addKern: kernDelta "Set the current kern amount." kern := kern + kernDelta! ! !MultiCharacterScanner methodsFor: 'private' stamp: 'sd 2/4/2008 21:22'! setActualFont: aFont "Set the basal font to an isolated font reference." font := aFont! ! !MultiCharacterScanner methodsFor: 'private' stamp: 'sd 2/4/2008 21:22'! setAlignment: style alignment := style. ! ! !MultiCharacterScanner methodsFor: 'private' stamp: 'sd 2/4/2008 21:22'! setConditionArray: aSymbol aSymbol == #paddedSpace ifTrue: [^stopConditions := PaddedSpaceCondition "copy"]. "aSymbol == #space ifTrue: [^stopConditions := SpaceCondition copy]." aSymbol == nil ifTrue: [^stopConditions := NilCondition "copy"]. self error: 'undefined stopcondition for space character'. ! ! !MultiCharacterScanner methodsFor: 'private' stamp: 'MarcusDenker 11/20/2012 09:59'! setFont | priorFont | "Set the font and other emphasis." priorFont := font. text == nil ifFalse:[ emphasisCode := 0. kern := 0. indentationLevel := 0. alignment := textStyle alignment. font := nil. (text attributesAt: lastIndex forStyle: textStyle) do: [:att | att emphasizeScanner: self]]. font == nil ifTrue: [self setFont: textStyle defaultFontIndex]. font := font emphasized: emphasisCode. priorFont ifNotNil: [ font = priorFont ifTrue:[ "font is the same, perhaps the color has changed? We still want kerning between chars of the same font, but of different color. So add any pending kern to destX" destX := destX + (pendingKernX ifNil:[0])]. destX := destX + priorFont descentKern]. pendingKernX := 0. "clear any pending kern so there is no danger of it being added twice" 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. " map := font characterToGlyphMap." stopConditions := DefaultStopConditions.! ! !MultiCharacterScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:53'! setFont: fontNumber "Set the font by number from the textStyle." self setActualFont: (textStyle fontAt: fontNumber)! ! !MultiCharacterScanner methodsFor: 'private' stamp: 'sd 2/4/2008 21:22'! text: t textStyle: ts text := t. textStyle := ts! ! !MultiCharacterScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:53'! textColor: ignored "Overridden in DisplayScanner"! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MultiCharacterScanner class instanceVariableNames: ''! !MultiCharacterScanner class methodsFor: 'class initialization' stamp: 'nice 3/8/2010 11:55'! initialize " MultiCharacterScanner initialize " | a | a := TextStopConditions new. 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. NilCondition := a copy. DefaultStopConditions := a copy. PaddedSpaceCondition := a copy. PaddedSpaceCondition at: Space asciiValue + 1 put: #paddedSpace. SpaceCondition := a copy. SpaceCondition at: Space asciiValue + 1 put: #space. ! ! ListComposableModel subclass: #MultiColumnListModel instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Spec-Widgets'! !MultiColumnListModel commentStamp: '' prior: 0! 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: 'morphic' stamp: 'StephaneDucasse 5/17/2012 18:03'! setIndex: anIndex self allowToSelect ifFalse: [ ^ self ]. self okToChange ifFalse: [ ^ self ]. selectionHolder index contents: anIndex. selectionHolder selection contents: (self listItems at: anIndex ifAbsent: [ nil ]).! ! !MultiColumnListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/20/2012 16:22'! 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 contents: idx. selectionHolder selection contents: selection.! ! !MultiColumnListModel methodsFor: 'remove me' stamp: 'StephaneDucasse 5/17/2012 18:03'! getIndex ^ selectionHolder index contents! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MultiColumnListModel class instanceVariableNames: ''! !MultiColumnListModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 2/8/2013 14:24'! defaultSpec ^ {#MultiColumnListSpec. #wrapSelector:. #wrapItem:index:. #model:. #model. #getListSizeSelector:. #listSize. #getIndexSelector:. #getIndex. #setIndexSelector:. #setIndex:. #getSelectionListSelector:. #getSelectionStateFor:. #setSelectionListSelector:. #setSelectionStateFor:at:. #getListElementSelector:. #listElementAt:. #resetListSelector:. #resetListSelection. #getMenuSelector:. #menu:shifted:. #setMultipleSelection:. {#model. #multiSelection}. #borderWidth:. #(model borderWidth). #borderColor:. #(model borderColor). #setBalloonText:. { #model . #help}. #hResizing:. #spaceFill. #vResizing:. #spaceFill}! ! ListSpec subclass: #MultiColumnListSpec instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Spec-Core-Specs'! !MultiColumnListSpec commentStamp: '' prior: 0! A MultiColumnListSpec is a spec used to describe a multi column list! !MultiColumnListSpec methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/24/2012 03:15'! classSymbol ^ #MultiColumnList! ! MultiCharacterScanner subclass: #MultiCompositionScanner instanceVariableNames: 'spaceX lineHeight baseline breakableIndex lineHeightAtBreak baselineAtBreak breakAtSpace' classVariableNames: '' poolDictionaries: '' category: 'Text-Scanning'! !MultiCompositionScanner methodsFor: 'accessing' stamp: 'yo 1/3/2003 02:33'! presentation ^ presentation. ! ! !MultiCompositionScanner methodsFor: 'accessing' stamp: 'yo 1/3/2003 02:33'! presentationLine ^ presentationLine. ! ! !MultiCompositionScanner methodsFor: 'accessing' stamp: 'yo 12/18/2002 14:56'! 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." breakAtSpace ifTrue: [^ spaceX]. ^ destX. ! ! !MultiCompositionScanner methodsFor: 'multilingual scanning' stamp: 'HenrikSperreJohansen 6/15/2010 19:35'! addCharToPresentation: char presentation nextPut: char. super addCharToPresentation: char.! ! !MultiCompositionScanner methodsFor: 'multilingual scanning' stamp: 'yo 1/16/2003 17:38'! getPresentation ^ presentation contents. ! ! !MultiCompositionScanner methodsFor: 'multilingual scanning' stamp: 'yo 1/16/2003 17:28'! getPresentationLine ^ presentationLine. ! ! !MultiCompositionScanner methodsFor: 'multilingual scanning' stamp: 'sd 2/4/2008 21:22'! registerBreakableIndex "Record left x and character index of the line-wrappable point. Used for wrap-around. Answer whether the character has crossed the right edge of the composition rectangle of the paragraph." (text at: lastIndex) = Character space ifTrue: [ breakAtSpace := true. spaceX := destX. spaceCount := spaceCount + 1. lineHeightAtBreak := lineHeight. baselineAtBreak := baseline. breakableIndex := lastIndex. destX > rightMargin ifTrue: [^self crossedX]. ] ifFalse: [ breakAtSpace := false. lineHeightAtBreak := lineHeight. baselineAtBreak := baseline. breakableIndex := lastIndex - 1. ]. ^ false. ! ! !MultiCompositionScanner methodsFor: 'multilingual scanning' stamp: 'HenrikSperreJohansen 6/15/2010 19:35'! removeLastCharFromPresentation presentation ifNotNil: [ presentation position: presentation position - 1. ]. super removeLastCharFromPresentation ! ! !MultiCompositionScanner methodsFor: 'scanning' stamp: 'BenjaminVanRyseghem 2/19/2013 17:27'! 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. firstDestX := destX. 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" self setStopConditions. "also sets font" runLength := text runLengthFor: startIndex. runStopIndex := (lastIndex := startIndex) + (runLength - 1). line := (TextLine start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0) rectangle: lineRectangle. presentationLine := (TextLine start: lastIndex stop: 0 internalSpaces: 0 paddingWidth: 0) rectangle: lineRectangle. numOfComposition := 0. spaceCount := 0. self handleIndentation. leftMargin := destX. line leftMargin: leftMargin. presentationLine leftMargin: leftMargin. presentation := TextStream on: (Text fromString: (WideString new: text size)). [false] whileFalse: [stopCondition := self scanCharactersFrom: lastIndex to: runStopIndex in: text string rightX: rightMargin stopConditions: stopConditions kern: kern. "See setStopConditions for stopping conditions for composing." (self perform: stopCondition) ifTrue: [presentationLine lineHeight: lineHeight + textStyle leading baseline: baseline + textStyle leading. ^ line lineHeight: lineHeight + textStyle leading baseline: baseline + textStyle leading]]! ! !MultiCompositionScanner methodsFor: 'scanning' stamp: 'sd 2/4/2008 21:22'! setActualFont: aFont "Keep track of max height and ascent for auto lineheight" | descent | super setActualFont: aFont. "' ', lastIndex printString, ' ' displayAt: (lastIndex * 15)@0." 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]! ! !MultiCompositionScanner methodsFor: 'stop conditions' stamp: 'tween 4/6/2007 11:11'! columnBreak "Answer true. Set up values for the text line interval currently being composed." pendingKernX := 0. line stop: lastIndex. presentationLine stop: lastIndex - numOfComposition. spaceX := destX. line paddingWidth: rightMargin - spaceX. presentationLine paddingWidth: rightMargin - spaceX. ^true! ! !MultiCompositionScanner methodsFor: 'stop conditions' stamp: 'nice 11/16/2009 10:02'! 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. presentationLine stop: lastIndex - numOfComposition. spaceX := destX. line paddingWidth: rightMargin - spaceX. presentationLine paddingWidth: rightMargin - spaceX. ^true! ! !MultiCompositionScanner methodsFor: 'stop conditions' stamp: 'BenjaminVanRyseghem 2/19/2013 17:27'! crossedX "There is a word that has fallen across the right edge of the composition rectangle. This signals the need for wrapping which is done to the last space that was encountered, as recorded by the space stop condition." pendingKernX := 0. breakAtSpace ifTrue: [ spaceCount >= 1 ifTrue: ["The common case. First back off to the space at which we wrap." line stop: breakableIndex. presentationLine stop: breakableIndex - numOfComposition. lineHeight := lineHeightAtBreak. baseline := baselineAtBreak. spaceCount := spaceCount - 1. breakableIndex := breakableIndex - 1. "Check to see if any spaces preceding the one at which we wrap. Double space after punctuation, most likely." [(spaceCount > 1 and: [(text at: breakableIndex) = Space])] whileTrue: [spaceCount := spaceCount - 1. "Account for backing over a run which might change width of space." font := text fontAt: breakableIndex withStyle: textStyle. breakableIndex := breakableIndex - 1. spaceX := spaceX - (font widthOf: Space)]. line paddingWidth: rightMargin - spaceX. presentationLine paddingWidth: rightMargin - spaceX. presentationLine internalSpaces: spaceCount. line internalSpaces: spaceCount] ifFalse: ["Neither internal nor trailing spaces -- almost never happens." lastIndex := lastIndex - 1. [destX <= rightMargin] whileFalse: [destX := destX - (font widthOf: (text at: lastIndex)). lastIndex := lastIndex - 1]. spaceX := destX. line paddingWidth: rightMargin - destX. presentationLine paddingWidth: rightMargin - destX. presentationLine stop: (lastIndex max: line first). line stop: (lastIndex max: line first)]. ^true ]. (breakableIndex isNil or: [breakableIndex < line first]) ifTrue: [ "Any breakable point in this line. Just wrap last character." breakableIndex := lastIndex - 1. lineHeightAtBreak := lineHeight. baselineAtBreak := baseline. ]. "It wasn't a space, but anyway this is where we break the line." line stop: breakableIndex. presentationLine stop: breakableIndex. lineHeight := lineHeightAtBreak. baseline := baselineAtBreak. ^ true. ! ! !MultiCompositionScanner methodsFor: 'stop conditions' stamp: 'sd 2/4/2008 21:22'! 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. presentationLine stop: lastIndex - numOfComposition. spaceX := destX. line paddingWidth: rightMargin - destX. presentationLine paddingWidth: rightMargin - destX. ^true] ifFalse: [ "(text at: lastIndex) charCode = 32 ifTrue: [destX := destX + spaceWidth]." runLength := (text runLengthFor: (lastIndex := lastIndex + 1)). runStopIndex := lastIndex + (runLength - 1). self setStopConditions. ^false] ! ! !MultiCompositionScanner methodsFor: 'stop conditions' stamp: 'sd 2/4/2008 21:22'! placeEmbeddedObject: anchoredMorph | descent | "Workaround: The following should really use #textAnchorType" anchoredMorph relativeTextAnchorPosition ifNotNil:[^true]. (super placeEmbeddedObject: anchoredMorph) ifFalse: ["It doesn't fit" "But if it's the first character then leave it here" lastIndex < line first ifFalse:[ line stop: lastIndex-1. ^ false]]. descent := lineHeight - baseline. lineHeight := lineHeight max: anchoredMorph height. baseline := lineHeight - descent. line stop: lastIndex. presentationLine stop: lastIndex - numOfComposition. ^ true! ! !MultiCompositionScanner methodsFor: 'stop conditions' stamp: 'MarcusDenker 11/20/2012 10:01'! setFont super setFont. breakAtSpace := false. wantsColumnBreaks ifTrue: [ stopConditions := stopConditions copy. stopConditions at: TextComposer characterForColumnBreak asciiValue + 1 put: #columnBreak. ]. ! ! !MultiCompositionScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:57'! setStopConditions "Set the font and the stop conditions for the current run." self setFont! ! !MultiCompositionScanner methodsFor: 'stop conditions' stamp: 'tween 4/6/2007 11:12'! 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 ! ! MultiCharacterScanner subclass: #MultiDisplayScanner instanceVariableNames: 'bitBlt lineY runX foregroundColor backgroundColor fillBlt lineHeight paragraph paragraphColor morphicOffset ignoreColorChanges' classVariableNames: '' poolDictionaries: 'TextConstants' category: 'Text-Scanning'! !MultiDisplayScanner commentStamp: 'LaurentLaffont 6/8/2011 22:21' prior: 0! I'm a class related to the computation of characters counting for text flow.! !MultiDisplayScanner methodsFor: 'multilingual scanning' stamp: 'yo 12/20/2002 11:52'! isBreakableAt: index in: sourceString in: encodingClass ^ false. ! ! !MultiDisplayScanner methodsFor: 'scanning' stamp: 'HenrikSperreJohansen 6/15/2010 18:47'! 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 | 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 := runX := leftMargin. fillBlt == nil ifFalse: ["Not right" fillBlt destX: line left destY: lineY width: line width left height: lineHeight; copyBits]. lastIndex := line first. leftInRun <= 0 ifTrue: [nowLeftInRun := text runLengthFor: lastIndex] ifFalse: [nowLeftInRun := leftInRun]. baselineY := lineY + line baseline. destY := baselineY - font ascent. runStopIndex := lastIndex + (nowLeftInRun - 1) min: line last. spaceCount := 0. string := text string. [ startIndex := lastIndex. lastPos := destX@destY. stopCondition := self scanCharactersFrom: lastIndex to: runStopIndex in: string rightX: rightMargin stopConditions: stopConditions kern: kern. lastIndex >= startIndex ifTrue:[ bitBlt displayString: string from: startIndex "XXXX: The following is an interesting bug. All stopConditions exept #endOfRun have lastIndex past the last character displayed. #endOfRun sets it *on* the character. If we display up until lastIndex then we will also display invisible characters like CR and tab. This problem should be fixed in the scanner (i.e., position lastIndex consistently) but I don't want to deal with the fallout right now so we keep the fix minimally invasive." to: (stopCondition == #endOfRun ifTrue:[lastIndex] ifFalse:[lastIndex-1]) at: lastPos kern: kern baselineY: baselineY font: font]. (emphasisCode allMask: 4) ifTrue:[ font displayUnderlineOn: bitBlt from: lastPos x@baselineY to: destX@baselineY. ]. (emphasisCode allMask: 16) ifTrue:[ font displayStrikeoutOn: bitBlt from: lastPos x@baselineY to: destX@baselineY. ]. "see setStopConditions for stopping conditions for displaying." self perform: stopCondition. "or: [lastIndex > runStopIndex]." ] whileFalse. ^ runStopIndex - lastIndex "Number of characters remaining in the current run"! ! !MultiDisplayScanner methodsFor: 'scanning' stamp: 'sd 2/4/2008 21:22'! placeEmbeddedObject: anchoredMorph anchoredMorph relativeTextAnchorPosition ifNotNil:[ anchoredMorph position: anchoredMorph relativeTextAnchorPosition + (anchoredMorph owner textBounds origin x @ 0) - (0@morphicOffset y) + (0@lineY). ^true ]. (super placeEmbeddedObject: anchoredMorph) ifFalse: [^ false]. anchoredMorph isMorph ifTrue: [ anchoredMorph position: ((destX - anchoredMorph width)@lineY) - morphicOffset ] ifFalse: [ destY := lineY. baselineY := lineY + anchoredMorph height.. runX := destX. anchoredMorph displayOn: bitBlt destForm at: destX - anchoredMorph width @ destY clippingBox: bitBlt clipRect rule: Form blend fillColor: Color white ]. ^ true! ! !MultiDisplayScanner methodsFor: 'stop conditions' stamp: 'nice 11/16/2009 15:01'! cr "When a carriage return is encountered, simply increment the pointer into the paragraph." pendingKernX := 0. (lastIndex < text size and: [(text at: lastIndex) = CR and: [(text at: lastIndex+1) = Character lf]]) ifTrue: [lastIndex := lastIndex + 2] ifFalse: [lastIndex := lastIndex + 1]. ^false! ! !MultiDisplayScanner methodsFor: 'stop conditions' stamp: 'yo 12/18/2002 13:58'! 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 ectangle since it is in the normal case not visible and is in any case appropriately clipped by the scanner." ^ true ! ! !MultiDisplayScanner methodsFor: 'stop conditions' stamp: 'sd 2/4/2008 21:22'! 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 | lastIndex = line last ifTrue: [^true]. runX := destX. runLength := text runLengthFor: (lastIndex := lastIndex + 1). runStopIndex := lastIndex + (runLength - 1) min: line last. self setStopConditions. ^ false! ! !MultiDisplayScanner methodsFor: 'stop conditions' stamp: 'tween 4/6/2007 12:52'! paddedSpace "Each space is a stop condition when the alignment is right justified. Padding must be added to the base width of the space according to which space in the line this space is and according to the amount of space that remained at the end of the line when it was composed." spaceCount := spaceCount + 1. destX := destX + spaceWidth + (line justifiedPadFor: spaceCount font: font). lastIndex := lastIndex + 1. pendingKernX := 0. ^ false! ! !MultiDisplayScanner methodsFor: 'stop conditions' stamp: 'sd 2/4/2008 21:22'! plainTab | oldX | oldX := destX. super plainTab. fillBlt == nil ifFalse: [fillBlt destX: oldX destY: destY width: destX - oldX height: font height; copyBits]! ! !MultiDisplayScanner methodsFor: 'stop conditions' stamp: 'sd 2/4/2008 21:22'! setStopConditions "Set the font and the stop conditions for the current run." self setFont. self setConditionArray: (alignment = Justified ifTrue: [#paddedSpace]). " alignment = Justified ifTrue: [ stopConditions == DefaultStopConditions ifTrue:[stopConditions := stopConditions copy]. stopConditions at: Space asciiValue + 1 put: #paddedSpace] "! ! !MultiDisplayScanner methodsFor: 'stop conditions' stamp: 'sd 2/4/2008 21:22'! tab self plainTab. lastIndex := lastIndex + 1. ^ false! ! !MultiDisplayScanner methodsFor: 'private' stamp: 'sd 2/4/2008 21:22'! presentationText: t text := t. ! ! !MultiDisplayScanner methodsFor: 'private' stamp: 'yo 12/18/2002 13:58'! setDestForm: df bitBlt setDestForm: df.! ! !MultiDisplayScanner methodsFor: 'private' stamp: 'sd 2/4/2008 21:22'! setFont foregroundColor := paragraphColor. super setFont. "Sets font and emphasis bits, and maybe foregroundColor" font installOn: bitBlt foregroundColor: foregroundColor backgroundColor: Color transparent. text ifNotNil:[ baselineY := lineY + line baseline. destY := baselineY - font ascent]. ! ! !MultiDisplayScanner methodsFor: 'private' stamp: 'sd 2/4/2008 21:22'! 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" ! ! !MultiDisplayScanner methodsFor: 'private' stamp: 'sd 2/4/2008 21:22'! text: t textStyle: ts foreground: foreColor background: backColor fillBlt: blt ignoreColorChanges: shadowMode text := t. textStyle := ts. foregroundColor := paragraphColor := foreColor. (backgroundColor := backColor) isTransparent ifFalse: [fillBlt := blt. fillBlt fillColor: backgroundColor]. ignoreColorChanges := shadowMode! ! !MultiDisplayScanner methodsFor: 'private' stamp: 'sd 2/4/2008 21:22'! textColor: textColor ignoreColorChanges ifTrue: [^ self]. foregroundColor := textColor! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MultiDisplayScanner class instanceVariableNames: ''! !MultiDisplayScanner class methodsFor: 'queries' stamp: 'yo 12/18/2002 13:58'! defaultFont ^ TextStyle defaultFont! ! LazyListMorph subclass: #MulticolumnLazyListMorph instanceVariableNames: 'columnWidths' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Widgets'! !MulticolumnLazyListMorph commentStamp: '' prior: 0! A variant of LazyListMorph that can display multi-column lists.! !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: 'BenjaminVanRyseghem 9/8/2011 12:33'! drawOn: aCanvas self getListSize = 0 ifTrue:[ ^self ]. self setColumnWidthsFor: aCanvas. self adjustWidth. super drawOn: aCanvas! ! !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: 'list access' stamp: 'ls 5/17/2001 21:23'! getListItem: index ^listSource getListRow: index! ! !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! ! !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: 'row management' stamp: 'ls 5/18/2001 16:43'! listChanged columnWidths := nil. super listChanged! ! !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: '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" ! ! PanelMorph subclass: #MultipleMethodsEditor instanceVariableNames: 'buttonsContainer container current editors lock' classVariableNames: '' poolDictionaries: '' category: 'Nautilus'! !MultipleMethodsEditor commentStamp: '' prior: 0! A MultipleMethodsEditor is a widget to edit multiple methods in one widget! !MultipleMethodsEditor methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 8/6/2012 00:56'! initialize "Initialization code for MultipleMethodsEditor" 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: '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: '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: 'protocol' stamp: 'BenjaminVanRyseghem 8/5/2012 19:47'! hasSingleElement ^ editors size = 1! ! !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: '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 18:04'! setCurrent: anEditor (editors includes: anEditor) ifFalse: [ ^ self ]. current := anEditor! ! !MultipleMethodsEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 8/6/2012 19:33'! setDefault current := editors first! ! !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: '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: 'BenjaminVanRyseghem 8/6/2012 17:59'! addAllButton buttonsContainer addMorph: self newAllButton! ! !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: '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: '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: '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).! ! !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: 'updating' stamp: 'IgorStasenko 12/19/2012 18:05'! updateLayoutForSingleWithButtons current ifNil: [ ^ self ]. self addMorph: current fullFrame: (LayoutFrame identity topOffset: -25). self addMorph: buttonsContainer fullFrame: ((0@1 corner: 1@1) asLayoutFrame topOffset: -25). current color: Color white. ! ! !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: '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: 'updating' stamp: 'BenjaminVanRyseghem 8/5/2012 22:11'! updateScrollerWithOneElement "container addMorph: current fullFrame: (LayoutFrame fractions: (0@0 corner: 1@1))"! ! !MultipleMethodsEditor methodsFor: 'private' stamp: 'BenjaminVanRyseghem 8/5/2012 22:04'! addHFill buttonsContainer addMorph: (Morph new hResizing: #spaceFill; height: 0; yourself)! ! !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: '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: '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: '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: 'private' stamp: 'BenjaminVanRyseghem 8/5/2012 22:04'! newProportionalPanelMorph | panel | panel := PanelMorph new color: Color white; changeProportionalLayout; yourself. ^ panel! ! !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: '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! ! Model subclass: #MultipleMethodsEditorAllButtonModel instanceVariableNames: 'model state' classVariableNames: '' poolDictionaries: '' category: 'Nautilus'! !MultipleMethodsEditorAllButtonModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/6/2012 18:00'! model ^ model! ! !MultipleMethodsEditorAllButtonModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/6/2012 18:00'! model: anObject model := anObject! ! !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: 'protocol' stamp: 'BenjaminVanRyseghem 8/6/2012 18:22'! initialize "Initialization code for MultipleMethodsEditorAllButtonModel" super initialize. state := true.! ! !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:18'! state ^ state! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MultipleMethodsEditorAllButtonModel class instanceVariableNames: ''! !MultipleMethodsEditorAllButtonModel class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 8/6/2012 18:00'! on: aModel ^ self new model: aModel; yourself! ! Model subclass: #MultipleMethodsEditorButtonModel instanceVariableNames: 'label model state target' classVariableNames: '' poolDictionaries: '' category: 'Nautilus'! !MultipleMethodsEditorButtonModel commentStamp: '' prior: 0! A MultipleMethodsEditorButtonModel is a ButtonModel created for MultipleMethodsEditor! !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 ^ model! ! !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 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: 'protocol' stamp: 'BenjaminVanRyseghem 8/6/2012 18:18'! initialize "Initialization code for MultipleMethodsEditorButtonModel" super initialize. state := false! ! !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:18'! state ^ state! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! MultipleMethodsEditorButtonModel class instanceVariableNames: ''! !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! ! !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! ! SettingDeclaration subclass: #MultipleSettingDeclaration instanceVariableNames: 'domainValues' classVariableNames: '' poolDictionaries: '' category: 'System-Settings-Core'! !MultipleSettingDeclaration methodsFor: 'accessing' stamp: 'AlainPlantec 9/3/2010 15:51'! domainValues ^ domainValues ifNil: [domainValues := OrderedCollection new]! ! !MultipleSettingDeclaration methodsFor: 'accessing' stamp: 'AlainPlantec 11/25/2009 22:09'! domainValues: aCollection domainValues := aCollection asArray collect: [ :v | v settingFixedDomainValueNodeFrom: self]! ! !MultipleSettingDeclaration methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'AlainPlantec 9/3/2010 17:04'! fixedDomainValueNodeForObject: anObject | s | ^ (s := (SettingDeclaration new name: anObject asString)) target: s; selector: #default; default: anObject! ! !MultipleSettingDeclaration methodsFor: 'user interface' stamp: 'AlainPlantec 11/25/2009 22:09'! domainValuesLabels ^ self domainValues collect: [:f | f name]! ! !MultipleSettingDeclaration methodsFor: 'user interface' stamp: 'AlainPlantec 11/25/2009 22:09'! hasEditableList ^ false! ! Morph subclass: #MultistateButtonMorph instanceVariableNames: 'enabled active over down stateMap' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !MultistateButtonMorph commentStamp: 'gvc 10/21/2008 13:27' prior: 0! 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'! active "Answer the value of active" ^ active! ! !MultistateButtonMorph methodsFor: 'accessing' stamp: 'gvc 10/21/2008 15:57'! active: anObject "Set the value of active" active := anObject. self changed! ! !MultistateButtonMorph methodsFor: 'accessing' stamp: 'gvc 10/21/2008 13:31'! down "Answer the value of down" ^ down! ! !MultistateButtonMorph methodsFor: 'accessing' stamp: 'gvc 10/21/2008 15:57'! down: anObject "Set the value of down" down := anObject. self changed! ! !MultistateButtonMorph methodsFor: 'accessing' stamp: 'gvc 10/21/2008 13:28'! enabled "Answer whether the button is rnabled." ^enabled! ! !MultistateButtonMorph methodsFor: 'accessing' stamp: 'gvc 10/21/2008 15:57'! enabled: anObject "Set the value of enabled" enabled := anObject. self changed! ! !MultistateButtonMorph methodsFor: 'accessing' stamp: 'gvc 10/21/2008 13:31'! over "Answer the value of over" ^ over! ! !MultistateButtonMorph methodsFor: 'accessing' stamp: 'gvc 10/21/2008 15:57'! over: anObject "Set the value of over" over := anObject. self changed! ! !MultistateButtonMorph methodsFor: 'accessing' stamp: 'gvc 10/21/2008 13:28'! stateMap "Answer the value of stateMap" ^ stateMap! ! !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/21/2008 16:50'! activate "Make active." super activate. self active: true! ! !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: 'as yet unclassified' stamp: 'gvc 10/22/2008 11:38'! addUpAction: anActionOrBlock "Add an up event handler." self when: #up evaluate: anActionOrBlock! ! !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: 'as yet unclassified' stamp: 'gvc 10/21/2008 16:32'! handlesMouseDown: evt "Yes." ^true! ! !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: '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/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: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: '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: '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: '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/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: 'as yet unclassified' stamp: 'gvc 10/21/2008 16:50'! passivate "Make passive." super passivate. self active: false! ! !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: 'as yet unclassified' stamp: 'gvc 10/22/2008 11:39'! removeDownActions "Remove all down event handlers" self removeActionsForEvent: #down! ! !MultistateButtonMorph methodsFor: 'as yet unclassified' stamp: 'gvc 10/22/2008 11:39'! removeUpActions "Remove all up event handlers" self removeActionsForEvent: #up! ! !MultistateButtonMorph methodsFor: 'initialize-release' 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: '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: '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: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:17'! activeDisabledOverDownFillStyle: aFillStyle "Set the active, disabled, over, down fill style." self stateMap atPath: #(active disabled over down) put: aFillStyle. self changed! ! !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: '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: '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:17'! activeEnabledOverDownFillStyle: aFillStyle "Set the active, enabled, over, down fill style." self stateMap atPath: #(active enabled over down) put: aFillStyle. self changed! ! !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: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: '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: '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: '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'! passiveDisabledNotOverUpFillStyle: aFillStyle "Set the passive, disabled, notOver, up fill style." self stateMap atPath: #(passive 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: '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:44'! passiveEnabledNotOverDownFillStyle: aFillStyle "Set the passive, enabled, notOver, down fill style." self stateMap atPath: #(passive enabled 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: '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: '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! ! LabelMorph subclass: #MultistateLabelMorph instanceVariableNames: 'colorMap' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !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: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:40'! disabledColor "Answer the disabled colour." ^self colorMap at: #disabled! ! !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: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: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:20'! initialize "Set up a default colour map." colorMap := self defaultColorMap. super initialize! ! !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:36'! mouseOverColor: aColor "Set the mouseOver colour." self colorMap at: #mouseOver 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'! pressedColor: aColor "Set the pressed colour." self colorMap at: #pressed put: aColor! ! !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: '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:37'! selectedMouseOverColor: aColor "Set the selectedMouseOver colour." self colorMap at: #selectedMouseOver 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! ! Object subclass: #Mutex instanceVariableNames: 'semaphore owner' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Processes'! !Mutex commentStamp: '' prior: 0! 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: 'initialize' 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]].! ! Object subclass: #MutexSet instanceVariableNames: 'array' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Processes'! !MutexSet commentStamp: '' prior: 0! A MutexSet helps with aquiring a set of mutexes.! !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 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 class instanceVariableNames: ''! !MutexSet class methodsFor: 'instance creation' stamp: 'das 11/3/2005 22:54'! withAll: mutexList ^self new withAll: mutexList! ! Error subclass: #MyResumableTestError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Exceptions'! !MyResumableTestError methodsFor: 'exceptiondescription' stamp: 'tfei 6/13/1999 00:46'! isResumable ^true! ! Error subclass: #MyTestError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Exceptions'! Notification subclass: #MyTestNotification instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Exceptions'! Object subclass: #NBBasicExamples instanceVariableNames: '' classVariableNames: '' poolDictionaries: 'AJx86Registers' category: 'NativeBoost-Examples'! !NBBasicExamples commentStamp: '' prior: 0! I am a collection on examples on how to use the NativeBoost infrastructure. Check my class-side methods for more details.! !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: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: '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: '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: '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: '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 instanceVariableNames: ''! !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: 'basc-types' stamp: 'CamilloBruni 7/16/2012 10:33'! returnFloat! ! !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: '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: '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-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-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: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: '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: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-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: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. ]! ! !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: '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: '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: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: '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'! 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:13'! returnSpecialObjectsArray ^ self nbCallout function: #( oop ( void) ) emit: [:gen :proxy :asm | "store the special objects array into EAX" proxy specialObjectsArray. ]! ! NBExternalType subclass: #NBBool instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Types'! !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/28/2010 16:10'! 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 EAX with: asm EAX; je: lfalse. proxy trueObject. asm jmp: done. asm label: lfalse. proxy falseObject. asm label: done.! ! !NBBool methodsFor: 'emitting code' stamp: 'Igor.Stasenko 4/30/2010 13:55'! pushAsValue: gen gen asm push: (gen proxy booleanValueOf: (loader emitLoad: gen)). ! ! NBExternalType subclass: #NBBootstrapUlong instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Types'! !NBBootstrapUlong commentStamp: 'Igor.Stasenko 5/14/2010 18:01' prior: 0! 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: '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! ! !NBBootstrapUlong methodsFor: 'emitting code' stamp: 'Igor.Stasenko 5/3/2010 01:29'! 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 firstIndexableField: asm EAX. "EAX - address , where to store result " asm mov: result to: asm ECX. asm mov: asm ECX to: asm EAX ptr. "primitive will return nil" proxy nilObject ! ! NBExternalType subclass: #NBByteArrayPtr instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Types'! !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: 'IgorStasenko 8/3/2011 19:47'! pushAsPointer: gen self error: 'ByteArrayPtr is already pointer'! ! !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 ]! ! NBExternalType subclass: #NBByteArraySize instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Types'! !NBByteArraySize commentStamp: 'Igor.Stasenko 5/3/2010 13:56' prior: 0! A helper type, which takes a byte array argument and pushing its size! !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 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: '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! ! Object subclass: #NBCPrinter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Examples'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NBCPrinter class instanceVariableNames: 'printFormat'! !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! ! Object subclass: #NBCallbackCodeGen instanceVariableNames: 'gen asm proxy savedEBX savedESI savedEDI savedCStackPointer savedCFramePointer cbIndex savedReenterInterpreter' classVariableNames: '' poolDictionaries: 'AJx86Registers' category: 'NativeBoost-Core-Objects'! !NBCallbackCodeGen commentStamp: '' prior: 0! 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 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 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: '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: '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: '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 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 ]! ! !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 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 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: 'global addresses' stamp: 'EstebanLorenzano 2/13/2013 16:27'! CFramePointerAddress ^ NativeBoost loadSymbol: 'CFramePointer' fromModule: NativeBoost VMModule! ! !NBCallbackCodeGen methodsFor: 'global addresses' stamp: 'IgorStasenko 5/7/2012 12:36'! CStackPointerAddress ^ NativeBoost loadSymbol: 'CStackPointer' fromModule: NativeBoost VMModule! ! !NBCallbackCodeGen methodsFor: 'global addresses' stamp: 'IgorStasenko 9/10/2012 12:49'! reenterInterpreterAddress ^ (NativeBoost loadSymbol: 'reenterInterpreter' fromModule: NativeBoost VMModule) value asUImm32 ! ! !NBCallbackCodeGen methodsFor: 'misc' stamp: 'IgorStasenko 5/7/2012 22:31'! generator: agen gen := agen. asm := gen asm. proxy := gen proxy.! ! !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: 'primitives' stamp: 'IgorStasenko 9/10/2012 12:23'! primJumpBufSize self error: 'a primitive failed. (seems like you using outdated VM)'! ! NBExternalType subclass: #NBCharacterType instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Types'! !NBCharacterType commentStamp: '' prior: 0! Character type. Represented as single byte on C side. Accepts Character/Smallint as argument, converts return value to Character instance! !NBCharacterType methodsFor: 'accessing' stamp: 'IgorStasenko 9/2/2012 23:34'! valueSize ^ 1! ! !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: '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 ! ! Error subclass: #NBCodeGenRecursion instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Errors'! !NBCodeGenRecursion commentStamp: '' prior: 0! 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! NBInterpreterProxy subclass: #NBCogInterpreterProxy instanceVariableNames: '' classVariableNames: '' poolDictionaries: 'AJx86Registers' category: 'NativeBoost-Core'! !NBCogInterpreterProxy commentStamp: '' prior: 0! I am a specialized interpreter proxy for the Cog family of intererpreters! NBExternalHandle variableByteSubclass: #NBExternalAddress uses: TNBMemoryAccessors @ {#byteAt:->#nbInt8AtOffset:. #byteAt:put:->#nbInt8AtOffset:put:. #longAt:->#nbInt32AtOffset:. #longAt:put:->#nbInt32AtOffset:put:. #ulongAt:->#nbUInt32AtOffset:. #ulongAt:put:->#nbUInt32AtOffset:put:} instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Objects'! !NBExternalAddress commentStamp: 'IgorStasenko 2/24/2012 17:10' prior: 0! 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'! 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'! 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'! 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'! 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'! 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: 'as yet unclassified'! 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'! 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'! 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'! 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'! 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'! 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: 'as yet unclassified'! 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'! 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'! 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: 'as yet unclassified'! 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'! 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'! 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'! 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'! 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: 'as yet unclassified'! 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 methodsFor: 'as yet unclassified'! 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: 'as yet unclassified'! 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'! 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'! 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: 'as yet unclassified'! 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'! 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: 'finalization' stamp: 'CamilloBruni 8/3/2012 15:27'! finalize self free! ! !NBExternalAddress methodsFor: 'finalization' stamp: 'CamilloBruni 8/3/2012 15:27'! free NativeBoost free: self! ! !NBExternalAddress methodsFor: 'finalization' stamp: 'CamilloBruni 8/3/2012 15:30'! freeAfterUse "add ourselves to finalization registry" NBExternalResourceManager addResource: self data: self value. ! ! !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: 'string access' stamp: 'Igor.Stasenko 5/24/2010 16:09'! writeString: aString "write a null-terminated byte string to receiver's address" | str | str := aString copyWith: (Character value: 0). NativeBoost memCopy: str to: self size: str size. ! ! !NBExternalAddress methodsFor: 'testing' stamp: 'IgorStasenko 8/4/2011 07:06'! notNull ^ self value ~= 0! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NBExternalAddress class uses: TNBMemoryAccessors classTrait instanceVariableNames: ''! !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! ! !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! ! NBExternalType subclass: #NBExternalAddressType instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Types'! !NBExternalAddressType methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/4/2010 00:56'! valueSize ^ self pointerSize! ! !NBExternalAddressType methodsFor: 'emitting code' stamp: 'Igor.Stasenko 5/19/2010 12:15'! coerceReturnValue: gen "input: address is in EAX. output: ExternalAddress instance oop in EAX creates an instance of NBExternalAddress and store the address there" | asm proxy result | proxy := gen proxy. asm := gen asm. result := gen reserveTemp. asm mov: asm EAX to: result. proxy createInstanceOf: NBExternalAddress size: NBExternalType pointerSize. asm mov: result to: asm ECX. proxy storePointer: asm ECX intoVarbytes: asm EAX at: 0. "return the oop in EAX" gen releaseTemps: 1. ! ! !NBExternalAddressType methodsFor: 'emitting code' stamp: 'CamilloBruni 7/23/2012 13:29'! 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: '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. ! ! ArrayedCollection subclass: #NBExternalArray instanceVariableNames: 'data size' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Objects'! !NBExternalArray commentStamp: '' prior: 0! 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'! address "For external memory arrays, sometimes we may need to get an address" ^ data! ! !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: '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'! size ^ size! ! !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: '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: '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: '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: '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: '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: '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 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: '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 class instanceVariableNames: 'elementType elementSize valueType valueSize'! !NBExternalArray class methodsFor: 'accessing' stamp: 'IgorStasenko 12/7/2012 16:45'! elementSize ^ elementSize! ! !NBExternalArray class methodsFor: 'accessing' stamp: 'IgorStasenko 12/7/2012 16:45'! elementType ^ elementType! ! !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: 'class initialization' stamp: 'IgorStasenko 12/7/2012 16:46'! 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) valueSize . self installAccessors.! ! !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: 'instance creation' stamp: 'IgorStasenko 12/7/2012 16:45'! new: numberOfElements ^ self basicNew initializeWithSize: numberOfElements! ! !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: 'private' stamp: 'CiprianTeodorov 12/16/2012 15:49'! anonymousSubclassInitElementType: aTypeName "create and initialize the anonymous subclass of me" | newSubclass | newSubclass := ClassBuilder new newSubclassOf: NBExternalArray type: NBExternalArray typeOfClass instanceVariables: '' from: nil. "we're not using 'self' to avoid wrong subclassing from anonymous subclass " newSubclass initElementType: aTypeName. ^ newSubclass! ! !NBExternalArray class methodsFor: 'private' stamp: 'IgorStasenko 12/7/2012 16:08'! 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 " self basicAddSelector: #at: withMethod: (NBExternalArray >> #at: ) copy. self basicAddSelector: #at:put: withMethod: (NBExternalArray >> #at:put: ) copy. ! ! SharedPool subclass: #NBExternalEnumeration instanceVariableNames: 'value' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Objects'! !NBExternalEnumeration commentStamp: 'CiprianTeodorov 12/12/2012 23:03' prior: 0! 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:05'! item ^ self class itemAt: value! ! !NBExternalEnumeration methodsFor: 'accessing' stamp: 'CamilloBruni 2/23/2013 13:06'! value ^value! ! !NBExternalEnumeration methodsFor: 'accessing' stamp: 'CamilloBruni 2/23/2013 13:06'! value: anObject value := anObject ! ! !NBExternalEnumeration methodsFor: 'comparing' stamp: 'CamilloBruni 2/23/2013 13:05'! = anEnumInst ^ self class == anEnumInst class and: [ self value = anEnumInst 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 instanceVariableNames: 'representationType'! !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/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: 'accessing' stamp: 'CiprianTeodorov 12/10/2012 20:17'! itemAt: aValue ^ self itemAt: aValue 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 2/6/2013 21:34'! representationType ^representationType! ! !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: '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: 'converting' stamp: 'CiprianTeodorov 2/6/2013 21:34'! asNBExternalType: aTypeName ^ NBExternalEnumerationType objectClass: self representationType: self representationType! ! !NBExternalEnumeration class methodsFor: 'enum declaration' stamp: 'CiprianTeodorov 12/15/2012 15:19'! enumDecl ^#()! ! !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: 'instance creation' stamp: 'CiprianTeodorov 12/10/2012 19:59'! new ^self shouldNotImplement ! ! !NBExternalEnumeration class methodsFor: 'testing' stamp: 'CiprianTeodorov 12/10/2012 19:47'! includes: aSymbol ^self classPool includesKey: aSymbol ! ! NBExternalType subclass: #NBExternalEnumerationType instanceVariableNames: 'representationType objectClass' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Types'! !NBExternalEnumerationType methodsFor: 'accessing' stamp: 'CiprianTeodorov 12/25/2012 13:29'! objectClass ^ objectClass! ! !NBExternalEnumerationType methodsFor: 'accessing' stamp: 'CiprianTeodorov 12/25/2012 13:29'! objectClass: anObject objectClass := anObject! ! !NBExternalEnumerationType methodsFor: 'accessing' stamp: 'CiprianTeodorov 12/11/2012 19:19'! representationType ^ representationType! ! !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 21:45'! valueSize ^4! ! !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: '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'! pushAsPointer: gen "push a pointer to handle value" | asm proxy oop | self assert: (pointerArity = 1). proxy := gen proxy. asm := gen asm. oop := gen reserveTemp. loader emitLoad: gen to: oop. self verifyClassOf: oop is: objectClass generator: gen. proxy fetchPointer: (self valueIvarIndex) ofObject: oop. "value ivar" proxy firstIndexableField: asm EAX. "value ptr" asm push: asm EAX. gen releaseTemps: 1.! ! !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: 'printing' stamp: 'CiprianTeodorov 12/25/2012 13:29'! printOn: aStream aStream nextPutAll: 'External enum(' , objectClass name , ')' ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NBExternalEnumerationType class instanceVariableNames: ''! !NBExternalEnumerationType class methodsFor: 'instance creation' stamp: 'CiprianTeodorov 12/25/2012 13:29'! objectClass: aClass ^ self objectClass: aClass representationType: NBUInt32 new! ! !NBExternalEnumerationType class methodsFor: 'instance creation' stamp: 'CiprianTeodorov 12/25/2012 13:29'! objectClass: aClass representationType: anIntegerType ^ self new objectClass: aClass; representationType: anIntegerType! ! Object variableByteSubclass: #NBExternalHandle instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Objects'! !NBExternalHandle commentStamp: 'IgorStasenko 2/24/2012 17:37' prior: 0! 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 13:25'! asUImm ^ self asUnsignedLong asUImm! ! !NBExternalHandle methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/3/2010 13:32'! asUImm32 ^ self asUnsignedLong asUImm32! ! !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: 'printing' stamp: 'Igor.Stasenko 4/29/2010 12:28'! printOn: aStream aStream nextPutAll: '@ 16r'; nextPutAll: (self value printStringBase: 16) ! ! !NBExternalHandle methodsFor: 'testing' stamp: 'IgorStasenko 6/2/2012 14:38'! isNull ^ self value = 0! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NBExternalHandle class instanceVariableNames: ''! !NBExternalHandle class methodsFor: 'fields description' stamp: 'IgorStasenko 5/26/2012 14:57'! instanceSize ^ NBExternalType pointerSize ! ! !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: 'IgorStasenko 5/26/2012 14:55'! new ^ self basicNew: self instanceSize ! ! !NBExternalHandle class methodsFor: 'instance creation' stamp: 'Igor.Stasenko 5/2/2010 14:08'! value: aValue ^ self new value: aValue! ! Object subclass: #NBExternalHeapManager instanceVariableNames: 'pages freeBlocks reservedBlocks sema' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Heap'! !NBExternalHeapManager commentStamp: 'Igor.Stasenko 9/25/2010 10:04' prior: 0! 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: 'abstract' stamp: 'Igor.Stasenko 9/25/2010 00:19'! primAllocatePage: numBytes self subclassResponsibility ! ! !NBExternalHeapManager methodsFor: 'abstract' stamp: 'Igor.Stasenko 9/25/2010 00:19'! primFreePage: aMemoryPage self subclassResponsibility ! ! !NBExternalHeapManager methodsFor: 'accessing' stamp: 'Igor.Stasenko 9/25/2010 00:36'! numAllocatedBlocks ^ reservedBlocks size! ! !NBExternalHeapManager methodsFor: 'accessing' stamp: 'Igor.Stasenko 9/25/2010 00:22'! numBlocks ^ freeBlocks size + reservedBlocks size! ! !NBExternalHeapManager methodsFor: 'accessing' stamp: 'Igor.Stasenko 9/25/2010 00:36'! numFreeBlocks ^ freeBlocks size! ! !NBExternalHeapManager methodsFor: 'accessing' stamp: 'Igor.Stasenko 9/25/2010 00:22'! numPages ^ pages 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: '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: '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: 'callbacks' stamp: 'Igor.Stasenko 9/24/2010 23:43'! removeFreeBlock: aMemoryBlock freeBlocks remove: aMemoryBlock ifAbsent: []! ! !NBExternalHeapManager methodsFor: 'initialize-release' stamp: 'Igor.Stasenko 9/24/2010 23:57'! initialize sema := Semaphore forMutualExclusion. pages := Dictionary new. freeBlocks := IdentitySet new. reservedBlocks := Dictionary new.! ! !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: '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: '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: 'memory pages' stamp: 'Igor.Stasenko 9/25/2010 00:35'! minimumPageSize " lets grab minimum 32kb pages" ^ 32768! ! !NBExternalHeapManager methodsFor: 'memory pages' stamp: 'Igor.Stasenko 9/25/2010 00:06'! pageAlignment " x86 4kb pages" ^ 4096! ! !NBExternalHeapManager methodsFor: 'testing' stamp: 'Igor.Stasenko 9/24/2010 23:51'! isValidAddress: anAddress ^ self isValidAddress: anAddress size: 1! ! !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)]] ]! ! Object subclass: #NBExternalLibraryWrapper instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-FFI'! !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 instanceVariableNames: ''! !NBExternalLibraryWrapper class methodsFor: 'as yet unclassified' 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: 'as yet unclassified' 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! ! !NBExternalLibraryWrapper class methodsFor: 'as yet unclassified' 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 ]! ! Object subclass: #NBExternalObject instanceVariableNames: 'handle' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Objects'! !NBExternalObject commentStamp: 'IgorStasenko 2/24/2012 17:40' prior: 0! 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: '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: 'initialize-release' stamp: 'Igor.Stasenko 4/29/2010 12:25'! initialize handle := NBExternalHandle new! ! !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 instanceVariableNames: ''! !NBExternalObject class methodsFor: 'instance creation' stamp: 'Igor.Stasenko 4/29/2010 09:18'! asNBExternalType: gen ^ NBExternalObjectType objectClass: self! ! !NBExternalObject class methodsFor: 'instance creation' stamp: 'Igor.Stasenko 5/17/2010 14:29'! null ^ self new! ! NBExternalType subclass: #NBExternalObjectType instanceVariableNames: 'objectClass' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Types'! !NBExternalObjectType commentStamp: 'Igor.Stasenko 4/29/2010 09:17' prior: 0! I providing coercions for NBExternalObject and its subclasses! !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 ^ objectClass! ! !NBExternalObjectType methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/29/2010 09:18'! objectClass: aClass objectClass := aClass! ! !NBExternalObjectType methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/29/2010 13:52'! valueSize ^ self pointerSize! ! !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: 'emitting code' stamp: 'IgorStasenko 8/29/2012 14:54'! 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: 4. asm mov: asm EAX to: handleOop. proxy firstIndexableField: asm EAX. asm mov: result to: asm ECX; mov: asm ECX to: asm EAX ptr. proxy pushRemappableOop: handleOop. 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: 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: 'Igor.Stasenko 5/18/2010 02:46'! pushAsPointer: gen "push a pointer to handle value" | asm proxy oop | self assert: (pointerArity = 1). proxy := gen proxy. asm := gen asm. oop := gen reserveTemp. loader emitLoad: gen to: oop. self verifyClassOf: oop is: objectClass generator: gen. proxy fetchPointer: (self handleIvarIndex) ofObject: oop. "handle ivar" proxy firstIndexableField: asm EAX. "handle value ptr" asm push: asm EAX. gen releaseTemps: 1. ! ! !NBExternalObjectType methodsFor: 'emitting code' stamp: 'JavierPimas 11/14/2011 15:17'! 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 firstIndexableField: asm EAX. "handle value ptr" asm mov: asm EAX ptr to: asm EAX. "handle value" asm push: asm EAX. gen releaseTemps: 1. ! ! !NBExternalObjectType methodsFor: 'printing' stamp: 'Igor.Stasenko 5/18/2010 01:25'! printOn: aStream aStream nextPutAll: 'External Object(' , objectClass name , ')'! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NBExternalObjectType class instanceVariableNames: ''! !NBExternalObjectType class methodsFor: 'instance creation' stamp: 'Igor.Stasenko 4/29/2010 09:16'! objectClass: aClass ^ self new objectClass: aClass! ! Object subclass: #NBExternalResourceExecutor instanceVariableNames: 'session data resourceClass' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Objects'! !NBExternalResourceExecutor commentStamp: '' prior: 0! 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: 'initialize' 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! ! Object subclass: #NBExternalResourceManager instanceVariableNames: 'registry' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Objects'! !NBExternalResourceManager commentStamp: '' prior: 0! 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 ^ self addResource: anObject data: anObject resourceData ! ! !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: 'initialize-release' stamp: 'IgorStasenko 6/2/2012 14:43'! initialize registry := NBFinalizationRegistry new! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NBExternalResourceManager class instanceVariableNames: 'soleInstance'! !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/23/2012 13:13'! addResource: anObject self soleInstance addResource: anObject ! ! !NBExternalResourceManager class methodsFor: 'resource management' stamp: 'IgorStasenko 3/28/2012 18:42'! addResource: anObject data: aData self soleInstance addResource: anObject data: aData! ! NBExternalType subclass: #NBExternalString instanceVariableNames: 'address' classVariableNames: '' poolDictionaries: 'AJx86Registers' category: 'NativeBoost-Core-Types'! !NBExternalString commentStamp: 'IgorStasenko 8/10/2011 18:46' prior: 0! 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: '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: 'IgorStasenko 8/10/2011 18:41'! 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 firstIndexableField: 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: '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 | 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 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; " 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 4/28/2010 20:26'! pushAsPointer: gen self error: 'Strings already passed as a pointer'.! ! !NBExternalString methodsFor: 'emitting code' stamp: 'Igor.Stasenko 4/28/2010 13:44'! pushAsValue: gen gen asm push: address. ! ! !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 ! ! Object variableByteSubclass: #NBExternalStructure instanceVariableNames: '' classVariableNames: 'Printing' poolDictionaries: '' category: 'NativeBoost-Core-Objects'! !NBExternalStructure commentStamp: 'JavierPimas 2/3/2012 22:35' prior: 0! I am used for transparent structures: 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. After that you do a initializeAccessors for that class and voila, field accessors are generated automatically. Class Instance Variables: initialized currentFields ! !NBExternalStructure methodsFor: 'dnu' stamp: 'IgorStasenko 8/5/2011 12:01'! doesNotUnderstand: aMessage self class isInitialized ifFalse: [ "retry send after initialization" self class initializeAccessors. ^ aMessage sentTo: self ]. ^ super doesNotUnderstand: aMessage! ! !NBExternalStructure methodsFor: 'printing' stamp: 'IgorStasenko 5/27/2012 03:15'! 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: 'Igor.Stasenko 5/19/2010 09:08'! 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. gen proxy stackValue: 0. "receiver oop" gen proxy firstIndexableField: 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 epilogue. gen emitFailureHandler. ^ gen! ! !NBExternalStructure methodsFor: 'private' stamp: 'IgorStasenko 5/26/2012 17:30'! 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. gen proxy firstIndexableField: asm EAX. 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: 'private' stamp: 'IgorStasenko 5/22/2012 18:06'! fieldAt: aFieldName ^ NBFFICallout handleFailureIn: thisContext sender nativeCode: [:gen | self emitRead: aFieldName generator: gen. gen bytes ] ! ! !NBExternalStructure methodsFor: 'private' stamp: 'Igor.Stasenko 4/28/2010 19:11'! fieldAt: aFieldName put: value ^ NBFFICallout handleFailureIn: thisContext sender nativeCode: [:gen | self emitWrite: aFieldName generator: gen. gen bytes ] ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NBExternalStructure class instanceVariableNames: 'initialized currentFields'! !NBExternalStructure class methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/19/2010 08:45'! fields ^ currentFields ifNil: [ self rebuildFieldAccessors. currentFields ].! ! !NBExternalStructure class methodsFor: 'accessing' stamp: 'CiprianTeodorov 1/19/2013 17:14'! fieldsClass ^NBExternalStructureFields ! ! !NBExternalStructure class methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/19/2010 08:56'! instanceSize ^ self fields totalSize ! ! !NBExternalStructure class methodsFor: 'accessing' stamp: 'IgorStasenko 2/2/2012 18:53'! offsetOf: aFieldName ^ self fields offsetOf: aFieldName! ! !NBExternalStructure class methodsFor: 'alignment' stamp: 'IgorStasenko 5/26/2012 17:45'! byteAlignment "default " ^ NativeBoost forCurrentPlatform pointerSize ! ! !NBExternalStructure class methodsFor: 'class initialization' stamp: 'IgorStasenko 8/5/2011 12:02'! initializeAccessors initialized := true. self rebuildFieldAccessors.! ! !NBExternalStructure class methodsFor: 'ffi type' stamp: 'Igor.Stasenko 5/17/2010 18:44'! asNBExternalType: gen ^ NBExternalStructureType objectClass: self! ! !NBExternalStructure class methodsFor: 'fields description' stamp: 'Igor.Stasenko 5/19/2010 09:01'! 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: 'instance creation' stamp: 'IgorStasenko 8/4/2011 05:53'! fromPointer: externalAddress | inst | inst:= self new. NativeBoost memCopy: externalAddress to: inst size: self instanceSize. ^ inst! ! !NBExternalStructure class methodsFor: 'instance creation' stamp: 'Igor.Stasenko 5/19/2010 08:56'! new ^ (self basicNew: self fields totalSize) initialize! ! !NBExternalStructure class methodsFor: 'managing accessors' stamp: 'Igor.Stasenko 5/22/2010 12:04'! createAccessorsFor: fieldName "Define read/write accessors for the given field" | code | code := fieldName,' "This method was automatically generated" ^ self fieldAt: ' , fieldName printString. self compile: code classified: '*auto-accessing'. code := fieldName,': anObject "This method was automatically generated" ^ self fieldAt: ' , fieldName printString , ' put: anObject'. self compile: code classified: '*auto-accessing'. ! ! !NBExternalStructure class methodsFor: 'managing accessors' stamp: 'Igor.Stasenko 4/29/2010 04:44'! flushNativeFieldAccessors methodDict do: [:method | NBNativeCodeGen removeNativeCodeFrom: method ]! ! !NBExternalStructure class methodsFor: 'managing accessors' stamp: 'IgorStasenko 8/3/2011 19:15'! 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: 'managing accessors' stamp: 'CiprianTeodorov 1/19/2013 17:14'! 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: 'managing accessors' stamp: 'Igor.Stasenko 5/2/2010 13:30'! removeAccessor: aSelector methodDict at: aSelector ifAbsent: [ ^ self ]. self removeSelector: aSelector. ! ! !NBExternalStructure class methodsFor: 'testing' stamp: 'Igor.Stasenko 4/29/2010 04:13'! allocateOnCHeap ^ false! ! !NBExternalStructure class methodsFor: 'testing' stamp: 'Igor.Stasenko 4/29/2010 04:14'! allocateOnObjectMemory ^ self allocateOnCHeap not! ! !NBExternalStructure class methodsFor: 'testing' stamp: 'IgorStasenko 8/5/2011 12:00'! isInitialized ^ initialized == true! ! Object subclass: #NBExternalStructureFields instanceVariableNames: 'fields totalSize' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Objects'! !NBExternalStructureFields methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/19/2010 07:15'! fieldNames ^ fields keys! ! !NBExternalStructureFields methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/19/2010 07:16'! fieldNamesDo: aBlock ^ fields keysDo: [:name | aBlock value: name ]! ! !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'! offsetOf: fieldName ^ (fields at: fieldName) at: 2! ! !NBExternalStructureFields methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/19/2010 06:41'! totalSize ^ totalSize! ! !NBExternalStructureFields methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/19/2010 07:16'! typeOf: fieldName ^ (fields at: fieldName) at: 1! ! !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: '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: 'parsing spec' stamp: 'CiprianTeodorov 1/19/2013 17:18'! sizeAlignedTo: anAlign with: aType totalSize := (totalSize alignedTo: anAlign) + aType typeSize! ! NBExternalType subclass: #NBExternalStructureType instanceVariableNames: 'objectClass returnOop' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Types'! !NBExternalStructureType methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/17/2010 18:43'! objectClass ^objectClass! ! !NBExternalStructureType methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/17/2010 18:43'! objectClass: anObject objectClass := anObject! ! !NBExternalStructureType methodsFor: 'accessing' stamp: 'IgorStasenko 5/26/2012 14:12'! valueSize ^ objectClass instanceSize ! ! !NBExternalStructureType methodsFor: 'emitting code' stamp: 'IgorStasenko 5/4/2012 19:17'! coerceReturnValue: gen | asm proxy | asm := gen asm. proxy := gen proxy. self returnViaRegisters ifTrue: [ | temp1 temp2 oop | "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. gen emitFetchClass: objectClass. proxy instantiateClass: asm EAX indexableSize: objectClass instanceSize. asm mov: asm EAX to: oop. proxy firstIndexableField: 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. ]. "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: 'emitting code' stamp: 'IgorStasenko 5/4/2012 19:16'! prepareReturnValue: gen for: callinfo | asm proxy | 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. gen emitFetchClass: objectClass. proxy instantiateClass: asm EAX indexableSize: objectClass instanceSize. asm mov: asm EAX to: returnOop. proxy firstIndexableField: asm EAX. "in EAX is pointer to first byte of struct" asm noticePush: asm pointerSize forCall: callinfo. asm push: asm EAX ] ! ! !NBExternalStructureType methodsFor: 'emitting code' stamp: 'IgorStasenko 5/26/2012 00:53'! pushAsPointer: gen "push a pointer to structure (which should be a subinstance of NBExternalStructure)" | asm proxy oop | proxy := gen proxy. asm := gen asm. oop := gen reserveTemp annotation: 'oop'. loader emitLoad: gen to: oop. self verifyClassOf: oop is: objectClass generator: gen. "do a shortcut, since we know that variable bytes first byte offset" asm mov: oop to: asm EAX; add: asm EAX with: (proxy objectFormat varBytesFirstField asUImm32 annotation: 'variable-byte first field offset'). asm push: asm EAX. gen releaseTemps: 1. ! ! !NBExternalStructureType methodsFor: 'emitting code' stamp: 'IgorStasenko 5/26/2012 14:19'! pushAsValue: gen "pass a structure by value on stack" | asm proxy oop bytesToCopy offset | proxy := gen proxy. 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 know its class" self verifyClassOf: oop is: objectClass generator: gen. ]. asm mov: oop to: asm EAX; add: asm EAX with: (proxy objectFormat varBytesFirstField asUImm32 annotation: 'variable-byte first field offset'). "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. "we can afford to read past struct size, since all objects in obj memory are 4-byte aligned" [ bytesToCopy > 0 ] whileTrue: [ asm mov: asm EAX ptr32 + offset to: asm EDX; mov: asm EDX to: asm ESP ptr32 + offset. bytesToCopy := bytesToCopy - 4. offset := offset + 4. ]. gen releaseTemps: 1. ! ! !NBExternalStructureType 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" | 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: self valueSize. asm mov: asm EAX to: oop. 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: '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 class instanceVariableNames: ''! !NBExternalStructureType class methodsFor: 'instance creation' stamp: 'Igor.Stasenko 5/17/2010 18:42'! objectClass: aClass ^ self new objectClass: aClass! ! Object subclass: #NBExternalType instanceVariableNames: 'pointerArity loader' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Types'! !NBExternalType commentStamp: 'IgorStasenko 2/15/2012 19:41' prior: 0! 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: '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:50'! loader ^ loader! ! !NBExternalType methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/30/2010 09:51'! loader: aLoader loader := aLoader! ! !NBExternalType methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/28/2010 11:35'! pointerArity ^ pointerArity! ! !NBExternalType methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/28/2010 11:35'! pointerArity: additionalArity pointerArity := pointerArity + additionalArity.! ! !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: '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: '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: 'accessing' stamp: 'IgorStasenko 5/26/2012 14:26'! storageSize "Answer a number of bytes, which receiver type takes in memory" pointerArity > 0 ifTrue: [ ^ self pointerSize ]. ^ self valueSize! ! !NBExternalType methodsFor: 'accessing' stamp: 'CiprianTeodorov 12/16/2012 15:34'! typeName | tName | tName := self class name. pointerArity timesRepeat: [ tName , '*' ]. ^ tName! ! !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: '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: '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: 'Igor.Stasenko 4/28/2010 17:42'! coerceReturn: gen pointerArity > 0 ifTrue: [ self coerceReturnPointer: gen ] ifFalse: [ self coerceReturnValue: gen ]. ! ! !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: 'Igor.Stasenko 4/30/2010 08:10'! coerceReturnValue: generator "emit code to coerce return value from external function call" self subclassResponsibility ! ! !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: '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: 'emitting code' stamp: 'Igor.Stasenko 4/28/2010 11:41'! prepareArgumentUsing: aNBFFICallout "by default, do nothing"! ! !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: 'emitting code' stamp: 'Igor.Stasenko 5/20/2010 06:31'! 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; push: 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 push: asm EAX. 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 firstIndexableField: oop. asm push: asm EAX. asm jmp: done. ]. asm jmp: gen failedLabel. asm label: done. gen releaseTemps: 1. ! ! !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: '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: 'initialize-release' stamp: 'Igor.Stasenko 4/28/2010 11:34'! initialize pointerArity := 0.! ! !NBExternalType methodsFor: 'printing' stamp: 'Igor.Stasenko 4/30/2010 09:22'! printOn: aStream super printOn: aStream. pointerArity timesRepeat: [ aStream nextPut: $* ].! ! !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: 'testing' stamp: 'Igor.Stasenko 5/1/2010 16:05'! isCallback ^ false! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NBExternalType class instanceVariableNames: ''! !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: 'as yet unclassified' stamp: 'Igor.Stasenko 4/28/2010 11:25'! prepareArgument: typeArgument generator: gen "by default, do nothing"! ! !NBExternalType class methodsFor: 'converting' stamp: 'Igor.Stasenko 4/28/2010 12:20'! asNBExternalType: gen ^ self new! ! !NBExternalType class methodsFor: 'public' stamp: 'IgorStasenko 12/30/2011 12:55'! sizeOf: aTypeName ^ (NBFFICallout new resolveType: aTypeName) valueSize! ! NBExternalStructure variableByteSubclass: #NBExternalTypeValue instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Objects'! !NBExternalTypeValue commentStamp: '' prior: 0! 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: 'printing' stamp: 'IgorStasenko 7/25/2012 02:59'! 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 class instanceVariableNames: 'valueType'! !NBExternalTypeValue class methodsFor: 'accessing' stamp: 'IgorStasenko 7/25/2012 02:58'! valueType ^ valueType! ! !NBExternalTypeValue class methodsFor: 'class factory' stamp: 'CiprianTeodorov 12/16/2012 15:47'! 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. " | newSubclass | newSubclass := ClassBuilder new newSubclassOf: NBExternalTypeValue type: NBExternalTypeValue typeOfClass instanceVariables: '' from: nil. "we're not using 'self' to avoid wrong subclassing from anonymous subclass " newSubclass valueType: aTypeName. ^ newSubclass! ! !NBExternalTypeValue class methodsFor: 'class factory' stamp: 'IgorStasenko 7/25/2012 02:49'! ofType: aTypeName ^ self getClassForType: aTypeName ! ! !NBExternalTypeValue class methodsFor: 'fields description' stamp: 'IgorStasenko 7/25/2012 02:28'! fieldsDesc valueType ifNil: [ ^ #() ]. ^ { valueType. #value }! ! !NBExternalTypeValue class methodsFor: 'private' stamp: 'IgorStasenko 7/25/2012 03:33'! valueType: aTypeName valueType := aTypeName. self rebuildFieldAccessors! ! NBExternalStructure variableByteSubclass: #NBExternalUnion instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Objects'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NBExternalUnion class instanceVariableNames: ''! !NBExternalUnion class methodsFor: 'accessing' stamp: 'CiprianTeodorov 1/19/2013 17:15'! fieldsClass ^ NBExternalUnionFields! ! NBExternalStructureFields subclass: #NBExternalUnionFields instanceVariableNames: 'nbFields' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Objects'! !NBExternalUnionFields methodsFor: 'accessing' stamp: 'CiprianTeodorov 1/19/2013 16:55'! offsetOf: fieldName ^ 0! ! !NBExternalUnionFields methodsFor: 'accessing' stamp: 'CiprianTeodorov 1/19/2013 16:55'! typeOf: fieldName ^ (fields at: fieldName) at: 1! ! !NBExternalUnionFields methodsFor: 'initialize-release' stamp: 'CiprianTeodorov 1/19/2013 17:05'! initialize super initialize. nbFields := 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: 'parsing spec' stamp: 'CiprianTeodorov 1/19/2013 16:59'! sizeAlignedTo: anAlign with: aType totalSize := (totalSize alignedTo: anAlign ) max: (aType typeSize alignedTo: anAlign)! ! NBExternalStructureType subclass: #NBExternalUnionType instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Types'! Object subclass: #NBExtraRootsRegistry instanceVariableNames: 'pool array cell freeCallbackIndexes' classVariableNames: 'Current Seed' poolDictionaries: '' category: 'NativeBoost-Core'! !NBExtraRootsRegistry commentStamp: 'Igor.Stasenko 4/29/2010 07:53' prior: 0! 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: '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: '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: '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: '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: '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: '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: '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: '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: '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 instanceVariableNames: ''! !NBExtraRootsRegistry class methodsFor: 'instance creation' stamp: 'Igor.Stasenko 5/2/2010 12:50'! new self error: 'use #newWithCell:'! ! !NBExtraRootsRegistry class methodsFor: 'instance creation' stamp: 'Igor.Stasenko 5/2/2010 12:50'! newWithCell: aMemoryCell ^ self basicNew initialize: aMemoryCell! ! Object subclass: #NBFFICallback instanceVariableNames: 'trunk index enterMethod block' classVariableNames: '' poolDictionaries: 'AJx86Registers' category: 'NativeBoost-Core-Objects'! !NBFFICallback commentStamp: '' prior: 0! 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: '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: 'as yet unclassified' 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: 'as yet unclassified' 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: 'initialize-release' 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: '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 instanceVariableNames: 'session numArgs cbEnter cbLeave trunkCode'! !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: 'accessing' stamp: 'IgorStasenko 5/8/2012 16:05'! callbackLeaveAddress self checkSession. cbLeave ifNil: [ self installCallbackCode ]. ^ cbLeave address ! ! !NBFFICallback class methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/11/2010 02:35'! numberOfArguments ^ numArgs! ! !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: 'callback spec' stamp: 'Igor.Stasenko 5/13/2010 23:33'! asNBExternalType: gen ^ NBFFICallbackType new callbackClass: self! ! !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: '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: '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: 'finalization' stamp: 'IgorStasenko 9/15/2012 14:18'! finalizeResourceData: trunkAndIndex NativeBoost free: trunkAndIndex first. NativeBoost extraRootsRegistry releaseCallbackIndex: trunkAndIndex second. ! ! !NBFFICallback class methodsFor: 'instance creation' stamp: 'Igor.Stasenko 5/13/2010 22:40'! new self error: 'use #on: instead'.! ! !NBFFICallback class methodsFor: 'instance creation' stamp: 'Igor.Stasenko 5/13/2010 22:43'! on: aBlock ^ self basicNew initialize block: aBlock! ! !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: '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. ]. ! ! NBExternalType subclass: #NBFFICallbackType instanceVariableNames: 'callbackClass' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Types'! !NBFFICallbackType commentStamp: 'Igor.Stasenko 5/4/2010 05:15' prior: 0! 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: 'accessing' stamp: 'Igor.Stasenko 5/4/2010 05:16'! valueSize ^ self pointerSize! ! !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: '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. ! ! !NBFFICallbackType methodsFor: 'testing' stamp: 'Igor.Stasenko 5/13/2010 23:31'! isCallback ^ true! ! NBNativeCodeGen subclass: #NBFFICallout instanceVariableNames: 'fnSpec requestor methodArgs coercionMayFail callInfo' classVariableNames: 'CustomErrorCodes CustomErrorMessages TypeAliases' poolDictionaries: '' category: 'NativeBoost-Core-FFI'! !NBFFICallout commentStamp: '' prior: 0! 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: 'accessing' stamp: 'IgorStasenko 8/21/2011 11:29'! anonSpec: anonFunctionSpec fnSpec := self newSpecParser parseAnonFunction: anonFunctionSpec. ! ! !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: 'accessing' stamp: 'Igor.Stasenko 4/30/2010 11:48'! fnSpec ^ fnSpec! ! !NBFFICallout methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/3/2010 01:05'! methodArgs ^ methodArgs! ! !NBFFICallout methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/30/2010 11:05'! methodArgs: aMethodArgumentNames "avoid setting them directly, useful for testing only" methodArgs := aMethodArgumentNames! ! !NBFFICallout methodsFor: 'accessing' stamp: 'IgorStasenko 8/21/2011 11:29'! namedFnSpec: namedFn fnSpec := self newSpecParser parseNamedFunction: namedFn. ! ! !NBFFICallout methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/30/2010 06:54'! newSpecParser ^ NBFnSpecParser new requestor: self ! ! !NBFFICallout methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/26/2010 02:03'! requestor ^ requestor! ! !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 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: 'accessing' stamp: 'IgorStasenko 3/27/2012 17:23'! sender: aSenderContext | nArgs | self requestor: aSenderContext method methodClass. nArgs := aSenderContext method numArgs. methodArgs := aSenderContext method methodNode tempNames first: nArgs. self assert: (methodArgs size = nArgs). ! ! !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: 'argument loaders' stamp: 'cipt 10/24/2012 20:39'! indirectLoader: aLoader byIndex: anIndex ^ NBSTIndirectArgument new argumentLoader: aLoader; elementIndex: anIndex! ! !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: '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: '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: 'call conventions' stamp: 'Igor.Stasenko 5/3/2010 22:28'! cdecl options add: #optCdecl! ! !NBFFICallout methodsFor: 'call conventions' stamp: 'Igor.Stasenko 5/3/2010 22:27'! stdcall options add: #optStdcall! ! !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: 'code generation' stamp: 'IgorStasenko 5/11/2011 17:23'! coercionMayFail: aBoolean coercionMayFail := coercionMayFail or: aBoolean ! ! !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: '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: '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: '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: 'code generation' stamp: 'IgorStasenko 12/7/2012 01:04'! generateInstructions: aFunctionBodyBlock | instructions | proxy prepareForCallout. "prepare & push arguments" 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: '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: 'CamilloBruni 7/23/2012 13:29'! 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 " asm decorateWith: 'FFI: prepare arguments' during: [ fnSpec arguments do: [:arg | arg prepareArgumentUsing: self ] ]. "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: '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: '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: '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/8/2011 17:50'! errorCodeForMessage: aString ^ self class registerErrorMessage: aString! ! !NBFFICallout methodsFor: 'failure code' stamp: 'IgorStasenko 8/6/2011 18:32'! failWithCode: aCode asm mov: aCode to: EAX; jmp: self failedWithCodeLabel! ! !NBFFICallout methodsFor: 'failure code' stamp: 'IgorStasenko 8/8/2011 17:49'! failWithMessage: aString | errorCode | errorCode := self errorCodeForMessage: aString. ^ self failWithCode: errorCode ! ! !NBFFICallout methodsFor: 'failure code' stamp: 'IgorStasenko 8/6/2011 18:25'! failedLabel ^ asm labelNamed: #FFICalloutFailed! ! !NBFFICallout methodsFor: 'failure code' stamp: 'IgorStasenko 8/6/2011 18:25'! failedWithCodeLabel ^ asm labelNamed: #FFICalloutFailedWithCode! ! !NBFFICallout methodsFor: 'initialize-release' 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: 'spec parsing' stamp: 'Igor.Stasenko 4/30/2010 11:27'! integerConstantArgument: int ^ NBFFIConst value: int! ! !NBFFICallout methodsFor: 'spec parsing' stamp: 'IgorStasenko 8/21/2011 11:04'! returnType: aType ^ self typeName: aType first ptrArity: aType second! ! !NBFFICallout methodsFor: 'spec parsing' stamp: 'Igor.Stasenko 4/30/2010 09:18'! typeName: aName ptrArity: ptrArity ^ (self resolveType: aName) pointerArity: ptrArity! ! !NBFFICallout methodsFor: 'testing' stamp: 'Igor.Stasenko 5/18/2010 02:23'! usesMethodArguments ^ fnSpec arguments anySatisfy: [:type | type loader usesSTStack ]! ! !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 class instanceVariableNames: ''! !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: '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: '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: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: '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/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: '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: '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: '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: '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: '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: '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 ] ! ! !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: '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: '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: 'initialize-release' stamp: 'Igor.Stasenko 4/28/2010 16:46'! initialize Smalltalk removeFromStartUpList: self . self initTypeAliases! ! !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 ) ! ! Object subclass: #NBFFICalloutAPI instanceVariableNames: 'context conv options' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-FFI'! !NBFFICalloutAPI methodsFor: 'accessing' stamp: 'IgorStasenko 11/22/2012 14:23'! context ^ context! ! !NBFFICalloutAPI methodsFor: 'accessing' stamp: 'IgorStasenko 11/22/2012 14:23'! context: anObject context := anObject! ! !NBFFICalloutAPI methodsFor: 'accessing' stamp: 'IgorStasenko 11/23/2012 13:56'! convention: aCallConvention conv := aCallConvention ! ! !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: '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: '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: 'call conventions' stamp: 'IgorStasenko 11/22/2012 18:11'! cdecl conv := #cdecl! ! !NBFFICalloutAPI methodsFor: 'call conventions' stamp: 'IgorStasenko 11/22/2012 18:11'! stdcall conv := #stdcall! ! !NBFFICalloutAPI methodsFor: 'initialize-release' stamp: 'IgorStasenko 11/22/2012 18:18'! initialize conv := #cdecl. options := #().! ! !NBFFICalloutAPI methodsFor: 'options' stamp: 'IgorStasenko 11/22/2012 18:12'! options: codeGenerationOptions options := codeGenerationOptions! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NBFFICalloutAPI class instanceVariableNames: ''! !NBFFICalloutAPI class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/22/2012 14:24'! inContext: aContext ^ self new context: aContext! ! NBNativeCodeError subclass: #NBFFICalloutError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Errors'! !NBFFICalloutError commentStamp: 'IgorStasenko 2/20/2012 13:52' prior: 0! 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: 'as yet unclassified' stamp: 'IgorStasenko 2/20/2012 13:47'! description ^ NBErrorDescriptions at: errorCode ifAbsent: [ (NBFFICallout messageForCode: errorCode) ifNil: [ 'Error during FFI call: ' , errorCode asString]]. ! ! Object subclass: #NBFFIConst instanceVariableNames: 'value' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Types'! !NBFFIConst commentStamp: 'Igor.Stasenko 5/3/2010 18:10' prior: 0! 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: 'accessing' stamp: 'Igor.Stasenko 5/18/2010 23:07'! loader ^ self! ! !NBFFIConst methodsFor: 'accessing' stamp: 'IgorStasenko 8/2/2011 14:39'! stackSize ^ 4! ! !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: 'as yet unclassified' stamp: 'Igor.Stasenko 4/30/2010 11:46'! pointerArity: ptrArity ptrArity > 0 ifTrue: [ self error: 'passing pointer to constant' ]! ! !NBFFIConst methodsFor: 'as yet unclassified' stamp: 'Igor.Stasenko 4/28/2010 13:54'! prepareArgumentUsing: gen "do nothing"! ! !NBFFIConst methodsFor: 'as yet unclassified' stamp: 'Igor.Stasenko 4/26/2010 03:21'! prepareUsing: gen "do nothing" ^ self! ! !NBFFIConst methodsFor: 'as yet unclassified' 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: '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: '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: 'testing' stamp: 'Igor.Stasenko 5/3/2010 00:53'! isCallback ^ false! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NBFFIConst class instanceVariableNames: ''! !NBFFIConst class methodsFor: 'instance creation' stamp: 'Igor.Stasenko 4/15/2010 22:18'! value: aValue ^ self new value: aValue! ! Object subclass: #NBFinalizationRegistry instanceVariableNames: 'list items nextFreeIndex sema' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core'! !NBFinalizationRegistry commentStamp: '' prior: 0! 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: 'accessing' stamp: 'IgorStasenko 5/31/2012 02:59'! add: anObject ^ self add: anObject executor: anObject executor! ! !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: 'accessing' stamp: 'IgorStasenko 5/31/2012 02:56'! initialSize ^ 100! ! !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: '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: 'for tests only' stamp: 'IgorStasenko 5/31/2012 14:41'! items ^ items! ! !NBFinalizationRegistry methodsFor: 'initialize-release' stamp: 'IgorStasenko 5/31/2012 14:51'! initialize super initialize. sema := Semaphore forMutualExclusion. self reset. WeakArray addWeakDependent: self! ! !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: '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: '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 14:24'! reset sema critical: [ nextFreeIndex := nil. list := WeakFinalizationList new. items := Array new: self initialSize. self formatItems: 1. ] ! ! NBFloatType subclass: #NBFloat128 instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Types'! !NBFloat128 methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/28/2010 15:53'! valueSize ^ 16! ! NBFloatType subclass: #NBFloat16 instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Types'! !NBFloat16 commentStamp: '' prior: 0! not supported on x86 archs.. ! !NBFloat16 methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/28/2010 15:53'! valueSize ^ 2! ! NBFloatType subclass: #NBFloat32 instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Types'! !NBFloat32 methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/28/2010 15:52'! valueSize ^ 4! ! !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: 'emitting code' stamp: 'Igor.Stasenko 5/20/2010 04:06'! pushAsValue: gen gen proxy pushFloatOopAsFloat32: (loader emitLoad: gen). ! ! NBFloatType subclass: #NBFloat64 instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Types'! !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: 'accessing' stamp: 'Igor.Stasenko 4/28/2010 15:52'! valueSize ^ 8! ! !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: '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: '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. ].! ! !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 ! ! NBExternalType subclass: #NBFloatPtr instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Types'! !NBFloatPtr commentStamp: 'IgorStasenko 12/21/2011 13:43' prior: 0! 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: 'accessing' stamp: 'IgorStasenko 12/21/2011 13:40'! valueSize ^ self pointerSize! ! !NBFloatPtr methodsFor: 'emitting code' stamp: 'IgorStasenko 12/21/2011 13:40'! pushAsPointer: gen self error: 'only value-type arguments allowed'! ! !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. ! ! NBExternalType subclass: #NBFloatType instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Types'! !NBFloatType commentStamp: 'Igor.Stasenko 4/28/2010 11:54' prior: 0! Abstract class for floating-point native types! Object subclass: #NBFnArgument instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-FFI'! !NBFnArgument commentStamp: 'Igor.Stasenko 4/30/2010 12:12' prior: 0! I am abstract class, describing a function argument. My subclasses should know what code to emit in order to load an argument. ! !NBFnArgument methodsFor: 'as yet unclassified' 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: 'as yet unclassified' 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! ! Object subclass: #NBFnSpec instanceVariableNames: 'returnType functionName arguments' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-FFI'! !NBFnSpec commentStamp: 'IgorStasenko 2/15/2012 19:46' prior: 0! 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: 'accessing' stamp: 'IgorStasenko 8/19/2011 17:44'! arguments ^ arguments! ! !NBFnSpec methodsFor: 'accessing' stamp: 'IgorStasenko 8/19/2011 17:44'! arguments: anObject arguments := anObject! ! !NBFnSpec methodsFor: 'accessing' stamp: 'IgorStasenko 8/19/2011 17:44'! functionName ^ functionName! ! !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 methodsFor: 'accessing' stamp: 'IgorStasenko 8/19/2011 17:44'! returnType: anObject returnType := anObject! ! !NBFnSpec methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 8/21/2011 02:49'! addArgument: anArgument ^ arguments add: anArgument! ! !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: '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: '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: '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: 'converting' stamp: 'IgorStasenko 8/19/2011 18:39'! printType: typeAndArity on: str str nextPutAll: typeAndArity first. typeAndArity second timesRepeat: [ str nextPut: $* ]. ! ! !NBFnSpec methodsFor: 'initialize-release' stamp: 'IgorStasenko 8/19/2011 17:53'! initialize arguments := OrderedCollection new! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NBFnSpec class instanceVariableNames: ''! !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 ! ! Object subclass: #NBFnSpecParser instanceVariableNames: 'requestor stream fnSpec' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-FFI'! !NBFnSpecParser methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/30/2010 05:31'! requestor: aRequestor requestor := aRequestor.! ! !NBFnSpecParser methodsFor: 'initialize-release' stamp: 'IgorStasenko 8/21/2011 02:50'! initialize requestor := self. ! ! !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: '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: '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: '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: '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 ]! ! !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: '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: '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:57'! integerConstantArgument: aValue ^ aValue! ! !NBFnSpecParser methodsFor: 'requestor callbacks' stamp: 'IgorStasenko 8/21/2011 10:55'! returnType: aType ^ aType! ! NBUInt16 subclass: #NBInt16 instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Types'! !NBInt16 commentStamp: '' prior: 0! 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))! ! NBUInt32 subclass: #NBInt32 instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Types'! !NBInt32 commentStamp: '' prior: 0! 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) )! ! NBUInt64 subclass: #NBInt64 instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Types'! !NBInt64 commentStamp: '' prior: 0! 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' ]. ].! ! NBUInt8 subclass: #NBInt8 instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Types'! !NBInt8 commentStamp: '' prior: 0! 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) ) ! ! NBExternalType subclass: #NBIntegerExternalType instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Types'! !NBIntegerExternalType commentStamp: 'Igor.Stasenko 4/28/2010 11:53' prior: 0! Abstract class for all integer external types! Object subclass: #NBInterpreterProxy instanceVariableNames: 'gen asm objectFormat usedGate stackPtrAddress framePtrAddress cStackPtrAddress cFramePtrAddress' classVariableNames: 'CogFunctions Functions' poolDictionaries: 'AJx86Registers' category: 'NativeBoost-Core'! !NBInterpreterProxy commentStamp: '' prior: 0! 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: '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: '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: '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: 'accessing' stamp: 'Igor.Stasenko 9/29/2010 09:27'! functions ^ self class functions! ! !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: 'accessing' stamp: 'IgorStasenko 8/3/2011 19:50'! objectFormat ^ objectFormat ! ! !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: '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: 'call' stamp: 'Igor.Stasenko 4/9/2010 07:57'! call: aFunction ^ self call: aFunction arguments: #() ! ! !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: '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: '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: '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: '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: '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 5/19/2010 11:56'! baseHeaderSize ^ objectFormat baseHeaderSize! ! !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: '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: 'helpers' stamp: 'Igor.Stasenko 5/3/2010 14:29'! createInstanceOf: aClass ^ self createInstanceOf: aClass size: 0! ! !NBInterpreterProxy methodsFor: 'helpers' stamp: 'Igor.Stasenko 5/3/2010 14:28'! createInstanceOf: aClass size: indexableSize ^ self instantiateClass: [ gen emitFetchClass: aClass ] indexableSize: indexableSize! ! !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: '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: 'helpers' stamp: 'Igor.Stasenko 4/11/2010 23:04'! ifFailedJumpTo: label self failed. asm or: EAX with: EAX. asm jnz: label. ! ! !NBInterpreterProxy methodsFor: 'helpers' stamp: 'Igor.Stasenko 5/5/2010 20:11'! indexOf: ivarName in: aClass ^ aClass instVarIndexFor: ivarName ifAbsent: [nil]! ! !NBInterpreterProxy methodsFor: 'helpers' stamp: 'Igor.Stasenko 5/20/2010 06:02'! isBytes: oop ifNotJumpTo: label ^ objectFormat isBytes: oop ifNotJumpTo: label! ! !NBInterpreterProxy methodsFor: 'helpers' stamp: 'Igor.Stasenko 5/20/2010 06:02'! isBytesOrWords: oop ifNotJumpTo: label ^ objectFormat isBytesOrWords: oop ifNotJumpTo: label! ! !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: '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: '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: '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 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: '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: '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: '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: 'helpers' stamp: 'IgorStasenko 8/10/2011 17:52'! shiftForPointer "answer the shift bits for pointer size" ^ self pointerSize highBit - 1 ! ! !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: '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: '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: '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: 'initialize-release' 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 classes' stamp: 'Igor.Stasenko 4/30/2010 20:29'! classAlien ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy classes' stamp: 'Igor.Stasenko 4/11/2010 16:15'! classArray ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy classes' stamp: 'Igor.Stasenko 4/11/2010 16:15'! classBitmap ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy classes' stamp: 'Igor.Stasenko 4/11/2010 16:15'! classByteArray ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy classes' stamp: 'Igor.Stasenko 4/11/2010 16:15'! classCharacter ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy classes' stamp: 'Igor.Stasenko 4/11/2010 16:40'! classExternalAddress ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy classes' stamp: 'Igor.Stasenko 4/11/2010 16:40'! classExternalData ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy classes' stamp: 'Igor.Stasenko 4/11/2010 16:40'! classExternalFunction ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy classes' stamp: 'Igor.Stasenko 4/11/2010 16:40'! classExternalLibrary ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy classes' stamp: 'Igor.Stasenko 4/11/2010 16:40'! classExternalStructure ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy classes' stamp: 'Igor.Stasenko 4/11/2010 16:16'! classFloat ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy classes' stamp: 'Igor.Stasenko 4/11/2010 16:38'! classLargeNegativeInteger ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy classes' stamp: 'Igor.Stasenko 4/11/2010 16:16'! classLargePositiveInteger ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy classes' stamp: 'Igor.Stasenko 4/11/2010 16:16'! classPoint ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy classes' stamp: 'Igor.Stasenko 4/11/2010 16:16'! classSemaphore ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy classes' stamp: 'Igor.Stasenko 4/11/2010 16:16'! classSmallInteger ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy classes' stamp: 'Igor.Stasenko 4/11/2010 16:16'! classString ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy classes' stamp: 'Igor.Stasenko 4/30/2010 20:29'! classUnsafeAlien ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/29/2010 06:20'! addGCRoot: sqIntPtr ^ self simpleCall ! ! !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: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 functions' stamp: 'Igor.Stasenko 4/11/2010 16:21'! become: array1 with: array2 ^ self gatedCall ! ! !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 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:22'! byteSwapped: w "Answer the given integer with its bytes in the reverse order." ^ self simpleCall! ! !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: 'proxy functions' stamp: 'Igor.Stasenko 4/30/2010 20:11'! callbackLeave: callbackId "Leave from a previous callback" ^ self gatedCall! ! !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/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 functions' stamp: 'Igor.Stasenko 4/11/2010 16:36'! compilerHookVector ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 16:38'! 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 shouldNotImplement ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 16:38'! 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 shouldNotImplement ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 16:15'! displayObject ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 14:57'! failed ^ self simpleCall! ! !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: '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: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/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: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 16:49'! fetchLong32: index ofObject: oop ^ 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: '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: '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/30/2010 19:02'! 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 shouldNotImplement. " ^ self gatedCall " ! ! !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: 'Igor.Stasenko 4/11/2010 16:49'! forceInterruptCheck ^ self gatedCall! ! !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: '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/30/2010 20:12'! getStackPointer "return a ST stack pointer" ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 16:49'! getThisSessionID ^ 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: '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:19'! instantiateClass: classOop indexableSize: sz ^ self gatedCall ! ! !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: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:28'! internalIsImmutable: oop ^ 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: '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: '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 functions' stamp: 'Igor.Stasenko 4/30/2010 20:14'! ioLoadModule: m OfLength: l "implemented , see NBUtils class>>ioLoadModule: " self shouldNotImplement ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/30/2010 20:13'! ioLoadSymbol: sym OfLength: len FromModule: handle "implemented , see NBUtils class>>ioLoadSymbol:fromModule: " self shouldNotImplement ! ! !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: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/11/2010 15:39'! literalCountOf: methodOop "Answer a total number of literals for given method" ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 16:37'! 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 shouldNotImplement ! ! !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: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 functions' stamp: 'HenrikSperreJohansen 8/25/2011 00:58'! methodArgumentCount "Answer a total number of arguments of primitive method" ^ gen method numArgs! ! !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 functions' stamp: 'Igor.Stasenko 4/11/2010 15:19'! minorVersion ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/30/2010 20:08'! obsoleteDontUseThisFetchWord: index ofObject: zap self shouldNotImplement! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 15:21'! pop: nItems "not recommended for use in native code. use #stackValue: " self shouldNotImplement ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 15:22'! pop: nItems thenPush: anObject "not recommended for use in native code. use #stackValue: , and return a result oop from native function instead" self shouldNotImplement ! ! !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' 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: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: '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 functions' stamp: 'IgorStasenko 9/3/2012 02:31'! positive64BitIntegerFor: op "use positive64BitIntegerFor instead" self shouldNotImplement.! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'IgorStasenko 9/3/2012 00:23'! positive64BitValueOf: oop ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 16:32'! primitiveFail "Fail a primitive." ^ self simpleCall! ! !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' stamp: 'Igor.Stasenko 4/11/2010 16:40'! primitiveMethod ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 15:22'! push: anObject "not recommended for use in native code" self shouldNotImplement ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 15:22'! pushBool: trueOrFalse "not recommended for use in native code" self shouldNotImplement ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 15:22'! pushFloat: f "not recommended for use in native code" self shouldNotImplement ! ! !NBInterpreterProxy methodsFor: 'proxy functions' stamp: 'Igor.Stasenko 4/11/2010 15:23'! pushInteger: int "not recommended for use in native code" self shouldNotImplement ! ! !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 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/30/2010 20:29'! removeGCRoot: addr ^ 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: 'Igor.Stasenko 4/11/2010 16:36'! setCompilerInitialized: initFlag ^ self simpleCall! ! !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 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 09:34'! signed32BitValueOf: object ^ 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: 'IgorStasenko 9/3/2012 02:32'! signed64BitIntegerFor: op "use #signed64BitIntegerFor instead" self shouldNotImplement.! ! !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: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: '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: 'Igor.Stasenko 4/11/2010 15:53'! stObject: obj at: index "Return what ST would return for at: index." ^ self simpleCall ! ! !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 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: '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: '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 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 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 09:39'! success: flag ^ self simpleCall! ! !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 16:51'! vmEndianness ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy functions Cog' stamp: 'CamilloBruni 7/19/2012 12:07'! addHighPriorityTickee: thickeeFnAddr period: periodms 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 functions Cog' stamp: 'CamilloBruni 7/19/2012 12:07'! disownVM: flags self shouldBeImplemented ! ! !NBInterpreterProxy methodsFor: 'proxy functions Cog' stamp: 'CamilloBruni 7/19/2012 12:07'! floatArg: index self shouldBeImplemented ! ! !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'! integerArg: index self shouldBeImplemented ! ! !NBInterpreterProxy methodsFor: 'proxy functions Cog' stamp: 'CamilloBruni 7/19/2012 12:07'! isKindOf: oop Class: aClass self shouldBeImplemented ! ! !NBInterpreterProxy methodsFor: 'proxy functions Cog' stamp: 'CamilloBruni 7/19/2012 12:07'! isYoung: anOop self shouldBeImplemented ! ! !NBInterpreterProxy methodsFor: 'proxy functions Cog' stamp: 'CamilloBruni 7/19/2012 12:07'! methodArg: index self shouldBeImplemented ! ! !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'! objectArg: index self shouldBeImplemented ! ! !NBInterpreterProxy methodsFor: 'proxy functions Cog' stamp: 'CamilloBruni 7/19/2012 12:07'! ownVM: threadIdAndFlags self shouldBeImplemented ! ! !NBInterpreterProxy methodsFor: 'proxy functions Cog' stamp: 'CamilloBruni 7/19/2012 12:07'! primitiveErrorTable self shouldBeImplemented ! ! !NBInterpreterProxy methodsFor: 'proxy functions Cog' stamp: 'CamilloBruni 7/19/2012 12:07'! primitiveFailFor: errorCode ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy functions Cog' stamp: 'CamilloBruni 7/19/2012 12:07'! primitiveFailureCode self shouldBeImplemented ! ! !NBInterpreterProxy methodsFor: 'proxy functions Cog' stamp: 'CamilloBruni 7/19/2012 12:07'! setInterruptCheckChain: aFunctionAddr self shouldBeImplemented ! ! !NBInterpreterProxy methodsFor: 'proxy functions Cog' stamp: 'CamilloBruni 7/19/2012 12:07'! tenuringIncrementalGC self shouldBeImplemented ! ! !NBInterpreterProxy methodsFor: 'proxy functions Cog' stamp: 'CamilloBruni 7/19/2012 12:07'! topRemappableOop self shouldBeImplemented ! ! !NBInterpreterProxy methodsFor: 'proxy functions Cog' stamp: 'CamilloBruni 7/19/2012 12:07'! utcMicroseconds self shouldBeImplemented ! ! !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: 'proxy objects' stamp: 'Igor.Stasenko 4/11/2010 16:15'! falseObject ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy objects' stamp: 'Igor.Stasenko 4/11/2010 16:15'! nilObject ^ 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 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 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: 'proxy objects' stamp: 'Igor.Stasenko 4/11/2010 16:15'! trueObject ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy testing' stamp: 'Igor.Stasenko 4/11/2010 15:58'! is: oop KindOf: stringPtr "char *" ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy testing' stamp: 'Igor.Stasenko 4/11/2010 15:58'! is: oop MemberOf: stringPtr "char *" ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy testing' stamp: 'Igor.Stasenko 4/11/2010 16:48'! isArray: oop ^ self simpleCall! ! !NBInterpreterProxy methodsFor: 'proxy testing' stamp: 'Igor.Stasenko 4/11/2010 09:33'! isBytes: oop ^ self simpleCall ! ! !NBInterpreterProxy methodsFor: 'proxy testing' stamp: 'Igor.Stasenko 4/11/2010 15:58'! isFloatObject: oop ^ self simpleCall ! ! !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 testing' stamp: 'Igor.Stasenko 4/11/2010 15:58'! isIndexable: oop ^ 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: '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 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 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 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 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-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-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-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: '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: 'testing' stamp: 'IgorStasenko 5/28/2012 05:25'! canUseStackPointer gen optUseStackPointer ifFalse: [ ^ false ]. ^ stackPtrAddress notNil ! ! !NBInterpreterProxy methodsFor: 'testing' stamp: 'IgorStasenko 8/3/2011 05:56'! usedGate ^ usedGate == true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NBInterpreterProxy class instanceVariableNames: ''! !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: '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: '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: '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: '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: 'Igor.Stasenko 5/2/2010 08:34'! interpreterProxyAddress ^ self primitiveFailed! ! !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 ] ! ! !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: '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: '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: '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: '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: '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: '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: 'class initialization' stamp: 'IgorStasenko 8/3/2011 09:08'! initialize "self initialize" self generateFunctions! ! !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'! 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 4/16/2010 03:31'! fnSelectorAt: offset " NBInterpreterProxy fnSelectorAt: 16r130 " ^ (self functionAtOffset: offset) selector! ! !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: 'instance creation' stamp: 'Igor.Stasenko 5/1/2010 11:46'! forGenerator: aNativeCodeGenerator ^ self basicNew initialize generator: aNativeCodeGenerator! ! !NBInterpreterProxy class methodsFor: 'instance creation' stamp: 'Igor.Stasenko 5/1/2010 11:46'! new self error: 'Use #forGenerator: '! ! !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 ) ! ! SharedPool subclass: #NBMacConstants instanceVariableNames: '' classVariableNames: 'MAP_ANON MAP_COPY MAP_FAILED MAP_FILE MAP_FIXED MAP_HASSEMAPHORE MAP_NOCACHE MAP_NOEXTEND MAP_NORESERVE MAP_PRIVATE MAP_RENAME MAP_RESERVED0080 MAP_SHARED PROT_EXEC PROT_NONE PROT_READ PROT_WRITE RTLD_DEFAULT RTLD_FIRST RTLD_GLOBAL RTLD_LAZY RTLD_LOCAL RTLD_MAIN_ONLY RTLD_NEXT RTLD_NODELETE RTLD_NOLOAD RTLD_NOW RTLD_SELF' poolDictionaries: '' category: 'NativeBoost-Mac'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NBMacConstants class instanceVariableNames: ''! !NBMacConstants class methodsFor: 'as yet unclassified' 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.! ! !NBMacConstants class methodsFor: 'as yet unclassified' 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. ! ! NBExternalHeapManager subclass: #NBMacExternalHeapManager instanceVariableNames: '' classVariableNames: '' poolDictionaries: 'NBMacConstants' category: 'NativeBoost-Mac'! !NBMacExternalHeapManager methodsFor: 'as yet unclassified' stamp: 'Igor.Stasenko 12/5/2010 19:13'! mapFlags ^ MAP_ANON bitOr: MAP_PRIVATE! ! !NBMacExternalHeapManager methodsFor: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' 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 ! ! Object subclass: #NBMemoryBlock instanceVariableNames: 'left right address length free' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Heap'! !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:17'! isFree ^ free! ! !NBMemoryBlock methodsFor: 'accessing' stamp: 'Igor.Stasenko 9/22/2010 04:43'! left ^left! ! !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/24/2010 04:29'! length: aValue length := aValue! ! !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 ].! ! !NBMemoryBlock methodsFor: 'accessing' stamp: 'Igor.Stasenko 9/22/2010 04:43'! right ^right! ! !NBMemoryBlock methodsFor: 'accessing' stamp: 'Igor.Stasenko 9/22/2010 04:43'! right: anObject right := anObject! ! !NBMemoryBlock methodsFor: 'as yet unclassified' stamp: 'Igor.Stasenko 9/22/2010 04:38'! initialize free := true! ! !NBMemoryBlock methodsFor: 'as yet unclassified' 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: '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: $)! ! Object subclass: #NBMemoryPage instanceVariableNames: 'address length initialBlock' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Heap'! !NBMemoryPage methodsFor: 'as yet unclassified' stamp: 'Igor.Stasenko 9/25/2010 00:32'! address ^ address! ! !NBMemoryPage methodsFor: 'as yet unclassified' stamp: 'Igor.Stasenko 9/25/2010 00:08'! firstBlock ^ initialBlock! ! !NBMemoryPage methodsFor: 'as yet unclassified' stamp: 'Igor.Stasenko 9/25/2010 00:21'! length ^ length! ! !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: '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 class instanceVariableNames: ''! !NBMemoryPage class methodsFor: 'as yet unclassified' stamp: 'Igor.Stasenko 9/24/2010 23:42'! address: addr length: len ^ self basicNew address: addr length: len! ! Error subclass: #NBNativeCodeError instanceVariableNames: 'errorCode' classVariableNames: '' poolDictionaries: 'NativeBoostConstants' category: 'NativeBoost-Core-Errors'! !NBNativeCodeError methodsFor: 'accessing' stamp: 'IgorStasenko 2/20/2012 13:46'! description ^ NBErrorDescriptions at: errorCode ifAbsent: [ 'Error during execution of native code: ' , errorCode asString]. ! ! !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 class instanceVariableNames: ''! !NBNativeCodeError class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 8/6/2011 17:48'! signalError: error ^ self new signalError: error! ! Object subclass: #NBNativeCodeGen instanceVariableNames: 'asm proxy options method' classVariableNames: 'DebugOn' poolDictionaries: 'AJx86Registers NativeBoostConstants' category: 'NativeBoost-Core'! !NBNativeCodeGen commentStamp: 'IgorStasenko 2/15/2012 19:49' prior: 0! 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: 'accessing' stamp: 'Igor.Stasenko 4/11/2010 09:04'! asm ^ asm! ! !NBNativeCodeGen methodsFor: 'accessing' stamp: 'HenrikSperreJohansen 8/23/2011 22:08'! method ^method! ! !NBNativeCodeGen methodsFor: 'accessing' stamp: 'IgorStasenko 5/7/2011 21:27'! newAssembler ^ NativeBoost newAssembler ! ! !NBNativeCodeGen methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/1/2010 10:27'! proxy ^ proxy! ! !NBNativeCodeGen methodsFor: 'accessing' stamp: 'IgorStasenko 8/10/2011 15:08'! stackAlignment ^ self utils stackAlignment ! ! !NBNativeCodeGen methodsFor: 'accessing' stamp: 'IgorStasenko 8/10/2011 15:08'! utils ^ NativeBoost forCurrentPlatform! ! !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: 'code generation' stamp: 'CamilloBruni 7/23/2012 16:40'! epilogue asm emitEpilogue: 0. ! ! !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: '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: 'initialize-release' stamp: 'IgorStasenko 5/9/2011 13:12'! initialize asm := self newAssembler. options := Set new. proxy := NBInterpreterProxy forGenerator: self. self parseOptions: self defaultOptions. ! ! !NBNativeCodeGen methodsFor: 'initialize-release' stamp: 'HenrikSperreJohansen 8/23/2011 22:09'! setMethod: aMethod method := aMethod ! ! !NBNativeCodeGen methodsFor: 'options' stamp: 'Igor.Stasenko 5/1/2010 10:18'! defaultOptions ^ self class defaultOptions! ! !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: 'options' stamp: 'Igor.Stasenko 5/1/2010 10:56'! optionAt: optionName ^ options includes: optionName! ! !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: '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: '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: '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 class instanceVariableNames: ''! !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 ] ]! ! !NBNativeCodeGen class methodsFor: 'debugging' stamp: 'Igor.Stasenko 4/28/2010 18:13'! debugOff DebugOn := false! ! !NBNativeCodeGen class methodsFor: 'debugging' stamp: 'Igor.Stasenko 5/2/2010 18:05'! debugOn DebugOn := true! ! !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: 'error handling' stamp: 'IgorStasenko 9/20/2012 14:43'! 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 primitive = 117) and: [ | lit | lit := method literalAt: 1. lit first = #NativeBoostPlugin and: [ lit second == #primitiveNativeCall]])]) 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: '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/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: 'error handling' stamp: 'IgorStasenko 9/20/2012 14:48'! jitPrimitiveNumber ^ 220! ! !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: 'error handling' stamp: 'IgorStasenko 2/20/2012 13:48'! signalError: errorCode ^ NBNativeCodeError signalError: errorCode ! ! !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: 'instance creation' stamp: 'HenrikSperreJohansen 8/23/2011 22:10'! newForMethod: aMethod ^self new setMethod: aMethod! ! !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: '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: 'options'! 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: '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 ] ! ! NBExternalObject subclass: #NBNativeFunction instanceVariableNames: 'fnSpec annotation' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Objects'! !NBNativeFunction methodsFor: 'accessing' stamp: 'IgorStasenko 8/23/2012 18:16'! address ^ handle! ! !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 methodsFor: 'accessing' stamp: 'CamilloBruni 8/3/2012 15:22'! resourceData ^ handle! ! !NBNativeFunction methodsFor: 'accessing' stamp: 'IgorStasenko 8/23/2012 18:30'! uninstall handle ifNotNil: [ NativeBoost free: handle. handle := nil. ]! ! !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: 'code generation' stamp: 'CamilloBruni 8/3/2012 16:17'! valueWithArguments: anArray "call this native function with the given arguments" self shouldBeImplemented.! ! !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 class instanceVariableNames: ''! !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'! cdecl: fnSpec emit: aFunctionBodyBlock ^ (NBNativeFunctionGen cdecl: fnSpec emit: aFunctionBodyBlock) install.! ! !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: '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'! stdCall: fnSpec emit: aFunctionBodyBlock ^ (NBNativeFunctionGen stdCall: fnSpec emit: aFunctionBodyBlock) install.! ! !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.! ! NBFnArgument subclass: #NBNativeFunctionArgument instanceVariableNames: 'name offset type' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-FFI'! !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! ! !NBNativeFunctionArgument methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/3/2010 19:13'! type ^type! ! !NBNativeFunctionArgument methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/3/2010 19:13'! type: anObject type := anObject! ! !NBNativeFunctionArgument methodsFor: 'as yet unclassified' stamp: 'Igor.Stasenko 5/3/2010 18:58'! name ^ name! ! !NBNativeFunctionArgument methodsFor: 'as yet unclassified' stamp: 'Igor.Stasenko 5/3/2010 18:58'! name: aName name := aName! ! NBFFICallout subclass: #NBNativeFunctionGen instanceVariableNames: 'nativeFunction code callType stackSize returnLabel' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-FFI'! !NBNativeFunctionGen commentStamp: '' prior: 0! 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: 'CamilloBruni 8/3/2012 15:36'! address ^ nativeFunction address! ! !NBNativeFunctionGen methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/13/2010 23:34'! code ^ code! ! !NBNativeFunctionGen methodsFor: 'accessing' stamp: 'IgorStasenko 8/21/2011 11:01'! fnSpec: anonymousSpec fnSpec := NBFnSpecParser new requestor: self ; parseAnonFunction: anonymousSpec! ! !NBNativeFunctionGen methodsFor: 'accessing' stamp: 'CamilloBruni 8/3/2012 15:36'! nativeFunction ^ nativeFunction! ! !NBNativeFunctionGen methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/3/2010 22:12'! nb ^ NativeBoost forCurrentPlatform ! ! !NBNativeFunctionGen methodsFor: 'accessing' stamp: 'CamilloBruni 7/23/2012 16:39'! returnLabel ^ returnLabel ifNil: [ returnLabel := asm uniqueLabelName: 'Return' ]! ! !NBNativeFunctionGen methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/7/2010 22:31'! stackSize ^ stackSize! ! !NBNativeFunctionGen methodsFor: 'as yet unclassified' 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: 'code generation' stamp: 'CamilloBruni 7/23/2012 16:40'! epilogue asm label: self returnLabel; emitEpilogue: (self optStdcall ifTrue: [ stackSize] ifFalse: [0]).! ! !NBNativeFunctionGen methodsFor: 'code generation' stamp: 'IgorStasenko 8/23/2012 18:14'! generate: aFunctionBodyBlock code := AJGeneratedCode fromInstructions: (self generateInstructions: aFunctionBodyBlock). ! ! !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 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: '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: '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:06'! install "install the code into a memory heap" self assert: code notNil. nativeFunction := NBNativeFunction code: code fnSpec: fnSpec. ^ nativeFunction ! ! !NBNativeFunctionGen methodsFor: 'installing' stamp: 'IgorStasenko 8/23/2012 18:04'! uninstall "uninstall the code from a memory heap" nativeFunction ifNotNil: [ nativeFunction uninstall ].! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NBNativeFunctionGen class instanceVariableNames: ''! !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'! cdecl: fnSpec emit: aFunctionBodyBlock options: anOptions ^ self new cdecl; parseOptions: anOptions; 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'! stdCall: fnSpec emit: aFunctionBodyBlock options: anOptions ^ self new parseOptions: anOptions; stdcall; fnSpec: fnSpec; generate: aFunctionBodyBlock; yourself! ! Object subclass: #NBObjectFormat instanceVariableNames: 'asm' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core'! !NBObjectFormat commentStamp: 'Igor.Stasenko 5/19/2010 11:12' prior: 0! i am exposing an object format to ease accessing various object fields directly, without calling interpreter proxy functions, where it is appropriate! !NBObjectFormat methodsFor: 'as yet unclassified' stamp: 'Igor.Stasenko 5/20/2010 05:54'! asm: anAsm asm := anAsm! ! !NBObjectFormat methodsFor: 'as yet unclassified' stamp: 'Igor.Stasenko 5/20/2010 05:52'! indexableWordsFormat self subclassResponsibility ! ! !NBObjectFormat methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'IgorStasenko 11/23/2011 10:44'! isCogVM ^ (Smalltalk vm version beginsWith: 'Squeak') not! ! !NBObjectFormat methodsFor: 'as yet unclassified' stamp: 'Igor.Stasenko 5/19/2010 11:27'! oopSize self subclassResponsibility ! ! !NBObjectFormat methodsFor: 'sizes' stamp: 'HenrikSperreJohansen 8/23/2011 21:44'! baseHeaderSize ^ self oopSize! ! !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: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 class instanceVariableNames: ''! !NBObjectFormat class methodsFor: 'as yet unclassified' 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! ! NBObjectFormat subclass: #NBObjectFormat32 instanceVariableNames: '' classVariableNames: '' poolDictionaries: 'AJx86Registers' category: 'NativeBoost-Core'! !NBObjectFormat32 commentStamp: 'Igor.Stasenko 5/19/2010 11:13' prior: 0! - an object format for 32-bit images! !NBObjectFormat32 methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'Igor.Stasenko 5/19/2010 11:29'! oopSize ^ 4! ! !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: '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: '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: '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 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: '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: '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: '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: '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: '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/22/2011 23:16'! identityHashMask "answer a bit mask for a compact class index in base header " " ggghhhhhhhhhhhhcccccffffsssssstt " ^ 2r00011111111111100000000000000000 ! ! !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: '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 shifts' stamp: 'Igor.Stasenko 5/20/2010 03:35'! compactClassIndexShift "answer a compact class index shift" ^ 12 ! ! !NBObjectFormat32 methodsFor: 'header shifts' stamp: 'HenrikSperreJohansen 8/22/2011 23:01'! immediateShift ^ 24! ! !NBObjectFormat32 methodsFor: 'header shifts' stamp: 'HenrikSperreJohansen 8/23/2011 00:05'! objectFormatShift ^ 8! ! !NBObjectFormat32 methodsFor: 'header shifts' stamp: 'HenrikSperreJohansen 8/23/2011 00:55'! sizeShift ^ 2! ! !NBObjectFormat32 methodsFor: 'object formats' stamp: 'HenrikSperreJohansen 8/22/2011 22:11'! fixedFieldsFormat " fixed fields only (all containing pointers) " ^ 2r0001! ! !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: 'object formats' stamp: 'HenrikSperreJohansen 8/22/2011 22:11'! indexableWordsFormat " indexable word fields only (no pointers) " ^ 2r0110! ! !NBObjectFormat32 methodsFor: 'object formats' stamp: 'Igor.Stasenko 5/20/2010 06:06'! noFieldsFormat ^ 0! ! !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: '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: 'testing' stamp: 'IgorStasenko 8/5/2011 18:14'! stackGrowsDown "Squeak interpreter stack grows up, while StackInterpreter down" ^ self isCogVM! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NBObjectFormat32 class instanceVariableNames: ''! !NBObjectFormat32 class methodsFor: 'as yet unclassified' 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 ]! ! NBExternalType subclass: #NBOop instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Types'! !NBOop commentStamp: '' prior: 0! i am special "type", doing no conversion of any sort, just passing an object oop as it is.! !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 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: 'emitting code' stamp: 'Igor.Stasenko 4/30/2010 13:55'! pushAsValue: gen gen asm push: (loader emitLoad: gen) ! ! Object subclass: #NBProxyFunction instanceVariableNames: 'selector retType arguments index majorVersion minorVersion requiresAlignment' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core'! !NBProxyFunction methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/29/2010 03:29'! arguments ^arguments! ! !NBProxyFunction methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/29/2010 03:29'! arguments: anObject arguments := anObject! ! !NBProxyFunction methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/29/2010 03:29'! majorVersion ^majorVersion! ! !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'! minorVersion ^minorVersion! ! !NBProxyFunction methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/29/2010 03:29'! minorVersion: anObject minorVersion := anObject! ! !NBProxyFunction methodsFor: 'accessing' stamp: 'IgorStasenko 5/11/2011 16:50'! name ^ selector ! ! !NBProxyFunction methodsFor: 'accessing' stamp: 'IgorStasenko 8/3/2011 07:32'! requiresAlignment ^ requiresAlignment ~~ false! ! !NBProxyFunction methodsFor: 'accessing' stamp: 'IgorStasenko 8/3/2011 07:36'! requiresAlignment: aBool requiresAlignment := aBool! ! !NBProxyFunction methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/29/2010 03:29'! retType ^retType! ! !NBProxyFunction methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/29/2010 03:29'! retType: anObject retType := anObject! ! !NBProxyFunction methodsFor: 'as yet unclassified' stamp: 'Igor.Stasenko 4/9/2010 07:14'! = object ^ self class == object class and: [ selector == object selector ]! ! !NBProxyFunction methodsFor: 'as yet unclassified' stamp: 'Igor.Stasenko 4/29/2010 03:34'! address self assert: (index < NBInterpreterProxy functions size). self checkVersion. ^ NBInterpreterProxy fnAddressAt: index! ! !NBProxyFunction methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'Igor.Stasenko 4/9/2010 07:13'! hash ^ selector hash! ! !NBProxyFunction methodsFor: 'as yet unclassified' stamp: 'Igor.Stasenko 4/9/2010 07:35'! index ^ index! ! !NBProxyFunction methodsFor: 'as yet unclassified' stamp: 'Igor.Stasenko 4/9/2010 07:34'! index: anIndex index := anIndex! ! !NBProxyFunction methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'IgorStasenko 5/11/2011 16:47'! printOn: aStream aStream print: selector. arguments ifNotNil: [ aStream space; print: arguments ]! ! !NBProxyFunction methodsFor: 'as yet unclassified' stamp: 'Igor.Stasenko 4/9/2010 07:14'! selector ^ selector! ! !NBProxyFunction methodsFor: 'as yet unclassified' stamp: 'Igor.Stasenko 4/9/2010 07:22'! selector: aSelector selector := aSelector! ! NBFFICallback subclass: #NBQSortCallback instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Objects'! !NBQSortCallback methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/24/2012 15:30'! index ^ index! ! !NBQSortCallback methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/24/2012 15:30'! trunk ^ trunk! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NBQSortCallback class instanceVariableNames: ''! !NBQSortCallback class methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/8/2010 19:17'! callType ^ #cdecl! ! !NBQSortCallback class methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/13/2010 22:54'! fnSpec ^ #(int ( NBExternalAddress a, NBExternalAddress b))! ! Notification subclass: #NBRecursionDetect instanceVariableNames: 'method' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Errors'! !NBRecursionDetect commentStamp: '' prior: 0! 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: 'as yet unclassified' stamp: 'IgorStasenko 5/28/2012 06:46'! check: aMethod method == aMethod ifTrue: [ self resume: true "recursion detected" ] ifFalse: [ self pass ]! ! !NBRecursionDetect methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 5/28/2012 06:01'! defaultAction ^ false "false indicate no recursion"! ! !NBRecursionDetect methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 5/28/2012 05:40'! method ^ method! ! !NBRecursionDetect methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 5/28/2012 05:35'! signalForMethod: aMethod method := aMethod. ^ self signal! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NBRecursionDetect class instanceVariableNames: ''! !NBRecursionDetect class methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'IgorStasenko 5/28/2012 05:41'! signalForMethod: aMethod ^ self new signalForMethod: aMethod ! ! NBFnArgument subclass: #NBSTIndirectArgument instanceVariableNames: 'argumentLoader elementIndex' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-FFI'! !NBSTIndirectArgument methodsFor: 'accessing' stamp: 'cipt 10/24/2012 20:34'! argumentLoader ^ argumentLoader! ! !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 ^ elementIndex! ! !NBSTIndirectArgument methodsFor: 'accessing' stamp: 'cipt 10/24/2012 20:34'! elementIndex: anObject elementIndex := anObject! ! !NBSTIndirectArgument methodsFor: 'accessing' stamp: 'cipt 10/27/2012 12:34'! 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" asm mov: elementIndex asImm to: asm EAX. asm cmp: asm EAX with: 0 asImm. asm jle: boundsFailed. "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'! 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:39'! usesSTStack ^ argumentLoader usesSTStack! ! NBFnArgument subclass: #NBSTIvarArgument instanceVariableNames: 'receiverClass ivarName' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-FFI'! !NBSTIvarArgument commentStamp: 'Igor.Stasenko 4/30/2010 12:24' prior: 0! This guy knows how to load a receiver's ivar. ! !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: 'accessing' stamp: 'Igor.Stasenko 4/30/2010 12:24'! receiverClass ^receiverClass! ! !NBSTIvarArgument methodsFor: 'accessing' stamp: 'Igor.Stasenko 4/30/2010 12:24'! receiverClass: anObject receiverClass := anObject! ! !NBSTIvarArgument methodsFor: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'Igor.Stasenko 5/18/2010 02:22'! usesSTStack ^ true " to fetch receiver we accessing the stack"! ! NBFnArgument subclass: #NBSTMethodArgument instanceVariableNames: 'stackIndex isReceiver' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-FFI'! !NBSTMethodArgument commentStamp: 'Igor.Stasenko 4/30/2010 10:47' prior: 0! i know what to emit for loading a method's argument from VM stack into register ! !NBSTMethodArgument methodsFor: 'accessing' stamp: 'IgorStasenko 8/5/2011 18:00'! isReceiver ^ isReceiver ! ! !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: 'accessing' stamp: 'Igor.Stasenko 4/30/2010 07:23'! stackIndex: anObject stackIndex := anObject! ! !NBSTMethodArgument methodsFor: 'emitting the code' stamp: 'Igor.Stasenko 4/30/2010 07:25'! emitLoad: gen gen proxy stackValue: stackIndex. ^ gen asm EAX! ! !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: 'initialize-release' stamp: 'IgorStasenko 8/5/2011 18:00'! initialize isReceiver := false! ! !NBSTMethodArgument methodsFor: 'testing' stamp: 'Igor.Stasenko 5/18/2010 02:22'! usesSTStack ^ true " to fetch receiver we accessing the stack"! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NBSTMethodArgument class instanceVariableNames: ''! !NBSTMethodArgument class methodsFor: 'errors' stamp: 'IgorStasenko 8/6/2011 18:20'! lastError ^ self error: 'NativeBoost plugin is missing?'! ! Announcement subclass: #NBSessionChangeAnnouncement instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core'! NBIntegerExternalType subclass: #NBSizeT instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Types'! !NBSizeT commentStamp: '' prior: 0! 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 instanceVariableNames: ''! !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'! ! NBExternalType subclass: #NBTCHAR instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Win32'! !NBTCHAR commentStamp: 'Igor.Stasenko 4/29/2010 13:44' prior: 0! - depending on context, acts either as char or wchar! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NBTCHAR class instanceVariableNames: ''! !NBTCHAR class methodsFor: 'as yet unclassified' stamp: 'Igor.Stasenko 5/1/2010 10:56'! asNBExternalType: gen ^ (gen optionAt: #WinUnicode) ifTrue: [ 'wchar_t' asNBExternalType: gen ] ifFalse: [ #uchar asNBExternalType: gen ] ! ! NBExternalType subclass: #NBTString instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Win32'! !NBTString commentStamp: 'Igor.Stasenko 4/29/2010 14:26' prior: 0! - depending on context, acts either as char* or wchar* string! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NBTString class instanceVariableNames: ''! !NBTString class methodsFor: 'as yet unclassified' stamp: 'Igor.Stasenko 5/1/2010 10:56'! asNBExternalType: gen ^ (gen optionAt: #WinUnicode) ifTrue: [ NBWideString asNBExternalType: gen ] ifFalse: [ NBExternalString asNBExternalType: gen ] ! ! NBIntegerExternalType subclass: #NBUInt16 instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Types'! !NBUInt16 commentStamp: '' prior: 0! I responsible for marshalling unsigned 16-bit integer type values.! !NBUInt16 methodsFor: 'accessing' stamp: 'IgorStasenko 9/2/2012 23:14'! valueSize ^ 2! ! !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: 'emitting code' stamp: 'IgorStasenko 9/2/2012 23:14'! pushAsValue: gen gen asm push: (gen proxy positive32BitValueOf: (loader emitLoad: gen))! ! NBIntegerExternalType subclass: #NBUInt32 instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Types'! !NBUInt32 commentStamp: '' prior: 0! I responsible for marshalling unsigned 32-bit integer type values.! !NBUInt32 methodsFor: 'accessing' stamp: 'IgorStasenko 9/2/2012 23:17'! valueSize ^ 4! ! !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: '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' ]. ].! ! NBIntegerExternalType subclass: #NBUInt64 instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Types'! !NBUInt64 commentStamp: '' prior: 0! I responsible for marshalling unsigned 64-bit integer type values.! !NBUInt64 methodsFor: 'accessing' stamp: 'IgorStasenko 9/2/2012 23:22'! valueSize ^ 8! ! !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: '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' ]. ].! ! !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 ! ! NBIntegerExternalType subclass: #NBUInt8 instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Types'! !NBUInt8 commentStamp: '' prior: 0! I responsible for marshalling unsigned 8-bit integer type values.! !NBUInt8 methodsFor: 'accessing' stamp: 'IgorStasenko 9/2/2012 23:12'! valueSize ^ 1! ! !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: 'emitting code' stamp: 'IgorStasenko 9/2/2012 23:12'! pushAsValue: gen gen asm push: ( gen proxy positive32BitValueOf: (loader emitLoad: gen)). ! ! NBExternalType subclass: #NBUTF8StringExample instanceVariableNames: 'address' classVariableNames: '' poolDictionaries: 'AJx86Registers' category: 'NativeBoost-Examples'! !NBUTF8StringExample commentStamp: 'IgorStasenko 8/8/2011 17:29' prior: 0! 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. ! ! SharedPool subclass: #NBUnixConstants instanceVariableNames: '' classVariableNames: 'MAP_32BIT MAP_ANON MAP_ANONYMOUS MAP_DENYWRITE MAP_EXECUTABLE MAP_FAILED MAP_FILE MAP_FIXED MAP_GROWSDOWN MAP_LOCKED MAP_NONBLOCK MAP_NORESERVE MAP_POPULATE MAP_PRIVATE MAP_SHARED MAP_STACK MAP_TYPE PROT_EXEC PROT_GROWSDOWN PROT_GROWSUP PROT_NONE PROT_READ PROT_WRITE RTLD_BINDING_MASK RTLD_DEEPBIND RTLD_DEFAULT RTLD_GLOBAL RTLD_LAZY RTLD_LOCAL RTLD_NEXT RTLD_NODELETE RTLD_NOLOAD RTLD_NOW' poolDictionaries: '' category: 'NativeBoost-Unix'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NBUnixConstants class instanceVariableNames: ''! !NBUnixConstants class methodsFor: 'as yet unclassified' 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: 'as yet unclassified' 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"! ! !NBUnixConstants class methodsFor: 'as yet unclassified' stamp: 'Igor.Stasenko 9/25/2010 06:57'! initialize " self initialize " "from " self initDlopenFlags; initMmapFlags! ! NBExternalHeapManager subclass: #NBUnixExternalHeapManager instanceVariableNames: '' classVariableNames: '' poolDictionaries: 'NBUnixConstants' category: 'NativeBoost-Unix'! !NBUnixExternalHeapManager commentStamp: 'Igor.Stasenko 9/26/2010 04:05' prior: 0! Unix heap implementation, based on mmap()/munmap() functions to manage external heap.! !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: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: '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: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: '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 ! ! NBExternalType subclass: #NBVoid instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core-Types'! !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!!'! ! WeakFinalizerItem weakSubclass: #NBWeakFinalizerItem instanceVariableNames: 'index' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Core'! !NBWeakFinalizerItem methodsFor: 'accessing' stamp: 'IgorStasenko 5/31/2012 03:15'! index ^ index! ! !NBWeakFinalizerItem methodsFor: 'accessing' stamp: 'IgorStasenko 5/31/2012 03:15'! index: aNumber index := aNumber! ! !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:48'! nextFreeIndex ^ next! ! !NBWeakFinalizerItem methodsFor: 'accessing' stamp: 'IgorStasenko 5/31/2012 04:00'! object: anObject executor: ex executor := ex. self basicAt: 1 put: anObject! ! !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.! ! NBExternalType subclass: #NBWideString instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Win32'! NBExternalObject subclass: #NBWin32Handle instanceVariableNames: '' classVariableNames: '' poolDictionaries: 'NBWinConstants NBWinTypes' category: 'NativeBoost-Win32'! !NBWin32Handle commentStamp: '' prior: 0! Instances of this class represent a reference value to a Win32 resource (file, window, ...)! !NBWin32Handle methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/17/2010 05:02'! value: uint handle value: uint! ! !NBWin32Handle methodsFor: 'call convention' stamp: 'IgorStasenko 11/25/2012 14:16'! nbCallingConvention ^ #stdcall! ! !NBWin32Handle methodsFor: 'conversion' stamp: 'Igor.Stasenko 5/18/2010 22:56'! asUnsignedLong ^ handle asUnsignedLong! ! NBWin32Handle subclass: #NBWin32Hdc instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Win32'! !NBWin32Hdc methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'IgorStasenko 11/25/2012 14:17'! moveToX: x y: y ^self nbCall: #(BOOL MoveToEx(HDC self, int x, int y, 0)) module: #gdi32 ! ! !NBWin32Hdc methodsFor: 'as yet unclassified' 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 ! ! NBWin32Handle subclass: #NBWin32Heap instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Win32'! !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:30'! alloc: numberOfBytes ^ self nbCall: #( LPVOID HeapAlloc (self , 0 , SIZE_T numberOfBytes) )! ! !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: 'win heap api' stamp: 'IgorStasenko 11/24/2012 17:31'! destroy ^ self nbCall: #( BOOL HeapDestroy (self) )! ! !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'! lock ^ self nbCall: #( BOOL HeapLock (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'! realloc: flags mem: lpMem size: dwBytes ^ self nbCall: #( LPVOID HeapReAlloc (self, DWORD flags, LPVOID lpMem, SIZE_T dwBytes) ) ! ! !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:32'! unlock ^ self nbCall: #( BOOL HeapUnlock (self) ) ! ! !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: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 class instanceVariableNames: ''! !NBWin32Heap class methodsFor: 'as yet unclassified' 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 ! ! Object subclass: #NBWin32MessageBox instanceVariableNames: '' classVariableNames: '' poolDictionaries: 'NBWinConstants NBWinTypes' category: 'NativeBoost-Win32'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NBWin32MessageBox class instanceVariableNames: ''! !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! ! !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! ! Object subclass: #NBWin32Shell instanceVariableNames: '' classVariableNames: '' poolDictionaries: 'NBWinConstants NBWinTypes' category: 'NativeBoost-Win32'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NBWin32Shell class instanceVariableNames: ''! !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: 'accessing' stamp: 'tbn 11/9/2012 22:28'! getApplicationDataFolder "Return the folder for application data self getApplicationDataFolder " ^self getEnvironmentVariable: 'APPDATA'! ! !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: '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: 'accessing' 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: 'accessing' stamp: 'tbn 11/9/2012 22:29'! getHomeDrive "Return the drive letter of the home drive. self getHomeDrive " ^self getEnvironmentVariable: 'HOMEDRIVE'! ! !NBWin32Shell class methodsFor: 'accessing' 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: 'accessing' stamp: 'tbn 11/9/2012 22:29'! getNumberOfProcessors "Return the number of processors/cores. self getNumberOfProcessors " ^self getEnvironmentVariable: 'NUMBER_OF_PROCESSORS'! ! !NBWin32Shell class methodsFor: 'accessing' stamp: 'tbn 11/9/2012 22:29'! getOS "Return the name of the OS" ^self getEnvironmentVariable: 'OS'! ! !NBWin32Shell class methodsFor: 'accessing' stamp: 'tbn 11/9/2012 22:29'! getPathEntries "Return the PATH entries" ^(self getEnvironmentVariable: 'PATH') findTokens: $;! ! !NBWin32Shell class methodsFor: 'accessing' 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: 'accessing' stamp: 'tbn 11/9/2012 22:29'! getProcessorArchitecture "Return processor chip architecture. Values: x86, IA64. self getProcessorArchitecture " ^self getEnvironmentVariable: 'PROCESSOR_ARCHITECTURE'! ! !NBWin32Shell class methodsFor: 'accessing' stamp: 'tbn 11/9/2012 22:29'! getProcessorIdentifier "Return a description of the processor. self getProcessorIdentifier " ^self getEnvironmentVariable: 'PROCESSOR_IDENTIFIER'! ! !NBWin32Shell class methodsFor: 'accessing' 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: 'accessing' stamp: 'tbn 11/9/2012 22:29'! getProcessorRevision "Return the revision number of the processor. self getProcessorRevision " ^self getEnvironmentVariable: 'PROCESSOR_REVISION'! ! !NBWin32Shell class methodsFor: 'accessing' stamp: 'tbn 11/9/2012 22:30'! getProgramFilesDirectory "Return the program files directory self getProgramFilesDirectory " ^self getEnvironmentVariable: 'PROGRAMFILES'! ! !NBWin32Shell class methodsFor: 'accessing' 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: 'accessing' 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: 'accessing' stamp: 'tbn 11/9/2012 22:30'! getTempDirectory "Return the name of the temp directory. self getTempDirectory " ^self getEnvironmentVariable: 'TEMP'! ! !NBWin32Shell class methodsFor: 'accessing' stamp: 'tbn 11/9/2012 22:30'! getTmpDirectory "Return the name of the temp directory. self getTmpDirectory " ^self getEnvironmentVariable: 'TMP'! ! !NBWin32Shell class methodsFor: 'accessing' 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:30'! getUserName "Return the name of the logged in user self getUserName " ^self getEnvironmentVariable: 'USERNAME'! ! !NBWin32Shell class methodsFor: 'accessing' 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: 'accessing' stamp: 'tbn 11/9/2012 22:30'! getWindowsDirectory "Return the path to the windows directory" ^self getEnvironmentVariable: 'windir'! ! !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: '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: '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: '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: '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: '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: '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: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'! 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: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:32'! showAccessibilitySoundSettings "Show the sound settings for accessibility self showAccessibilitySoundSettings " ^self shellRunDLL: 'shell32.dll,Control_RunDLL access.cpl,,2'! ! !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:32'! showBluetoothSettings " self showBluetoothSettings " ^self shellRunDLL: 'irprops.cpl,,BluetoothAuthenticationAgent'! ! !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: 'control panel applets' stamp: 'tbn 11/9/2012 22:32'! showControlPanel " self showControlPanel " ^self shellRunDLL: 'Shell32.dll,Control_RunDLL'! ! !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: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:32'! showDisplaySettingsAppearance " self showDisplaySettingsAppearance " ^self shellRunDLL: 'shell32.dll,Control_RunDLL desk.cpl,,2'! ! !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: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: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:33'! showFindFastSetting " self showFindFastSetting " ^self shellRunDLL: 'shell32.dll,Control_RunDLL findfast.cpl'! ! !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: '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:33'! showFormatDrive " self showFormatDrive " ^self shellRunDLL: 'shell32.dll,SHFormatDrive'! ! !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:33'! showInternationalSettingsCurrency " self showInternationalSettingsCurrency " ^self shellRunDLL: 'Shell32.dll,Control_RunDLL Intl.cpl,,2'! ! !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: '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:34'! showInternationalSettingsNumber "Show the internation settings dialog for number. self showInternationalSettingsNumber " ^self shellRunDLL: 'Shell32.dll,Control_RunDLL Intl.cpl,,1'! ! !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:34'! showInternationalSettingsTime "Show the internation settings for input locales. self showInternationalSettingsTime " ^self shellRunDLL: 'Shell32.dll,Control_RunDLL Intl.cpl,,3'! ! !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:34'! showInternetExplorerSettings "Show the internet explorer settings self showInternetExplorerSettings " ^self shellRunDLL: 'Shell32.dll,Control_RunDLL Inetcpl.cpl,,6'! ! !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:34'! showInternetSettingsConnections " self showInternetSettingsConnections " ^self shellRunDLL: 'Shell32.dll,Control_RunDLL Inetcpl.cpl,,4'! ! !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: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: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: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:35'! showJoystickSettings " self showJoystickSettings " ^self shellRunDLL: 'shell32.dll,Control_RunDLL joy.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: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'! showMapNetworkDriveWizard " self showMapNetworkDriveWizard " ^self shellRunDLL: 'Shell32.dll,SHHelpShortcuts_RunDLL Connect'! ! !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:35'! showModemSettings " self showModemSettings " ^self shellRunDLL: 'shell32.dll,Control_RunDLL modem.cpl' ! ! !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'! showMultimediaSettingsAudio " self showMultimediaSettingsAudio " ^self shellRunDLL: 'shell32.dll,Control_RunDLL mmsys.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:35'! showMultimediaSettingsDevices " self showMultimediaSettingsDevices " ^self shellRunDLL: 'shell32.dll,Control_RunDLL mmsys.cpl,,4'! ! !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: '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:36'! showODBCSettings " self showODBCSettings " ^self shellRunDLL: 'shell32.dll,Control_RunDLL odbccp32.cpl' ! ! !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:36'! showPrinterManagementFolder " self showPrinterManagementFolder " ^self shellRunDLL: 'Shell32.dll,SHHelpShortcuts_RunDLL PrintersFolder'! ! !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:36'! showProgramPropertiesInstallUninstall " self showProgramPropertiesInstallUninstall " ^self shellRunDLL: 'shell32.dll,Control_RunDLL appwiz.cpl,,1'! ! !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: '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: 'control panel applets' stamp: 'tbn 11/9/2012 22:36'! showServerProperties " self showServerProperties " ^self shellRunDLL: 'shell32.dll,Control_RunDLL srvmgr.cpl' ! ! !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: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:37'! showTelephonySettings " self showTelephonySettings " ^self shellRunDLL: 'shell32.dll,Control_RunDLL telephon.cpl' ! ! !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: '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: '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: '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: '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: '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: '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: '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: 'special' stamp: 'tbn 11/9/2012 22:22'! lockWorkstation "Locks the workstation." ^ self nbCall: #(BOOL LockWorkStation(void)) module: #user32 ! ! NBWin32Handle subclass: #NBWin32Window instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NativeBoost-Win32'! !NBWin32Window commentStamp: 'Igor.Stasenko 4/29/2010 10:54' prior: 0! Through WinTypes pool, i seen as HWND type , so whenever you type HWND, you are working with instances of me ! !NBWin32Window methodsFor: 'accessing' stamp: 'IgorStasenko 11/25/2012 14:18'! getDC ^ self nbCall: #( HDC GetDC ( 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: 'accessing' stamp: 'tbn 11/12/2012 07:11'! getWindowStyle "Retrieves the window styles" ^self getWindowLongAtIndex: GWL_STYLE! ! !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: '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: 'accessing' stamp: 'IgorStasenko 11/25/2012 14:19'! setWindowText: lpString ^self nbCall: #(BOOL SetWindowTextA(HWND self, LPCTSTR lpString)) module: #user32 ! ! !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: 'api' stamp: 'IgorStasenko 11/25/2012 14:18'! getWindowLongAtIndex: nIndex ^self nbCall: #(LONG GetWindowLongA(HWND self, int nIndex)) 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: '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: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'IgorStasenko 11/24/2012 17:38'! show "destroy the window" ^ self nbCallout stdcall options: #( + optMayGC ); " calls windowproc" function: #( BOOL ShowWindow ( HWND self, SW_SHOW )) module: #user32 ! ! !NBWin32Window methodsFor: 'operations' stamp: 'Igor.Stasenko 5/17/2010 15:11'! destroy ^ self destroyWindow! ! !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: '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: '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: 'testing' stamp: 'IgorStasenko 11/25/2012 14:19'! isZoomed "Determines whether a window is maximized. " ^self nbCall: #(BOOL IsZoomed(HWND self)) module: #user32 ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NBWin32Window class instanceVariableNames: ''! !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 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: 'IgorStasenko 4/6/2012 13:58'! DefWindowProcA ^ NativeBoost loadSymbol: #DefWindowProcA fromModule: #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 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: 'as yet unclassified' 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: 'callout options' stamp: 'IgorStasenko 9/16/2012 18:10'! ffiCalloutOptions ^ #( + optMayGC )! ! SharedPool subclass: #NBWinConstants instanceVariableNames: '' classVariableNames: 'CS_BYTEALIGNCLIENT CS_BYTEALIGNWINDOW CS_CLASSDC CS_DBLCLKS CS_DROPSHADOW CS_GLOBALCLASS CS_HREDRAW CS_IME CS_NOCLOSE CS_OWNDC CS_PARENTDC CS_SAVEBITS CS_VREDRAW CW_USEDEFAULT DRIVE_CDROM DRIVE_FIXED DRIVE_NO_ROOT_DIR DRIVE_RAMDISK DRIVE_REMOTE DRIVE_REMOVABLE DRIVE_UNKNOWN GWL_EXSTYLE GWL_HINSTANCE GWL_HWNDPARENT GWL_ID GWL_STYLE GWL_USERDATA GWL_WNDPROC HEAP_CREATE_ENABLE_EXECUTE HEAP_GENERATE_EXCEPTIONS HEAP_NO_SERIALIZE HEAP_REALLOC_IN_PLACE_ONLY HEAP_ZERO_MEMORY IDABORT IDCANCEL IDCONTINUE IDIGNORE IDNO IDOK IDRETRY IDTRYAGAIN IDYES MB_ABORTRETRYIGNORE MB_APPLMODAL MB_CANCELTRYCONTINUE MB_DEFAULT_DESKTOP_ONLY MB_DEFBUTTON1 MB_DEFBUTTON2 MB_DEFBUTTON3 MB_DEFBUTTON4 MB_HELP MB_ICONASTERISK MB_ICONERROR MB_ICONEXCLAMATION MB_ICONHAND MB_ICONINFORMATION MB_ICONQUESTION MB_ICONSTOP MB_ICONWARNING MB_OK MB_OKCANCEL MB_RETRYCANCEL MB_RIGHT MB_RTLREADING MB_SERVICE_NOTIFICATION MB_SETFOREGROUND MB_SYSTEMMODAL MB_TASKMODAL MB_TOPMOST MB_YESNO MB_YESNOCANCEL PFD_DEPTH_DONTCARE PFD_DOUBLEBUFFER PFD_DOUBLEBUFFER_DONTCARE PFD_DRAW_TO_BITMAP PFD_DRAW_TO_WINDOW PFD_GENERIC_ACCELERATED PFD_GENERIC_FORMAT PFD_MAIN_PLANE PFD_NEED_PALETTE PFD_NEED_SYSTEM_PALETTE PFD_OVERLAY_PLANE PFD_STEREO PFD_STEREO_DONTCARE PFD_SUPPORT_DIRECTDRAW PFD_SUPPORT_GDI PFD_SUPPORT_OPENGL PFD_SWAP_COPY PFD_SWAP_EXCHANGE PFD_SWAP_LAYER_BUFFERS PFD_TYPE_COLORINDEX PFD_TYPE_RGBA PFD_UNDERLAY_PLANE SW_FORCEMINIMIZE SW_HIDE SW_MAX SW_MAXIMIZE SW_MINIMIZE SW_NORMAL SW_RESTORE SW_SHOW SW_SHOWDEFAULT SW_SHOWMAXIMIZED SW_SHOWMINIMIZED SW_SHOWMINNOACTIVE SW_SHOWNA SW_SHOWNOACTIVATE SW_SHOWNORMAL WM_ACTIVATEAPP WM_CANCELMODE WM_CHILDACTIVATE WM_CLOSE WM_COMPACTING WM_CREATE WM_DESTROY WM_ENABLE WM_ENTERSIZEMOVE WM_EXITSIZEMOVE WM_GETICON WM_GETMINMAXINFO WM_INPUTLANGCHANGE WM_INPUTLANGCHANGEREQUEST WM_MOVE WM_MOVING WM_NCACTIVATE WM_NCCALCSIZE WM_NCCREATE WM_NCDESTROY WM_NULL WM_QUERYDRAGICON WM_QUERYOPEN WM_QUIT WM_SHOWWINDOW WM_SIZE WM_SIZING WM_STYLECHANGED WM_STYLECHANGING WM_THEMECHANGED WM_USERCHANGED WM_WINDOWPOSCHANGED WM_WINDOWPOSCHANGING WS_BORDER WS_CAPTION WS_CHILD WS_CHILDWINDOW WS_CLIPCHILDREN WS_CLIPSIBLINGS WS_DISABLED WS_DLGFRAME WS_EX_ACCEPTFILES WS_EX_APPWINDOW WS_EX_CLIENTEDGE WS_EX_COMPOSITED WS_EX_CONTEXTHELP WS_EX_CONTROLPARENT WS_EX_DLGMODALFRAME WS_EX_LAYERED WS_EX_LAYOUTRTL WS_EX_LEFT WS_EX_LEFTSCROLLBAR WS_EX_LTRREADING WS_EX_MDICHILD WS_EX_NOACTIVATE WS_EX_NOINHERITLAYOUT WS_EX_NOPARENTNOTIFY WS_EX_OVERLAPPEDWINDOW WS_EX_PALETTEWINDOW WS_EX_RIGHT WS_EX_RIGHTSCROLLBAR WS_EX_RTLREADING WS_EX_STATICEDGE WS_EX_TOOLWINDOW WS_EX_TOPMOST WS_EX_TRANSPARENT WS_EX_WINDOWEDGE WS_GROUP WS_HSCROLL WS_ICONIC WS_MAXIMIZE WS_MAXIMIZEBOX WS_MINIMIZE WS_MINIMIZEBOX WS_OVERLAPPED WS_OVERLAPPEDWINDOW WS_POPUP WS_POPUPWINDOW WS_SIZEBOX WS_SYSMENU WS_TABSTOP WS_THICKFRAME WS_TILED WS_TILEDWINDOW WS_VISIBLE WS_VSCROLL' poolDictionaries: '' category: 'NativeBoost-Win32'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NBWinConstants class instanceVariableNames: ''! !NBWinConstants class methodsFor: 'class initialization' stamp: 'tbn 11/12/2012 09:52'! initialize " self initialize" self classStyles; heapConstants; windowStyles; windowExStyles; windowCreationConstants; gdiConstants; showWindowConstants; messageBoxConstants; getWindowLongConstants; windowMessages; driveTypes! ! !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: '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: '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. ! ! !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: '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: '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: 'Igor.Stasenko 5/20/2010 07:57'! 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/17/2010 14:27'! windowCreationConstants CW_USEDEFAULT := 16r80000000. ! ! !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: '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: '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. ! ! Object subclass: #NBWinTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: 'NBWinConstants NBWinTypes' category: 'NativeBoost-Win32'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NBWinTest class instanceVariableNames: ''! !NBWinTest class methodsFor: 'as yet unclassified' stamp: 'Igor.Stasenko 4/29/2010 15:35'! createWindow " NBWin32Window createWindowExA: lpClassName: lpWindowName: dwStyle: x: y: width: height: hWndParent: hMenu: hInstance: lParam: "! ! SharedPool subclass: #NBWinTypes instanceVariableNames: '' classVariableNames: 'ATOM BOOL BOOLEAN BYTE CALLBACK CHAR COLORREF DWORD DWORD32 DWORD64 DWORDLONG DWORD_PTR FLOAT HACCEL HALF_PTR HANDLE HBRUSH HCOLORSPACE HCONV HCONVLIST HCURSOR HDC HDDEDATA HDESK HDROP HDWP HENHMETAFILE HFILE HFONT HGDIOBJ HGLOBAL HHOOK HICON HINSTANCE HKEY HKL HLOCAL HMENU HMETAFILE HMODULE HMONITOR HPALETTE HPEN HRESULT HRGN HRSRC HSZ HWINSTA HWND INT INT32 INT64 INT_PTR LANGID LCID LCTYPE LGRPID LONG LONG32 LONG64 LONGLONG LONG_PTR LPARAM LPBOOL LPBYTE LPCOLORREF LPCSTR LPCTSTR LPCVOID LPCWSTR LPDWORD LPHANDLE LPINT LPLONG LPSTR LPTCH LPTSTR LPVOID LPWCH LPWORD LPWSTR LRESULT PBOOL PBOOLEAN PBYTE PCHAR PCSTR PCTSTR PCWSTR PDWORD PDWORD32 PDWORD64 PDWORDLONG PDWORD_PTR PFLOAT PHALF_PTR PHANDLE PHKEY PINT PINT32 PINT64 PINT_PTR PLCID PLONG PLONG32 PLONG64 PLONGLONG PLONG_PTR POINTER_32 POINTER_64 PSHORT PSIZE_T PSSIZE_T PSTR PTBYTE PTCHAR PTSTR PUCHAR PUHALF_PTR PUINT PUINT32 PUINT64 PUINT_PTR PULONG PULONG32 PULONG64 PULONGLONG PULONG_PTR PUSHORT PVOID PWCHAR PWORD PWSTR SC_HANDLE SC_LOCK SERVICE_STATUS_HANDLE SHORT SIZE_T SSIZE_T TBYTE TCHAR UCHAR UHALF_PTR UINT UINT32 UINT64 UINT_PTR ULONG ULONG32 ULONG64 ULONGLONG ULONG_PTR USHORT USN VOID WCHAR WNDCLASSEX WNDPROC WORD WPARAM' poolDictionaries: '' category: 'NativeBoost-Win32'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NBWinTypes class instanceVariableNames: ''! !NBWinTypes class methodsFor: 'initialization' stamp: 'Igor.Stasenko 5/19/2010 07:14'! initialize " self initialize " BOOL := #bool. DWORD := #ulong. HWND := #NBWin32Window. 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 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" ! ! !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: 'object types' stamp: 'Igor.Stasenko 5/17/2010 15:19'! objTypes WNDCLASSEX := #NBWndClassEx! ! NBExternalStructure variableByteSubclass: #NBWndClassEx instanceVariableNames: '' classVariableNames: '' poolDictionaries: 'NBWinTypes' category: 'NativeBoost-Win32'! !NBWndClassEx methodsFor: 'initialize-release' stamp: 'Igor.Stasenko 4/29/2010 14:05'! initialize self cbSize: (self basicSize).! ! !NBWndClassEx methodsFor: 'registering' stamp: 'IgorStasenko 11/24/2012 16:24'! register ^ self nbCallout stdcall function: #( ATOM RegisterClassExA (WNDCLASSEX * self) ) module: #user32! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NBWndClassEx class instanceVariableNames: ''! !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 ! ! NECEntry subclass: #NECClassVarEntry instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NECompletion-Model'! !NECClassVarEntry commentStamp: '' prior: 0! I represent a class Variable! !NECClassVarEntry methodsFor: 'accessing'! label ^ 'class variable'! ! !NECClassVarEntry methodsFor: 'operations'! guessTypeWith: anECContext ^ anECContext guessClassVarClass: contents! ! NECVarTypeGuesser subclass: #NECClassVarTypeGuesser instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NECompletion-Model'! !NECClassVarTypeGuesser commentStamp: '' prior: 0! I'm a simple InstructionClient that tries to guess the type of a given class variable name of a class. ! !NECClassVarTypeGuesser methodsFor: 'bytecode decoding'! popIntoLiteralVariable: anAssociation anAssociation key == variableName asSymbol ifTrue: [ found := true ] ifFalse: [ self reset ]! ! !NECClassVarTypeGuesser methodsFor: 'bytecode decoding'! send: selector super: supered numArgs: numberArguments ! ! !NECClassVarTypeGuesser methodsFor: 'instruction decoding'! popIntoReceiverVariable: offset self reset! ! !NECClassVarTypeGuesser methodsFor: 'public'! methodRefs | theClass classVarAssoc | theClass := receiverClass classThatDefinesClassVariable: variableName. classVarAssoc := theClass classPool associationAt: variableName asSymbol. classVarAssoc value ifNil: [ ^ SystemNavigation new allCallsOn: classVarAssoc ] ifNotNil: [ ^ classVarAssoc value class ]! ! TestCase subclass: #NECClassVarTypeGuesserTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NECompletion-Tests'! !NECClassVarTypeGuesserTest methodsFor: 'tests'! testClassVar self guessVariable: 'ClassVar' in: NECTestClass expected: ByteString! ! !NECClassVarTypeGuesserTest methodsFor: 'tests'! testDependentsFieldsClassVar self guessVariable: 'DependentsFields' in: NECTestClass expected: WeakIdentityKeyDictionary! ! !NECClassVarTypeGuesserTest methodsFor: 'tests'! testSuperClassVar self guessVariable: 'SuperClassVar' in: NECTestClass expected: Dictionary ! ! !NECClassVarTypeGuesserTest methodsFor: 'utils'! guessVariable: aString in: aClass expected: theClassExpected | typeGuesser result | typeGuesser := NECClassVarTypeGuesser variableName: aString class: aClass. result := typeGuesser perform. self assert: result == theClassExpected! ! Object subclass: #NECContext instanceVariableNames: 'source position theClass ranges completionIndex recurseCount receiverClass completionToken model controller variables selectors' classVariableNames: '' poolDictionaries: '' category: 'NECompletion-Model'! !NECContext commentStamp: '' prior: 0! 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: 'accessing'! completionToken completionToken ifNil: [ | range | range := ranges at: completionIndex. completionToken := self sourceOf: range stopAt: position. completionToken := completionToken wordBefore: completionToken size ]. ^ completionToken! ! !NECContext methodsFor: 'accessing' stamp: 'EstebanLorenzano 2/1/2013 18:01'! 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 ifNotNilDo: [:class | modelClass := class]]. ^ modelClass class: theClass temporaries: self temporaries additionals: controller additionals variables: variables selectors: selectors! ! !NECContext methodsFor: 'accessing'! model model isNil ifTrue: [ model := self createModel ]. ^ model! ! !NECContext methodsFor: 'accessing'! 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: 'accessing'! theClass ^theClass! ! !NECContext methodsFor: 'action'! narrowWith: aString completionToken := aString. model ifNotNil: [ model narrowWith: aString ]! ! !NECContext methodsFor: 'action'! switchToUntyped receiverClass := nil. self configureSelectorsAndVariables. model := self createModel! ! !NECContext methodsFor: 'initialize-release'! initialize super initialize. source := String new. position := 0. recurseCount := 0. variables := true. selectors := true. ranges := OrderedCollection new. completionIndex := 0. completionToken := nil! ! !NECContext methodsFor: 'initialize-release'! setController: aECController class: aClass source: aString position: anInteger controller := aECController. theClass := aClass. source := aString. position := anInteger. self createRanges. self compute! ! !NECContext methodsFor: 'private'! compute completionIndex := self computeIndexOfPosition. receiverClass := self computeReceiverClass! ! !NECContext methodsFor: 'private'! 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: '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'! 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'! 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' 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'! 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: 'private'! guessTempVarClass: aSHRange ^self guessTempVarClass: (self sourceOf: aSHRange) type: aSHRange type. ! ! !NECContext methodsFor: 'private'! 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: 'private'! receiverClass ^ receiverClass! ! !NECContext methodsFor: 'private'! sourceOf: aSHRange ^aSHRange isString ifTrue: [aSHRange] ifFalse: [self sourceOf: aSHRange stopAt: aSHRange end]! ! !NECContext methodsFor: 'private'! sourceOf: aSHRange stopAt: aNumber ^ aSHRange type = #empty ifTrue: [String new] ifFalse: [source copyFrom: aSHRange start to: aNumber]! ! !NECContext methodsFor: 'private-compute-index'! checkForZeroPosition ^ (position = 0 or: [ranges isEmpty]) and: [self insertEmptyRangeAt: 1 start: 0 end: 1. true]! ! !NECContext methodsFor: 'private-compute-index'! 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-compute-index'! createEmptyRangeAtTail | previous | previous := ranges last. ranges add: (SHRange start: previous end + 1 end: source size type: #empty). ^ ranges size! ! !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-compute-index'! insertEmptyRangeAt: index start: start end: end ranges add: (SHRange start: start end: end type: #empty) beforeIndex: index! ! !NECContext methodsFor: 'private-configure'! configureSelectorsAndVariables variables := true. selectors := true. ^true! ! !NECContext methodsFor: 'private-configure'! configureSelectorsOnly variables := false. selectors := true. ^true! ! !NECContext methodsFor: 'private-configure'! configureVariablesOnly variables := true. selectors := false. ^true! ! !NECContext methodsFor: 'private-receiver-guessing'! checkImpossibleReceiver ^ self isSelectorsAndVariables ifTrue: [self configureSelectorsAndVariables] ifFalse: [self isVariablesOnly ifTrue: [self configureVariablesOnly] ifFalse: [self isSelectorsOnly and: [self configureSelectorsOnly]]]. ! ! !NECContext methodsFor: 'private-receiver-guessing'! isSelectorsAndVariables | current | current := ranges at: completionIndex. ^current isUnfinished! ! !NECContext methodsFor: 'private-receiver-guessing'! isSelectorsOnly | previous | previous := ranges at: completionIndex - 1. ^previous isOpening! ! !NECContext methodsFor: 'private-receiver-guessing'! 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-roel-typer'! findCommonSuperclass: aCollection | current | aCollection isEmpty ifTrue: [ ^ nil ]. current := aCollection first. aCollection do: [ :class | [ class includesBehavior: current ] whileFalse: [ current := current superclass ] ]. ^ current! ! !NECContext methodsFor: 'private-roel-typer'! 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-temporaries'! 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: 'private-temporaries'! convertBlocksToVariables: anOrderedCollection | result blockStack | blockStack := anOrderedCollection. result := OrderedCollection new. blockStack do: [ :each | result addAll: each ]. ^ result! ! !NECContext methodsFor: 'private-temporaries'! 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-type-guessing'! guessArgument: aSHRange | name | name := self sourceOf: aSHRange. (name = 'html' and: [ (Smalltalk at: #WARenderCanvas ifAbsent: [ ]) notNil ]) ifTrue: [ ^ Smalltalk at: #WARenderCanvas ]. ^ NECInstVarTypeGuesser getClassFromTypeSuggestingName: name! ! !NECContext methodsFor: 'private-type-guessing'! 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 methodsFor: 'private-type-guessing' stamp: 'EstebanLorenzano 4/23/2012 13:13'! 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: [ ^range asType ]. 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 class instanceVariableNames: ''! !NECContext class methodsFor: 'instance creation'! controller: aECController class: aClass source: aString position: anInteger ^ self basicNew initialize setController: aECController class: aClass source: aString position: anInteger! ! TestCase subclass: #NECContextTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NECompletion-Tests'! !NECContextTest methodsFor: 'tests'! 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'! 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'! 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'! testCompletionTokenEmpty | text context | text := 'testIt: aRectangle | abc | test. abc daf '. context := self createContextFor: text at: text size. self assert: context completionToken = ''! ! !NECContextTest methodsFor: 'tests'! 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: 'tests'! testEmpty self createContextFor: '' at: 0! ! !NECContextTest methodsFor: 'tests'! testInTheMiddelOfAWord | text context | text := 'hagada'. context := self createContextFor: text at: 4. self assert: context completionToken = 'haga'! ! !NECContextTest methodsFor: 'tests'! 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'! 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'! testReceiverClassVar | text context | text := 'testIt ClassVar '. context := self createContextFor: text at: text size. self assert: context receiverClass == ByteString! ! !NECContextTest methodsFor: 'tests'! testReceiverConstant | text context | text := 'testIt 15r16 printS'. context := self createContextFor: text at: text size. self assert: context receiverClass == Number. text := 'testIt ''test'' printS'. context := self createContextFor: text at: text size. self assert: context receiverClass == String. 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. ! ! !NECContextTest methodsFor: 'tests'! testReceiverGlobal | text context | text := 'testIt Dictionary n'. context := self createContextFor: text at: text size. self assert: context receiverClass == Dictionary class. ! ! !NECContextTest methodsFor: 'tests'! testReceiverGlobalVarNew | text context | text := 'testIt Dictionary new a'. context := self createContextFor: text at: text size. self assert: context receiverClass == Dictionary. ! ! !NECContextTest methodsFor: 'tests'! testReceiverTempVar | text context | text := 'testIt | aha | aha _ ''test''. aha p'. context := self createContextFor: text at: text size. self assert: context receiverClass == String. 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 = Number. text := 'testIt | aha bili | aha _ constantString. bili _ 15. bili _ aha. bili p'. context := self createContextFor: text at: text size. self assert: context receiverClass == Number. text := 'testIt [ :each | |a| a _ 16. a print'. context := self createContextFor: text at: text size. self assert: context receiverClass == Number. 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! ! !NECContextTest methodsFor: 'tests'! 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: 'tests'! 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'! 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'! 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! ! !NECContextTest methodsFor: 'tests'! 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: '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: 'private'! createContextFor: aString at: anInteger ^ NECContext controller: NECController new class: NECTestClass source: aString position: anInteger! ! Object subclass: #NECController instanceVariableNames: 'model menuMorph editor context inverseMapping completionDelay' classVariableNames: '' poolDictionaries: '' category: 'NECompletion-View'! !NECController commentStamp: '' prior: 0! 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: '*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: 'accessing'! additionals ^ nil! ! !NECController methodsFor: 'accessing'! context ^context! ! !NECController methodsFor: 'accessing'! editor ^ editor! ! !NECController methodsFor: 'accessing'! model ^model! ! !NECController methodsFor: 'accessing'! workspace ^nil! ! !NECController methodsFor: 'initialize-release'! setModel: aStringHolder model := aStringHolder! ! !NECController methodsFor: 'keyboard' stamp: 'EstebanLorenzano 2/1/2013 19:04'! 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 model isEmpty ifTrue: [ ^self closeMenu ]! ! !NECController methodsFor: 'keyboard' stamp: 'EstebanLorenzano 2/1/2013 17:21'! 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 isSpaceKey | self flag: #fixme. "this method should be split up". self setEditor: anEditor. self setModel: editor model. keyCharacter := aKeyboardEvent keyCharacter. controlKeyPressed := aKeyboardEvent controlKeyPressed. isSpaceKey := keyCharacter = Character null or: [ keyCharacter = Character space ]. 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: [ (NECPreferences useEnterToAccept not and: [ menuMorph insertSelected ]) ifTrue: [^ true]] ifTrue: [ menuMorph insertCommonPrefix 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 not ifTrue: [ self closeMenu]. ^ false]. (controlKeyPressed not & aKeyboardEvent commandKeyPressed not and: [aKeyboardEvent keyCharacter isCompletionCharacter ]) ifFalse: [ self closeMenu. ^ keyCharacter = Character escape]. ^ false.! ! !NECController methodsFor: 'keyboard' stamp: 'EstebanLorenzano 2/25/2013 13:30'! handleKeystrokeWithoutMenu: aKeyboardEvent | isSpaceKey | self editor atCompletionPosition ifFalse: [ ^ (self smartInputWithEvent: aKeyboardEvent ) notNil ]. isSpaceKey := #(0 32) includes: aKeyboardEvent keyValue. 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'! invalidateEditorMorph editor morph invalidRect: editor morph bounds. ! ! !NECController methodsFor: 'keyboard' stamp: 'CamilloBruni 8/26/2012 17:51'! leftArrow (menuMorph hideDetail) ifFalse: [ self closeMenu. ^ false ]. ^ true! ! !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: '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: '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 methodsFor: 'menu morph' stamp: 'CamilloBruni 10/21/2012 14:54'! closeMenu self stopCompletionDelay. menuMorph ifNotNil: [ menuMorph delete ]. menuMorph := nil.! ! !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'! isMenuOpen ^menuMorph notNil! ! !NECController methodsFor: 'menu morph' stamp: 'EstebanLorenzano 2/1/2013 18:42'! menuClosed NECSymbols resetCachedSymbols. menuMorph := nil. context := nil.! ! !NECController methodsFor: 'menu morph' stamp: 'EstebanLorenzano 2/1/2013 15:51'! openMenu ^ self openMenuFor: editor.! ! !NECController methodsFor: 'menu morph' stamp: 'EstebanLorenzano 2/1/2013 19:01'! 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: 'settings'! smartCharacters ^ NECPreferences smartCharacters ! ! !NECController methodsFor: 'settings'! smartCharactersMapping ^ NECPreferences smartCharactersMapping ! ! !NECController methodsFor: 'settings'! smartInverseMapping ^ inverseMapping ifNil: [ inverseMapping := Dictionary new. self smartCharactersMapping keysAndValuesDo: [ :key :value | inverseMapping at: value put: key ]. inverseMapping ]! ! !NECController methodsFor: 'testing' stamp: 'CamilloBruni 8/26/2012 23:11'! captureNavigationKeys ^ NECPreferences captureNavigationKeys! ! !NECController methodsFor: 'type guessing' stamp: 'CamilloBruni 8/5/2012 23:39'! guessTypeFor: aString ^ model isNil ifFalse: [ model guessTypeForName: aString ]! ! !NECController methodsFor: 'private' stamp: 'EstebanLorenzano 4/11/2012 16:40'! contextClass ^NECContext! ! !NECController methodsFor: 'private' stamp: 'EstebanLorenzano 4/11/2012 16:49'! menuMorphClass ^ NECMenuMorph! ! !NECController methodsFor: 'private' stamp: 'EstebanLorenzano 2/1/2013 15:56'! 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. WorldState addDeferredUIMessage: [ editor atCompletionPosition ifTrue: [ self openMenu ]] ] fork. ! ! !NECController methodsFor: 'private' stamp: 'MarianoMartinezPeck 11/2/2012 11:41'! setEditor: anObject editor := anObject. editor morph onAnnouncement: MorphLostFocus do: [self closeMenu ].! ! !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: '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: '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: 'private' stamp: 'CamilloBruni 8/6/2012 00:26'! stopCompletionDelay completionDelay ifNotNil: [ completionDelay terminate ].! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NECController class instanceVariableNames: 'uniqueInstance'! !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: 'class initialization' stamp: 'EstebanLorenzano 4/12/2012 13:43'! initialize self register! ! !NECController class methodsFor: 'instance creation' stamp: 'EstebanLorenzano 4/11/2012 15:08'! reset uniqueInstance := nil ! ! !NECController class methodsFor: 'instance creation' stamp: 'EstebanLorenzano 4/11/2012 11:26'! uniqueInstance ^uniqueInstance ifNil: [ uniqueInstance := self basicNew initialize ]! ! !NECController class methodsFor: 'testing' stamp: 'EstebanLorenzano 4/12/2012 13:24'! allowModel: aModel ^NECPreferences enabled and: [ aModel isCodeCompletionAllowed ]! ! !NECController class methodsFor: 'tools registry' stamp: 'EstebanLorenzano 4/12/2012 13:44'! register self registerToolsOn: Smalltalk tools.! ! !NECController class methodsFor: 'tools registry' stamp: 'EstebanLorenzano 4/11/2012 10:47'! registerToolsOn: registry "self registerToolsOn: Smalltalk tools" registry register: self as: #codeCompletion ! ! TestCase subclass: #NECControllerTest instanceVariableNames: 'controller' classVariableNames: '' poolDictionaries: '' category: 'NECompletion-View-Tests'! !NECControllerTest commentStamp: '' prior: 0! A NECControllerTest is a test class for testing the behavior of NECController! !NECControllerTest methodsFor: 'initialize' stamp: 'EstebanLorenzano 2/25/2013 14:30'! setUp "Setting up code for NECControllerTest" controller := NECController new.! ! !NECControllerTest methodsFor: 'initialize' stamp: 'EstebanLorenzano 2/25/2013 14:30'! tearDown "Tearing down code for NECControllerTest" controller := nil.! ! !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).! ! Morph subclass: #NECDetailMorph instanceVariableNames: 'title description arrowPosition label' classVariableNames: '' poolDictionaries: '' category: 'NECompletion-View'! !NECDetailMorph commentStamp: '' prior: 0! 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'! descriptionBounds ^ self contentBounds top: self contentBounds top + 30! ! !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: 'accessing' 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: 'accessing'! titleBounds ^ self contentBounds top: self contentBounds top + 10! ! !NECDetailMorph methodsFor: 'drawing'! bounds ^ super bounds topLeft extent: self class width @ self class height! ! !NECDetailMorph methodsFor: 'drawing'! 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: 'drawing'! defaultColor ^ NECMenuMorph backgroundColor. ! ! !NECDetailMorph methodsFor: 'drawing'! 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: '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: 'CamilloBruni 8/4/2012 01:49'! drawOn: aCanvas super drawOn: aCanvas. arrowPosition ifNotNil: [ self drawArrowOn: aCanvas. self drawMessageOn: aCanvas]! ! !NECDetailMorph methodsFor: 'drawing'! itemHeight ^ NECMenuMorph itemHeight! ! !NECDetailMorph methodsFor: 'drawing'! messageFont ^ NECMenuMorph messageFont! ! !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: 'drawing'! scrollColor ^ NECMenuMorph scrollColor! ! !NECDetailMorph methodsFor: 'private'! positionOnLeft: anInteger ^ arrowPosition x - self class width - anInteger ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NECDetailMorph class instanceVariableNames: ''! !NECDetailMorph class methodsFor: 'private'! height ^ NECMenuMorph itemHeight * 15.5! ! !NECDetailMorph class methodsFor: 'private'! width ^ NECMenuMorph itemWidth * 2.0! ! Object subclass: #NECEntry instanceVariableNames: 'contents type description' classVariableNames: '' poolDictionaries: '' category: 'NECompletion-Model'! !NECEntry commentStamp: 'bar 10/5/2005 23:31' prior: 0! I represent a completion entry that is management by a ECModel and shown in the ECMenuMorph as a menu entry.! !NECEntry methodsFor: 'accessing'! completion ^ self contents asSymbol! ! !NECEntry methodsFor: 'accessing'! contents ^contents! ! !NECEntry methodsFor: 'accessing'! contentsAsSymbol ^ contents asSymbol ! ! !NECEntry methodsFor: 'accessing'! label ^ 'unknown'! ! !NECEntry methodsFor: 'accessing'! setContents: aString type: aSymbol contents := aString. type := aSymbol! ! !NECEntry methodsFor: 'accessing'! type ^type! ! !NECEntry methodsFor: 'conversion' stamp: 'CamilloBruni 8/4/2012 02:07'! asNECEntry ^ self! ! !NECEntry methodsFor: 'detail information'! 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: 'operations'! <= aECEntry ^ contents <= aECEntry contents! ! !NECEntry methodsFor: 'operations' stamp: 'MarcusDenker 7/12/2012 18:01'! browseWith: anECContext type := self guessTypeWith: anECContext. type ifNil: [^ false]. SystemNavigation new browseClass: type. ^ true! ! !NECEntry methodsFor: 'operations'! descriptionWith: anECContext description ifNotNil: [ ^ description ]. ^ description := self createDescriptionWith: anECContext! ! !NECEntry methodsFor: 'operations'! guessTypeWith: anECContext ^ nil! ! !NECEntry methodsFor: 'printing' stamp: 'CamilloBruni 8/3/2012 18:54'! printOn: aStream aStream nextPutAll: self class name; nextPut: $(; nextPutAll: contents asString; nextPut: $,; nextPutAll: type; nextPut: $)! ! !NECEntry methodsFor: 'testing'! isInstance ^ false! ! !NECEntry methodsFor: 'testing'! isLocal ^ false! ! !NECEntry methodsFor: 'testing'! isSelector ^ false! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NECEntry class instanceVariableNames: ''! !NECEntry class methodsFor: 'instance creation'! contents: aString type: aSymbol ^ self new setContents: aString type: aSymbol! ! Object subclass: #NECEntryDescription instanceVariableNames: 'title description label' classVariableNames: '' poolDictionaries: '' category: 'NECompletion-Model'! !NECEntryDescription commentStamp: '' prior: 0! A NECEntryDescription is a holder for some information to be displayed.! !NECEntryDescription methodsFor: 'accessing'! description ( description isNil or:[description isEmpty]) ifTrue:[^'-']. ^ description! ! !NECEntryDescription methodsFor: 'accessing'! label ^ label! ! !NECEntryDescription methodsFor: 'accessing'! title ^ title! ! !NECEntryDescription methodsFor: 'initialize-release'! setLabel: firstString title: secondString description: thirdString label := firstString. title := secondString. description := thirdString! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NECEntryDescription class instanceVariableNames: ''! !NECEntryDescription class methodsFor: 'instance creation'! label: firstString ^ self new setLabel: firstString title: '(unknown)' description: nil! ! !NECEntryDescription class methodsFor: 'instance creation'! label: firstString title: secondString description: thirdString ^ self new setLabel: firstString title: secondString description: thirdString! ! TestCase subclass: #NECEntryTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NECompletion-Tests'! !NECEntryTest methodsFor: 'tests'! testCompletion | entry | entry := NECSelectorEntry contents: 'makeItHappen' type: #unary:. self assert: entry completion = #makeItHappen! ! !NECEntryTest methodsFor: 'tests'! testInstance | entry | entry := NECInstVarEntry contents: 'abc' type: #instVar:. self assert: entry isInstance! ! !NECEntryTest methodsFor: 'tests'! 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'! testPrintOn | entry | entry := NECSelectorEntry contents: 'compute' type: #unary:. self assert: 'NECSelectorEntry(compute,unary:)' = entry printString! ! NECEntry subclass: #NECGlobalEntry instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NECompletion-Model'! !NECGlobalEntry commentStamp: '' prior: 0! I represent a global variable.! !NECGlobalEntry methodsFor: 'accessing'! label ^ 'global'! ! !NECGlobalEntry methodsFor: 'operations'! guessTypeWith: anECContext | globalEntry | globalEntry := Smalltalk at: contents ifAbsent: [^ nil]. globalEntry isBehavior ifTrue: [^ globalEntry]. globalEntry ifNotNil: [^ globalEntry class]. ^ nil! ! NECEntry subclass: #NECInstVarEntry instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NECompletion-Model'! !NECInstVarEntry commentStamp: '' prior: 0! I represent an instance variable.! !NECInstVarEntry methodsFor: 'accessing'! label ^ 'instance variable'! ! !NECInstVarEntry methodsFor: 'operations'! guessTypeWith: anECContext ^ anECContext guessInstVarClass: contents! ! !NECInstVarEntry methodsFor: 'testing'! isInstance ^true! ! NECVarTypeGuesser subclass: #NECInstVarTypeGuesser instanceVariableNames: 'varIndex' classVariableNames: '' poolDictionaries: '' category: 'NECompletion-Model'! !NECInstVarTypeGuesser commentStamp: '' prior: 0! I'm a simple InstructionClient that tries to guess the type of a given instance variable name of a class. ! !NECInstVarTypeGuesser methodsFor: 'bytecode decoding'! popIntoReceiverVariable: offset varIndex = offset ifTrue: [ found := true ] ifFalse: [ self reset ]! ! !NECInstVarTypeGuesser methodsFor: 'bytecode decoding'! prepare: aCompiledMethod | theClass | super prepare: aCompiledMethod. theClass := aCompiledMethod realClass. varIndex := (theClass allInstVarNames indexOf: variableName) - 1! ! !NECInstVarTypeGuesser methodsFor: 'public'! methodRefs | theClass selectors | theClass := receiverClass classThatDefinesInstanceVariable: variableName. theClass ifNil: [ ^ nil ]. selectors := theClass whichSelectorsStoreInto: variableName. ^ selectors collect: [ :each | RGMethodDefinition realClass: theClass selector: each]! ! TestCase subclass: #NECInstVarTypeGuesserTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NECompletion-Tests'! !NECInstVarTypeGuesserTest methodsFor: 'testing'! testComplexInit self guessVariable: 'complexInit' in: NECTestClass expected: nil! ! !NECInstVarTypeGuesserTest methodsFor: 'testing'! testComplexInit2 self guessVariable: 'complexInit2' in: NECTestClass expected: Dictionary! ! !NECInstVarTypeGuesserTest methodsFor: 'testing'! testConstantArray self guessVariable: 'constantArray' in: NECTestClass expected: Array! ! !NECInstVarTypeGuesserTest methodsFor: 'testing'! testConstantBoolean self guessVariable: 'constantBoolean' in: NECTestClass expected: True! ! !NECInstVarTypeGuesserTest methodsFor: 'testing'! testConstantInteger self guessVariable: 'constantInteger' in: NECTestClass expected: SmallInteger! ! !NECInstVarTypeGuesserTest methodsFor: 'testing'! testConstantIntegerNil self guessVariable: 'constantNil' in: NECTestClass expected: nil! ! !NECInstVarTypeGuesserTest methodsFor: 'testing'! testConstantString self guessVariable: 'constantString' in: NECTestClass expected: ByteString! ! !NECInstVarTypeGuesserTest methodsFor: 'testing'! testConstantSymbol self guessVariable: 'constantSymbol' in: NECTestClass expected: ByteSymbol! ! !NECInstVarTypeGuesserTest methodsFor: 'testing'! testGlobalVarKeyword self guessVariable: 'globalVarKeyword' in: NECTestClass expected: SortedCollection! ! !NECInstVarTypeGuesserTest methodsFor: 'testing'! testGlobalVarKeyword2 self guessVariable: 'globalVarKeyword2' in: NECTestClass expected: SortedCollection! ! !NECInstVarTypeGuesserTest methodsFor: 'testing'! testMessageSend self guessVariable: 'messageSend' in: NECTestClass expected: Dictionary! ! !NECInstVarTypeGuesserTest methodsFor: 'testing'! testMessageSend2 self guessVariable: 'messageSend2' in: NECTestClass expected: nil! ! !NECInstVarTypeGuesserTest methodsFor: 'testing'! testSuperWithAnotherInit self guessVariable: 'superInstVar' in: NECTestClass expected: Dictionary! ! !NECInstVarTypeGuesserTest methodsFor: 'testing'! testTypeSuggestingParameter self guessVariable: 'typeSuggestingParameter2' in: NECTestClass expected: Rectangle! ! !NECInstVarTypeGuesserTest methodsFor: 'private'! guessVariable: aString in: aClass expected: theClassExpected | typeGuesser result | typeGuesser := NECInstVarTypeGuesser variableName: aString class: aClass. result := typeGuesser perform. self assert: result == theClassExpected! ! NECEntry subclass: #NECLocalEntry instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NECompletion-Model'! !NECLocalEntry commentStamp: '' prior: 0! I represent a local variable! !NECLocalEntry methodsFor: 'accessing'! label ^ 'local variable'! ! !NECLocalEntry methodsFor: 'operations'! guessTypeWith: anECContext ^ (anECContext guessTempVarClass: contents type: type) ifNil: [anECContext guessArgument: contents]! ! !NECLocalEntry methodsFor: 'testing'! isLocal ^true! ! Morph subclass: #NECMenuMorph instanceVariableNames: 'selected firstVisible titleStringMorph controller context pageHeight detailMorph detailPosition' classVariableNames: '' poolDictionaries: '' category: 'NECompletion-View'! !NECMenuMorph commentStamp: '' prior: 0! 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: 'accessing'! detailPosition: aPoint detailPosition := aPoint. self triggerEvent: #positionChanged! ! !NECMenuMorph methodsFor: 'accessing'! 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: 'accessing'! selected "Answer the value of selected" selected ifNil: [ selected := self firstVisible ]. ^ selected! ! !NECMenuMorph methodsFor: 'accessing'! 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: 'accessing'! selectedEntry ^ context model entries at: self selected! ! !NECMenuMorph methodsFor: 'actions' stamp: 'CamilloBruni 10/20/2012 14:43'! browse (self selectedEntry browseWith: context) ifTrue: [ controller closeMenu ]! ! !NECMenuMorph methodsFor: 'actions' stamp: 'CamilloBruni 8/26/2012 15:33'! close self delete.! ! !NECMenuMorph methodsFor: 'actions'! end self gotoPage: self pageCount. self changed.! ! !NECMenuMorph methodsFor: 'actions'! expand context model toggleExpand. self narrowCompletion! ! !NECMenuMorph methodsFor: 'actions' stamp: 'EstebanLorenzano 2/1/2013 17:16'! help self class helpText asMorph openInWindowLabeled: self class helpTitle! ! !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'! home self gotoPage: 1. self changed! ! !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: '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: 'CamilloBruni 8/26/2012 23:37'! insertSelected context model isEmpty ifTrue: [^ false]. self insertCompletion: (context model completionAt: self selected). self delete. ^ true! ! !NECMenuMorph methodsFor: 'actions'! moveDown self selected: self selected + 1. (self selected > self lastVisible and: [self selected <= self itemsCount]) ifTrue: [firstVisible := firstVisible + 1]. self changed! ! !NECMenuMorph methodsFor: 'actions'! 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: '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'! pageDown self gotoPage: self currentPage + 1. self changed. ! ! !NECMenuMorph methodsFor: 'actions'! pageUp self gotoPage: self currentPage - 1. self changed. ! ! !NECMenuMorph methodsFor: 'actions' stamp: 'CamilloBruni 8/30/2012 14:46'! show self resize. self activeHand newMouseFocus: self. self changed.! ! !NECMenuMorph methodsFor: 'actions'! showDetail detailMorph ifNotNil: [ ^ self browse ]. self itemsCount isZero ifTrue: [ ^ self ]. detailMorph := NECDetailMorph new. self addMorph: detailMorph. self updateDetail! ! !NECMenuMorph methodsFor: 'actions' stamp: 'CamilloBruni 8/7/2012 12:17'! switchToUntyped context switchToUntyped. self removeTitle; narrowCompletion! ! !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: '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 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: '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: '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: '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: '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: 'drawing'! hasMessage ^ true ! ! !NECMenuMorph methodsFor: 'drawing'! prepareRectForNextRow: aRectangle ^aRectangle translateBy: 0 @ self class itemHeight! ! !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: 'drawing'! selectColor: type ^ self class selectColorFor: type! ! !NECMenuMorph methodsFor: 'drawing'! selectFont: aSymbol ^ self class selectFontFor: aSymbol! ! !NECMenuMorph methodsFor: 'event handling' stamp: 'CamilloBruni 8/30/2012 16:55'! handlesMouseDown: anEvent ^ true! ! !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: '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: '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: '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: 'initialization' stamp: 'CamilloBruni 8/6/2012 12:58'! setController: aECController position: aPoint controller := aECController. context := controller context. self position: aPoint - (20 @ 0). self narrowCompletion ifTrue: [ self createTitle. self openInWorld]. ! ! !NECMenuMorph methodsFor: 'paging'! currentPage ^(self selected - 1 // self pageHeight ) + 1.! ! !NECMenuMorph methodsFor: 'paging'! 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: 'paging'! 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: 'paging'! pageCountString ^ self itemsCount = 501 ifTrue: [ 'more' ] ifFalse: [ self pageCount asString ]! ! !NECMenuMorph methodsFor: 'paging'! pageHeight ^pageHeight.! ! !NECMenuMorph methodsFor: 'testing' stamp: 'CamilloBruni 8/26/2012 15:29'! takesKeyboardFocus ^ true! ! !NECMenuMorph methodsFor: 'title'! removeTitle titleStringMorph ifNil: [^ self]. self removeMorph: titleStringMorph owner. titleStringMorph := nil! ! !NECMenuMorph methodsFor: 'private'! delete super delete. controller menuClosed! ! !NECMenuMorph methodsFor: 'private'! firstVisible ^firstVisible min: context model entryCount! ! !NECMenuMorph methodsFor: 'private'! isClosed ^ owner isNil! ! !NECMenuMorph methodsFor: 'private'! itemsCount ^context model entryCount! ! !NECMenuMorph methodsFor: 'private'! lastVisible ^ (self firstVisible + self height-1) min: (self itemsCount).! ! !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: 'private'! visibleItemsCount. ^ self lastVisible - self firstVisible + 1! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NECMenuMorph class instanceVariableNames: ''! !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'! 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:16'! helpTitle ^ 'Completion Keyboard Help'! ! !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'! sectionAttributes ^ {TextEmphasis bold}! ! !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: 'help text' stamp: 'EstebanLorenzano 2/1/2013 17:15'! shortcutAttributes ^ {TextIndent spaceUsed; tabs: 1. TextEmphasis italic }! ! !NECMenuMorph class methodsFor: 'instance creation'! controller: aECController position: aPoint | newObject | newObject := self new. newObject setController: aECController position: aPoint. ^ newObject! ! !NECMenuMorph class methodsFor: 'preferences'! convertToSHSymbol: aSymbol ^ (SHTextStylerST80 new attributesFor: aSymbol) notNil ifTrue: [ aSymbol ] ifFalse: [ #default ]! ! !NECMenuMorph class methodsFor: 'preferences'! itemHeight ^ (self selectFontFor: #default) height + 2! ! !NECMenuMorph class methodsFor: 'preferences' stamp: 'CamilloBruni 8/5/2012 23:13'! itemWidth ^ 250! ! !NECMenuMorph class methodsFor: 'preferences'! maxLength ^ 20! ! !NECMenuMorph class methodsFor: 'preferences'! scrollArrowSize ^ 8! ! !NECMenuMorph class methodsFor: 'preferences'! selectColorFor: aSymbol | attribute | attribute := self convertToSHSymbol: aSymbol. ^ (SHTextStylerST80 new attributesFor: attribute) first color! ! !NECMenuMorph class methodsFor: 'preferences-colors' stamp: 'CamilloBruni 8/3/2012 21:20'! backgroundColor ^NECPreferences backgroundColor! ! !NECMenuMorph class methodsFor: 'preferences-colors' stamp: 'CamilloBruni 8/3/2012 20:31'! scrollColor ^ UITheme current settings selectionColor! ! !NECMenuMorph class methodsFor: 'preferences-fonts' stamp: 'CamilloBruni 8/6/2012 00:33'! messageFont ^ StandardFonts menuFont! ! !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-fonts'! titleFont ^ StandardFonts windowTitleFont! ! Object subclass: #NECModel instanceVariableNames: 'clazz selectors narrowString entries' classVariableNames: '' poolDictionaries: '' category: 'NECompletion-Model'! !NECModel commentStamp: '' prior: 0! I'm an abstract class that stores the entries to be completed.! !NECModel methodsFor: 'accessing'! at: aNumber ^ entries at: aNumber ! ! !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'! entries ^entries! ! !NECModel methodsFor: 'accessing'! entriesOfType: aSymbol | collection | collection := entries select: [ :each | each type == aSymbol ]. ^ collection collect: [ :each | each contents ]! ! !NECModel methodsFor: 'accessing'! entryCount ^entries size! ! !NECModel methodsFor: 'accessing'! hasMessage ^ self message notNil! ! !NECModel methodsFor: 'accessing'! initializeSelectors self subclassResponsibility ! ! !NECModel methodsFor: 'accessing' stamp: 'EstebanLorenzano 2/1/2013 18:22'! message ^self isEmpty ifTrue: ['no completions found'] ifFalse: [nil]! ! !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: 'action'! narrowWith: aString self subclassResponsibility ! ! !NECModel methodsFor: 'action'! theClass ^nil! ! !NECModel methodsFor: 'action'! title ^nil! ! !NECModel methodsFor: 'initialize-release'! initialize self reset! ! !NECModel methodsFor: 'initialize-release'! setClass: aClass clazz := aClass. self initializeSelectors. self narrowWith: String new! ! !NECModel methodsFor: 'initialize-release'! toggleExpand ! ! !NECModel methodsFor: 'testing'! isEmpty ^ entries isEmpty! ! !NECModel methodsFor: 'testing'! notEmpty ^self isEmpty not! ! !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: 'private'! narrowString: aString narrowString := aString! ! !NECModel methodsFor: 'private'! reset self resetSelectors. self resetEntries. narrowString := String new! ! !NECModel methodsFor: 'private'! resetEntries entries := OrderedCollection new! ! !NECModel methodsFor: 'private'! 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 class instanceVariableNames: ''! !NECModel class methodsFor: 'instance creation'! class: aClass | newInstance | newInstance := self basicNew initialize. newInstance setClass: aClass. ^ newInstance! ! NECTypedModel subclass: #NECOverrideModel instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NECompletion-Model'! !NECOverrideModel commentStamp: '' prior: 0! 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: '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: 'action'! title ^ '(override) ' , clazz superclass name! ! !NECOverrideModel methodsFor: 'initialize-release' stamp: 'MartinDias 2/11/2013 14:46'! initializeSelectors clazz superclass ifNotNil: [ self initializeSelectorsFor: clazz superclass]. clazz methodDictionary keysDo: [ :each | | entry | entry := selectors detect: [ :ea | ea contentsAsSymbol == each ] ifNone: [ ]. entry notNil ifTrue: [ selectors remove: entry ifAbsent: [ ] ] ]! ! !NECOverrideModel methodsFor: 'private'! methodAt: aNumber ^ clazz lookupSelector: (self at: aNumber) contentsAsSymbol! ! TestCase subclass: #NECOverrideModelTest instanceVariableNames: 'model' classVariableNames: '' poolDictionaries: '' category: 'NECompletion-Tests'! !NECOverrideModelTest methodsFor: 'testing'! setUp model := NECOverrideModel class: NECTestClass. model toggleExpand! ! !NECOverrideModelTest methodsFor: 'testing'! testCompletionAt | completion | completion := model completionAt: 2. self assert: completion = 'toBeOverriden: anArgument super toBeOverriden: anArgument'! ! !NECOverrideModelTest methodsFor: 'testing'! testCompletionAtWithReturn | completion | completion := model completionAt: 3. self assert: completion = 'toBeOverridenWithReturn ^ super toBeOverridenWithReturn'! ! !NECOverrideModelTest methodsFor: 'testing'! testExpand | size | size := model entries size. self assert: size == model entries size! ! !NECOverrideModelTest methodsFor: 'testing'! 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)! ! !NECOverrideModelTest methodsFor: 'testing'! testTitle self assert: '(override) NECTestSuperClass' = model title! ! Object subclass: #NECPreferences instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NECompletion-Pharo'! !NECPreferences commentStamp: '' prior: 0! 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 instanceVariableNames: 'enabled caseSensitive smartCharacters smartCharactersMapping backgroundColor expandPrefixes captureNavigationKeys useEnterToAccept popupShowAutomatic popupAutomaticDelay popupShowWithShortcut spaceAfterCompletion smartCharactersWithSingleSpace smartCharactersWithDoubleSpace'! !NECPreferences class methodsFor: 'accessing' stamp: 'EstebanLorenzano 2/1/2013 17:23'! availablePopupShortcuts ^ { Character space shift. Character tab asShortcut}! ! !NECPreferences class methodsFor: 'accessing' stamp: 'EstebanLorenzano 4/12/2012 13:38'! backgroundColor ^backgroundColor ifNil: [ backgroundColor := (UITheme current settings menuColor ifNil: [ Color white ]) ]! ! !NECPreferences class methodsFor: 'accessing' stamp: 'EstebanLorenzano 4/12/2012 13:36'! backgroundColor: aColor backgroundColor := aColor! ! !NECPreferences class methodsFor: 'accessing' stamp: 'CamilloBruni 8/26/2012 23:10'! captureNavigationKeys ^ captureNavigationKeys! ! !NECPreferences class methodsFor: 'accessing' stamp: 'CamilloBruni 8/26/2012 23:10'! captureNavigationKeys: aBoolean captureNavigationKeys := aBoolean! ! !NECPreferences class methodsFor: 'accessing'! caseSensitive ^ caseSensitive ! ! !NECPreferences class methodsFor: 'accessing'! caseSensitive: aBoolean caseSensitive := aBoolean! ! !NECPreferences class methodsFor: 'accessing'! enabled ^ enabled ! ! !NECPreferences class methodsFor: 'accessing' stamp: 'EstebanLorenzano 4/12/2012 13:11'! enabled: aBoolean enabled := aBoolean.! ! !NECPreferences class methodsFor: 'accessing' stamp: 'CamilloBruni 8/3/2012 23:56'! expandPrefixes ^ expandPrefixes! ! !NECPreferences class methodsFor: 'accessing' stamp: 'CamilloBruni 8/3/2012 23:56'! expandPrefixes: aBoolean expandPrefixes := aBoolean! ! !NECPreferences class methodsFor: 'accessing' stamp: 'EstebanLorenzano 2/1/2013 16:40'! popupAutomaticDelay ^popupAutomaticDelay ifNil: [ popupAutomaticDelay := self defaultPopupDelay ] ! ! !NECPreferences class methodsFor: 'accessing' stamp: 'EstebanLorenzano 2/1/2013 15:39'! popupAutomaticDelay: anObject popupAutomaticDelay := anObject! ! !NECPreferences class methodsFor: 'accessing' stamp: 'EstebanLorenzano 2/1/2013 16:40'! popupShowAutomatic ^ popupShowAutomatic ifNil: [ popupShowAutomatic := self defaultPopupShowAutomatic ]! ! !NECPreferences class methodsFor: 'accessing' stamp: 'EstebanLorenzano 2/1/2013 15:37'! popupShowAutomatic: aBoolean popupShowAutomatic := aBoolean! ! !NECPreferences class methodsFor: 'accessing' stamp: 'EstebanLorenzano 2/1/2013 16:40'! popupShowWithShortcut ^ popupShowWithShortcut ifNil: [ popupShowWithShortcut := self defaultPopupShortcut ]! ! !NECPreferences class methodsFor: 'accessing' stamp: 'EstebanLorenzano 2/1/2013 15:39'! popupShowWithShortcut: anObject popupShowWithShortcut := anObject! ! !NECPreferences class methodsFor: 'accessing'! smartCharacters ^ smartCharacters! ! !NECPreferences class methodsFor: 'accessing'! smartCharacters: aBoolean smartCharacters := aBoolean! ! !NECPreferences class methodsFor: 'accessing'! smartCharactersMapping ^ smartCharactersMapping! ! !NECPreferences class methodsFor: 'accessing'! smartCharactersMapping: aDictionary smartCharactersMapping := aDictionary! ! !NECPreferences class methodsFor: 'accessing' stamp: 'CamilloBruni 1/15/2013 15:46'! smartCharactersWithDoubleSpace ^ smartCharactersWithDoubleSpace! ! !NECPreferences class methodsFor: 'accessing' stamp: 'CamilloBruni 1/15/2013 15:46'! smartCharactersWithDoubleSpace: aString smartCharactersWithDoubleSpace := aString! ! !NECPreferences class methodsFor: 'accessing' stamp: 'CamilloBruni 1/15/2013 15:45'! smartCharactersWithSingleSpace ^ smartCharactersWithSingleSpace! ! !NECPreferences class methodsFor: 'accessing' stamp: 'CamilloBruni 1/15/2013 15:46'! smartCharactersWithSingleSpace: aString smartCharactersWithSingleSpace := aString! ! !NECPreferences class methodsFor: 'accessing' stamp: 'EstebanLorenzano 2/1/2013 15:54'! spaceAfterCompletion ^ spaceAfterCompletion ifNil: [ spaceAfterCompletion := true ]! ! !NECPreferences class methodsFor: 'accessing' stamp: 'EstebanLorenzano 2/1/2013 15:39'! spaceAfterCompletion: anObject spaceAfterCompletion := anObject! ! !NECPreferences class methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/9/2013 17:51'! useEnterToAccept ^ useEnterToAccept ifNil: [ useEnterToAccept := self defaultUseEnterToAccept ]! ! !NECPreferences class methodsFor: 'accessing' stamp: 'CamilloBruni 8/26/2012 23:28'! useEnterToAccept: aBoolean useEnterToAccept := aBoolean! ! !NECPreferences class methodsFor: 'defaults' stamp: 'BenjaminVanRyseghem 2/9/2013 17:52'! defaultUseEnterToAccept ^ false! ! !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: '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: 'settings' stamp: 'EstebanLorenzano 2/1/2013 16:36'! defaultPopupShowAutomatic ^true! ! !NECPreferences class methodsFor: 'settings' stamp: 'EstebanLorenzano 2/1/2013 16:37'! defaultSpaceAfterCompletion ^true! ! !NECPreferences class methodsFor: 'settings' stamp: 'EstebanLorenzano 2/25/2013 15:48'! settingsOn: aBuilder (aBuilder setting: #'Code Completion') target: self; parentName: #codeBrowsing; selector: #enabled; icon: UITheme current 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 13:04'! availableControllers ^NECController withAllSubclasses copyWithout: NECWorkspaceController! ! !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: 'private' stamp: 'EstebanLorenzano 4/12/2012 11:24'! useController: aClass aClass registerToolsOn: Smalltalk tools! ! Object subclass: #NECReadMe instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NECompletion-Model'! !NECReadMe commentStamp: '' prior: 0! 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.! NECEntry subclass: #NECSelectorEntry instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NECompletion-Model'! !NECSelectorEntry commentStamp: '' prior: 0! I represent a selector! !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: '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: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'! 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 methodSymbol class: ref realClass] ifFalse: [^ notfoundBlock value: contents]] ifNotNil: [self lookupSelector: contents class: theClass]. ^ foundBlock value: result first value: result second! ! !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! ! !NECSelectorEntry methodsFor: 'private'! 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: '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! ! NECEntry subclass: #NECSelfEntry instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NECompletion-Model'! !NECSelfEntry commentStamp: '' prior: 0! I represent self! !NECSelfEntry methodsFor: 'accessing'! label ^ 'self'! ! !NECSelfEntry methodsFor: 'operations'! guessTypeWith: anECContext ^ anECContext theClass! ! TestCase subclass: #NECStringSortingTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NECompletion-Tests'! !NECStringSortingTest methodsFor: 'tests'! testCaseSensitiveMap | map colon o | map := String classPool at: #CaseSensitiveOrder. colon := map at: $: asciiValue + 1. o := map at: $O asciiValue + 1. self assert: colon > o! ! !NECStringSortingTest methodsFor: 'tests'! testCompare self assert: ('at:' compare: 'atOne' caseSensitive: false) == 1! ! !NECStringSortingTest methodsFor: 'tests'! testCompareWithCase self assert: ('at:' compare: 'atOne' caseSensitive: true) == 3! ! NECEntry subclass: #NECSuperEntry instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NECompletion-Model'! !NECSuperEntry commentStamp: '' prior: 0! I represent super.! !NECSuperEntry methodsFor: 'accessing'! label ^ 'super'! ! !NECSuperEntry methodsFor: 'operations'! guessTypeWith: anECContext ^ anECContext theClass ifNotNil: [anECContext theClass superclass]! ! Object subclass: #NECSymbols instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NECompletion-Pharo'! !NECSymbols commentStamp: '' prior: 0! 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 instanceVariableNames: 'cachedSymbols'! !NECSymbols class methodsFor: 'accessing' stamp: 'EstebanLorenzano 2/1/2013 18:31'! cachedSymbols ^cachedSymbols! ! !NECSymbols class methodsFor: 'accessing' stamp: 'EstebanLorenzano 2/1/2013 18:31'! resetCachedSymbols cachedSymbols := nil! ! !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: 'query'! 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 ] ]! ! !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: 'private' stamp: 'EstebanLorenzano 2/1/2013 18:37'! cachedInterestingSymbolsDo: aBlock self cachedSymbols do: aBlock! ! !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 ]]]].! ! NECTestSuperClass subclass: #NECTestClass instanceVariableNames: 'third fourth typeSuggestingParameter messageSend messageSend2 typeSuggestingParameter2 complexInit complexInit2 constantInteger constantSymbol constantArray constantBoolean constantString constantNil globalVarKeyword globalVarKeyword2' classVariableNames: 'ClassVar' poolDictionaries: '' category: 'NECompletion-Tests'! !NECTestClass commentStamp: '' prior: 0! I'm only for SUnit TestCases.! !NECTestClass methodsFor: 'tests'! testIt: anArgument | loc1 x2 t | x2 := [:bar :var | var < bar]. loc1 := constantArray. x2 value: loc1. t := 15. ^ x2! ! !NECTestClass methodsFor: 'utils'! initialize: aRectangle constantInteger := 15. 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 methodsFor: 'utils'! lowPriorityOverrides: aRectangle messageSend := aRectangle. typeSuggestingParameter2 := aRectangle. ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NECTestClass class instanceVariableNames: ''! !NECTestClass class methodsFor: 'as yet unclassified'! initialize super initialize. ClassVar := 'Any string'! ! Object subclass: #NECTestSuperClass instanceVariableNames: 'superInstVar' classVariableNames: 'SuperClassVar' poolDictionaries: '' category: 'NECompletion-Tests'! !NECTestSuperClass commentStamp: '' prior: 0! I'm only for SUnit TestCases.! !NECTestSuperClass methodsFor: 'initialize-release'! initialize superInstVar := Dictionary new! ! !NECTestSuperClass methodsFor: 'tests'! testIt: aString self subclassResponsibility ! ! !NECTestSuperClass methodsFor: 'utils'! toBeOverriden: anArgument 15 > 16 ifTrue: [self sample * anArgument ]! ! !NECTestSuperClass methodsFor: 'utils'! toBeOverridenWithReturn ^ 'saga'! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NECTestSuperClass class instanceVariableNames: ''! !NECTestSuperClass class methodsFor: 'as yet unclassified'! initialize SuperClassVar := Dictionary new! ! Object subclass: #NECTypeInfo instanceVariableNames: 'type kind temporaryOffset' classVariableNames: '' poolDictionaries: '' category: 'NECompletion-Model'! !NECTypeInfo commentStamp: '' prior: 0! I'm used in ECInstVarTypeGuesser to store found type informations.! !NECTypeInfo methodsFor: 'accessing'! priority ^kind! ! !NECTypeInfo methodsFor: 'accessing'! setType: aClass kind: anInteger type := aClass. kind := anInteger! ! !NECTypeInfo methodsFor: 'accessing'! temporaryOffset ^temporaryOffset! ! !NECTypeInfo methodsFor: 'accessing'! temporaryOffset: anInteger temporaryOffset := anInteger! ! !NECTypeInfo methodsFor: 'accessing'! type ^type! ! !NECTypeInfo methodsFor: 'accessing'! type: aClass type := aClass! ! !NECTypeInfo methodsFor: 'testing'! isDefinedByMessageSend ^kind == 2! ! !NECTypeInfo methodsFor: 'testing'! isDefinedByTemporary ^ kind == 3! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NECTypeInfo class instanceVariableNames: ''! !NECTypeInfo class methodsFor: 'instance creation'! definedByLiteral: aClass | newInstance | newInstance := self new. newInstance setType: aClass kind: 1. ^ newInstance! ! !NECTypeInfo class methodsFor: 'instance creation'! definedByMessageSend: aClass | newInstance | newInstance := self new. newInstance setType: aClass kind: 2. ^ newInstance! ! !NECTypeInfo class methodsFor: 'instance creation'! definedByTemporaryVar: anInteger | newInstance | newInstance := self new. newInstance setType: nil kind: 3. newInstance temporaryOffset: anInteger. ^ newInstance! ! NECModel subclass: #NECTypedModel instanceVariableNames: 'expanded' classVariableNames: '' poolDictionaries: '' category: 'NECompletion-Model'! !NECTypedModel commentStamp: '' prior: 0! 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: 'action'! narrowWith: aString self narrowString: aString ; initializeSelectors. entries reset. self addToEntries: selectors! ! !NECTypedModel methodsFor: 'action'! theClass ^clazz! ! !NECTypedModel methodsFor: 'action'! title ^clazz name! ! !NECTypedModel methodsFor: 'action'! toggleExpand expanded := expanded not. self initializeSelectors. self narrowWith: narrowString! ! !NECTypedModel methodsFor: 'initialize-release'! initialize super initialize. expanded := true! ! !NECTypedModel methodsFor: 'private'! initializeSelectors self initializeSelectorsFor: clazz! ! !NECTypedModel methodsFor: 'private'! initializeSelectorsFor: aClass |excludedClasses| selectors reset. excludedClasses := (expanded ifTrue: [#()] ifFalse: [Object withAllSuperclasses]). selectors addAll: ((aClass allSelectorsWithout: excludedClasses) collect: [:each | NECSelectorEntry contents: each type: #selector])! ! TestCase subclass: #NECTypedModelTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NECompletion-Tests'! !NECTypedModelTest methodsFor: 'tests'! 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'! testMessage | model | model := NECTypedModel class: NECTestClass. self shouldnt: model hasMessage. model narrowWith: 'hagadagadu'. self assert: model hasMessage. self assert: model message = 'no completions found'! ! !NECTypedModelTest methodsFor: 'tests'! testTitle | model | model := NECTypedModel class: NECTestClass. self assert: #NECTestClass = model title! ! !NECTypedModelTest methodsFor: 'tests'! 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:)! ! NECUntypedModel subclass: #NECUnseparatedModel instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NECompletion-Model'! !NECUnseparatedModel commentStamp: '' prior: 0! kind of variant but no idea why - sd! !NECUnseparatedModel methodsFor: 'action'! completionAt: aNumber ^ (self at: aNumber) completion! ! NECModel subclass: #NECUntypedModel instanceVariableNames: 'instVars localVars includeVariables includeSelectors classVars listLimit' classVariableNames: '' poolDictionaries: '' category: 'NECompletion-Model'! !NECUntypedModel commentStamp: '' prior: 0! 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 ^ listLimit! ! !NECUntypedModel methodsFor: 'accessing' stamp: 'CamilloBruni 2/3/2013 21:39'! listLimit: aNumber listLimit := aNumber! ! !NECUntypedModel methodsFor: 'accessing'! message ^ (includeSelectors and: [ narrowString isEmpty ]) ifTrue: [ selectors size = 500 ifTrue: [ 'more...' ] ifFalse: [ 'press key for selectors' ] ] ifFalse: [ super message ]! ! !NECUntypedModel methodsFor: 'action'! narrowWith: aString self narrowString: aString. self resetEntries. self addVariables. self addSelectors! ! !NECUntypedModel methodsFor: 'initialize-release' 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'! initializeClassVars (clazz isNil or: [ includeVariables not ]) ifTrue: [ ^ self ]. classVars := clazz theNonMetaClass allClassVarNames asSortedCollection. classVars := classVars collect: [ :each | NECClassVarEntry contents: each type: #classVar ]! ! !NECUntypedModel methodsFor: 'initialize-release'! initializeInstVars (clazz isNil or: [ includeVariables not ]) ifTrue: [ ^ self ]. instVars := clazz allInstVarNames asSortedCollection. instVars := instVars collect: [ :each | NECInstVarEntry contents: each type: #instVar ]. instVars add: (NECSelfEntry contents: 'self' type: #self). instVars add: (NECSuperEntry contents: 'super' type: #super)! ! !NECUntypedModel methodsFor: 'initialize-release'! narrowString: aString (narrowString isEmpty or: [aString isEmpty or: [aString first ~= narrowString first]]) ifTrue: [self reset]. super narrowString: aString! ! !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'! 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: 'private'! addSelectors self initializeSelectors. self addToEntries: selectors! ! !NECUntypedModel methodsFor: 'private'! addVariables includeVariables ifFalse: [^ self]. self addToEntries: localVars. self addToEntries: instVars. self addToEntries: classVars! ! !NECUntypedModel methodsFor: 'private' stamp: 'CamilloBruni 2/3/2013 21:39'! initializeSelectors self resetSelectors. includeSelectors ifFalse: [ Smalltalk keysAndValuesDo: [ :each :class | selectors add: (NECGlobalEntry contents: each type: #globalVar) ]. ^ 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: 'CamilloBruni 8/21/2012 16:29'! loadEntries self addVariables; addSelectors! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NECUntypedModel class instanceVariableNames: ''! !NECUntypedModel class methodsFor: 'instance creation'! class: aClass temporaries: aCollection ^self class: aClass temporaries: aCollection additionals: #() variables: true selectors: true! ! !NECUntypedModel class methodsFor: 'instance creation'! 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! ! TestCase subclass: #NECUntypedModelTest instanceVariableNames: 'prefValueCase' classVariableNames: '' poolDictionaries: '' category: 'NECompletion-Tests'! !NECUntypedModelTest methodsFor: 'tests'! setUp prefValueCase := NECPreferences caseSensitive. NECPreferences caseSensitive: true! ! !NECUntypedModelTest methodsFor: 'tests'! tearDown NECPreferences caseSensitive: prefValueCase! ! !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'! testCaseSensitive | model locals | self assert: NECPreferences caseSensitive. model := NECUntypedModel class: NECTestClass temporaries: OrderedCollection new. model loadEntries. locals := model entriesOfType: #instVar. self assert: locals size == 17. 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: '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'! testEmpty | model | model := NECUntypedModel new. self assert: model isEmpty. self assert: model entries isEmpty. self assert: model entryCount == 0! ! !NECUntypedModelTest methodsFor: 'tests' stamp: 'CamilloBruni 8/21/2012 16:29'! testForClassInstVars | model locals | model := NECUntypedModel class: NECTestClass temporaries: OrderedCollection new. model loadEntries. locals := model entriesOfType: #instVar. self assert: locals size == 17. 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: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: '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')! ! !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'! 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'! testTitle | model | model := NECUntypedModel class: NECTestClass temporaries: #(). self assert: model title isNil! ! InstructionClient subclass: #NECVarTypeGuesser instanceVariableNames: 'types receiverClass variableName found currentMethod hasSend contextCount' classVariableNames: '' poolDictionaries: '' category: 'NECompletion-Model'! !NECVarTypeGuesser commentStamp: '' prior: 0! I'm an InstructionClient that tries to guess the type of a given instance variable name of a class. ! !NECVarTypeGuesser methodsFor: 'bytecode decoding'! blockReturnTop contextCount := contextCount - 1! ! !NECVarTypeGuesser methodsFor: 'bytecode decoding' stamp: 'MarcusDenker 4/27/2012 13:13'! computeVarType | info tempNames name | types ifEmpty: [ ^ nil ]. info := types first. (hasSend and: [ info isDefinedByMessageSend not ]) ifTrue: [ info type: nil. ^ info ]. info isDefinedByTemporary not ifTrue: [ ^ info ]. tempNames := (receiverClass compilerClass new parse: currentMethod sourceCode in: receiverClass notifying: nil) tempNames. name := tempNames at: info temporaryOffset + 1. info type: (self class getClassFromTypeSuggestingName: name). ^ info! ! !NECVarTypeGuesser methodsFor: 'bytecode decoding'! interpretNextInstructionUsing: aScanner found := false. aScanner interpretNextInstructionFor: self. ^found ! ! !NECVarTypeGuesser methodsFor: 'bytecode decoding'! popIntoLiteralVariable: anAssociation "Remove Top Of Stack And Store Into Literal Variable bytecode." self reset! ! !NECVarTypeGuesser methodsFor: 'bytecode decoding'! popIntoTemporaryVariable: offset "Remove Top Of Stack And Store Into Temporary Variable bytecode." self reset ! ! !NECVarTypeGuesser methodsFor: 'bytecode decoding'! prepare: aCompiledMethod ! ! !NECVarTypeGuesser methodsFor: 'bytecode decoding'! pushActiveContext "Push Active Context On Top Of Its Own Stack bytecode." contextCount := contextCount + 1! ! !NECVarTypeGuesser methodsFor: 'bytecode decoding'! 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'! 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'! 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'! 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'! 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: 'instance creation'! initialize super initialize. types := OrderedCollection new. hasSend := false. contextCount := 0! ! !NECVarTypeGuesser methodsFor: 'instance creation'! setVariableName: aString source: aSourceString class: aClass variableName := aString. receiverClass := aClass! ! !NECVarTypeGuesser methodsFor: 'public'! methodRefs ^ #()! ! !NECVarTypeGuesser methodsFor: 'public'! 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: 'private'! reset contextCount > 0 ifTrue:[^self]. types reset. hasSend := false.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NECVarTypeGuesser class instanceVariableNames: ''! !NECVarTypeGuesser class methodsFor: 'instance creation'! variableName: aString class: aClass ^self variableName: aString source: nil class: aClass ! ! !NECVarTypeGuesser class methodsFor: 'instance creation'! variableName: aString source: sourceString class: aClass | newInstance | newInstance := self basicNew initialize. newInstance setVariableName: aString source: sourceString class: aClass. ^ newInstance! ! !NECVarTypeGuesser class methodsFor: 'private'! 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! ! NECController subclass: #NECWorkspaceController instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NECompletion-View'! !NECWorkspaceController commentStamp: '' prior: 0! I'm a specialized controller, that works with Workspaces.! !NECWorkspaceController methodsFor: 'accessing'! additionals ^ self workspace completionAdditionals! ! !NECWorkspaceController methodsFor: 'accessing'! workspace ^model! ! Object subclass: #NOCCompletionTable instanceVariableNames: 'table numberofEntries' classVariableNames: '' poolDictionaries: '' category: 'NOCompletion-Model'! !NOCCompletionTable commentStamp: '' prior: 0! 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: 'rr 4/17/2009 14:14'! entriesMatching: prefix | list | list := self listForPrefix: prefix. ^ list entriesMatching: prefix! ! !NOCCompletionTable methodsFor: 'accessing' stamp: 'rr 4/9/2009 17:42'! entriesPerPrefix: n numberofEntries := n! ! !NOCCompletionTable methodsFor: 'accessing' stamp: 'rr 4/10/2009 12:11'! fillRate ^ self totalNumberOfEntries / self maxNumberOfEntries ! ! !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: '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:10'! maxNumberOfEntries ^ 26 * 26 * numberofEntries ! ! !NOCCompletionTable methodsFor: 'accessing' stamp: 'rr 4/9/2009 17:46'! numberOfEntries ^ numberofEntries! ! !NOCCompletionTable methodsFor: 'accessing' stamp: 'rr 4/10/2009 11:21'! reset table := Dictionary new.! ! !NOCCompletionTable methodsFor: 'accessing' stamp: 'rr 4/9/2009 17:49'! totalNumberOfEntries ^ table inject: 0 into: [:total :list | total + list numEntries]! ! !NOCCompletionTable methodsFor: 'initialization' stamp: 'rr 4/9/2009 17:45'! initialize table := Dictionary new.! ! !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/15/2009 10:52'! addEntry: aString date: d | lists | lists := self listsForPrefix: aString. lists do: [:e | e addEntry: aString date: d] ! ! !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/16/2009 12:01'! justCompiled: selector in: class | date | date := DateAndTime now. self compiled: selector in: class date: date! ! !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: '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: 'rr 5/28/2009 14:10'! quickFillWithClass: cls cls methodsDo: [:e | self justCompiled: e selector in: cls] ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NOCCompletionTable class instanceVariableNames: 'classTable table'! !NOCCompletionTable class methodsFor: 'accessing' stamp: 'CamilloBruni 8/4/2012 01:05'! classes ^ classTable ifNil: [classTable := self new entriesPerPrefix: 40]! ! !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: 'cleanup' stamp: 'MarcusDenker 11/14/2012 13:37'! cleanUp 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: 'rr 4/14/2009 17:13'! default ^ table ifNil: [table := self new entriesPerPrefix: 40]! ! !NOCCompletionTable class methodsFor: 'instance creation' stamp: 'MarcusDenker 11/14/2012 13:33'! reset classTable := nil. table := nil.! ! !NOCCompletionTable class methodsFor: 'system startup' stamp: 'MarcusDenker 11/14/2012 13:39'! shutDown self reset! ! NECContext subclass: #NOCContext instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NOCompletion-Model'! !NOCContext commentStamp: '' prior: 0! 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! ! NECController subclass: #NOCController instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NOCompletion-Model'! !NOCController commentStamp: '' prior: 0! 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: 'EstebanLorenzano 4/12/2012 11:17'! contextClass ^NOCContext! ! !NOCController methodsFor: 'private' stamp: 'CamilloBruni 8/5/2012 23:16'! menuMorphClass ^ NOCMenuMorph! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NOCController class instanceVariableNames: ''! !NOCController class methodsFor: 'class initialization' stamp: 'EstebanLorenzano 2/1/2013 18:12'! initialize self register.! ! NECSelectorEntry subclass: #NOCDatedEntry instanceVariableNames: 'date next previous' classVariableNames: '' poolDictionaries: '' category: 'NOCompletion-Model'! !NOCDatedEntry commentStamp: '' prior: 0! 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: 'rr 2/21/2009 11:49'! date ^ date! ! !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:38'! matches: pref ^contents beginsWithEmpty: pref caseSensitive: false! ! !NOCDatedEntry methodsFor: 'accessing' stamp: 'ul 9/27/2010 05:07'! next ^next! ! !NOCDatedEntry methodsFor: 'accessing' stamp: 'ul 9/27/2010 05:08'! next: anODatedEntry next := anODatedEntry! ! !NOCDatedEntry methodsFor: 'accessing' stamp: 'rr 4/9/2009 15:32'! now date := DateAndTime now! ! !NOCDatedEntry methodsFor: 'accessing' stamp: 'ul 9/27/2010 05:07'! previous ^previous! ! !NOCDatedEntry methodsFor: 'accessing' stamp: 'ul 9/27/2010 05:08'! previous: anODatedEntry previous := anODatedEntry! ! !NOCDatedEntry methodsFor: 'accessing' stamp: 'ul 9/27/2010 05:08'! unlink next previous: previous. previous next: next! ! !NOCDatedEntry methodsFor: 'operations' stamp: 'rr 2/21/2009 11:49'! <= anEntry ^ date = anEntry date ifTrue: [contents <= anEntry contents] ifFalse: [date > anEntry date]! ! Object subclass: #NOCEmptyModel instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NOCompletion-Model'! !NOCEmptyModel commentStamp: '' prior: 0! 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/14/2009 16:47'! entries ^ Array new! ! !NOCEmptyModel methodsFor: 'accessing' stamp: 'rr 4/17/2009 14:27'! entryCount ^ 0! ! !NOCEmptyModel methodsFor: 'accessing' stamp: 'rr 4/17/2009 14:26'! narrowString: string! ! !NOCEmptyModel methodsFor: 'accessing' stamp: 'rr 4/17/2009 14:26'! narrowWith: string ! ! Object subclass: #NOCEntryList instanceVariableNames: 'size entries entryHead' classVariableNames: '' poolDictionaries: '' category: 'NOCompletion-Model'! !NOCEntryList commentStamp: '' prior: 0! 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/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 methodsFor: 'accessing' stamp: 'rr 4/9/2009 16:14'! first ^self firstEntry contents! ! !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: 'ul 9/27/2010 05:31'! lastEntry ^ entryHead next! ! !NOCEntryList methodsFor: 'accessing' stamp: 'rr 2/21/2009 11:46'! numEntries ^ entries size! ! !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: 'adding' stamp: 'rr 4/9/2009 16:06'! addEntry: aSymbol self addEntry: aSymbol date: DateAndTime now! ! !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 class instanceVariableNames: ''! !NOCEntryList class methodsFor: 'instance creation' stamp: 'rr 2/21/2009 11:44'! ofSize: n ^ self new setSize: n; yourself! ! NECMenuMorph subclass: #NOCMenuMorph instanceVariableNames: 'lastActivity' classVariableNames: '' poolDictionaries: '' category: 'NOCompletion-View'! !NOCMenuMorph commentStamp: '' prior: 0! 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! ! NECUntypedModel subclass: #NOCModel instanceVariableNames: 'table expand context nextModel cachedEntries classTable' classVariableNames: '' poolDictionaries: '' category: 'NOCompletion-Model'! !NOCModel commentStamp: '' prior: 0! I keep the state of the ocompletion algorithm. See comments of my parents for details. ! !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: 'damiencassou 7/27/2009 14:22'! at: aNumber ^ self entries at: (aNumber max: 1) ! ! !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: '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: 'accessing' stamp: 'CamilloBruni 8/5/2012 23:35'! entries | ent more | entries ifEmpty: [ self loadEntries ]. ^ entries! ! !NOCModel methodsFor: 'accessing' stamp: 'RomainRobbes 8/2/2010 17:56'! entryCount ^ self entries size! ! !NOCModel methodsFor: 'accessing' stamp: 'rr 4/15/2009 13:28'! expand expand := true.! ! !NOCModel methodsFor: 'accessing' stamp: 'CamilloBruni 8/4/2012 00:52'! narrowWith: aString self narrowString: aString. self loadEntries. self nextModel ifNotNilDo: [: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: 'accessing' stamp: 'EstebanLorenzano 4/12/2012 11:20'! noNextModel nextModel := NOCEmptyModel new.! ! !NOCModel methodsFor: 'accessing' stamp: 'rr 4/14/2009 13:46'! table ^ table! ! !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: 'CamilloBruni 8/6/2012 00:01'! title ^ self nextModel title! ! !NOCModel methodsFor: 'accessing' stamp: 'EstebanLorenzano 4/12/2012 11:17'! useUniqueTable table := NOCCompletionTable new entriesPerPrefix: 20. ! ! !NOCModel methodsFor: 'initialize-release' stamp: 'CamilloBruni 8/3/2012 21:26'! initialize super initialize. self contract. table := NOCCompletionTable default. classTable := NOCCompletionTable classes.! ! !NOCModel methodsFor: 'initialize-release' stamp: 'rr 4/14/2009 13:56'! initializeSelectors! ! !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 ]! ! !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: 'private' stamp: 'CamilloBruni 8/7/2012 11:51'! loadNextModelEntries entries := self nextModel entries ! ! !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].! ! ArithmeticError subclass: #NaNException instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Exceptions'! !NaNException commentStamp: 'SvenVanCaekenberghe 4/15/2011 16:41' prior: 0! I am NaNException, an ArithmeticException signaled when Float nan was encountered where it was not allowed. ! NetworkError subclass: #NameLookupFailure instanceVariableNames: 'hostName' classVariableNames: '' poolDictionaries: '' category: 'Network-Kernel'! !NameLookupFailure commentStamp: 'mir 5/12/2003 18:16' prior: 0! Signals that a name lookup operation failed. hostName hostName for which the name loopup failed ! !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 methodsFor: 'accessing' stamp: 'len 12/14/2002 11:57'! hostName: aString hostName := aString! ! !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 19:59'! standardMessageText "Generate a standard textual description" ^ String streamContents: [ :stream | stream << 'cannot resolve '. stream print: self hostName ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NameLookupFailure class instanceVariableNames: ''! !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! ! UpdatingStringMorph subclass: #NameStringInHalo instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Widgets'! !NameStringInHalo commentStamp: 'kfr 10/27/2003 16:29' prior: 0! Shows the name of the morph in the halo. ! !NameStringInHalo methodsFor: 'accessing' stamp: 'sw 9/17/1999 13:17'! interimContents: aString self contents: aString. self placeContents! ! !NameStringInHalo methodsFor: 'as yet unclassified' stamp: 'di 11/25/1999 23:40'! placeContents | namePosition | (owner notNil and: [owner isInWorld]) ifTrue: [namePosition := owner basicBox bottomCenter - ((self width // 2) @ (owner handleSize negated // 2 - 1)). namePosition := namePosition min: self world viewBox bottomRight - self extent y + 2. self bounds: (namePosition extent: self extent)]! ! !NameStringInHalo methodsFor: 'drawing' stamp: 'sw 9/7/1999 21:27'! drawOn: aCanvas aCanvas fillRectangle: self bounds color: Color white. super drawOn: aCanvas.! ! !NameStringInHalo methodsFor: 'editing' stamp: 'sw 9/17/1999 13:41'! cancelEdits self interimContents: target externalName. super cancelEdits! ! Object subclass: #NativeBoost instanceVariableNames: 'bootstrapping insideCallback callbackCounterAddr extraRootsRegistry rootsCell gateFunction' classVariableNames: 'Current NBAnnouncer' poolDictionaries: 'AJx86Registers NativeBoostConstants' category: 'NativeBoost-Core'! !NativeBoost commentStamp: '' prior: 0! 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: '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: '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/5/2010 16:47'! newAssembler self subclassResponsibility ! ! !NativeBoost methodsFor: 'as yet unclassified' stamp: 'Igor.Stasenko 5/2/2010 13:52'! pointerSize self subclassResponsibility ! ! !NativeBoost methodsFor: 'as yet unclassified' 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: '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 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: '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: '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: '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: 'Igor.Stasenko 9/26/2010 04:37'! callbackCounterAddress ^ callbackCounterAddr! ! !NativeBoost methodsFor: 'callback support' stamp: 'cipt 11/3/2012 18:28'! insideCallback bootstrapping ifTrue: [ ^ false ]. ^ (callbackCounterAddr nbInt32AtOffset: 0) ~= 0! ! !NativeBoost methodsFor: 'initialize-release' stamp: 'cipt 11/3/2012 18:28'! 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. "notify any observers about session change" self class announcer announce: NBSessionChangeAnnouncement ! ! !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: '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 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 5/3/2010 11:03'! allocationFailed self error: 'Memory allocation failed'! ! !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: '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: '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: '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: '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: '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: 'retrieving symbols' stamp: 'Igor.Stasenko 5/2/2010 16:35'! 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 firstIndexableField: 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: '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: '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: 'retrieving symbols' stamp: 'IgorStasenko 11/18/2012 17:05'! 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 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 ofLength: aSymbolName size fromModule: module into: bytes. handle := bytes unsignedLongAt: 1 bigEndian: false. handle = 0 ifTrue: [ ^ nil ]. ^ NBExternalAddress value: handle ! ! !NativeBoost methodsFor: 'testing' stamp: 'Igor.Stasenko 9/25/2010 07:32'! isBootstrapping ^ bootstrapping! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NativeBoost class instanceVariableNames: ''! !NativeBoost class methodsFor: 'accessing' stamp: 'IgorStasenko 3/28/2012 17:44'! announcer ^ NBAnnouncer ifNil: [ NBAnnouncer := Announcer new ].! ! !NativeBoost class methodsFor: 'accessing' stamp: 'Igor.Stasenko 5/2/2010 19:10'! callgateFunctionAddress ^ self forCurrentPlatform callgateFunctionAddress! ! !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: '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: '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: 'class initialization' stamp: 'IgorStasenko 3/19/2012 12:43'! initialize "self initialize" self registerPrimitiveSimulators! ! !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: 'debugger support' stamp: 'IgorStasenko 3/19/2012 12:42'! registerPrimitiveSimulators ContextPart simulatePrimitive: #primitiveNativeCall module: #NativeBoostPlugin with: self! ! !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: 'debugger support' stamp: 'IgorStasenko 3/19/2012 13:38'! 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 := Compiler new 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 8/6/2011 17:42'! lastError ^ self error: 'NativeBoost plugin is not installed?'! ! !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: '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: '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: 'memory access' stamp: 'Igor.Stasenko 5/3/2010 10:27'! ulongAt: ulongAddr ^ self forCurrentPlatform ulongAt: ulongAddr! ! !NativeBoost class methodsFor: 'platform id' stamp: 'Igor.Stasenko 5/2/2010 11:07'! platformId " do not fail, answer nil instead" ^ nil! ! !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: '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: '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: 'retrieving symbols' stamp: 'CamilloBruni 7/19/2012 11:50'! loadFunction: fnName ^ self loadFunction: fnName from: ''! ! !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: 'retrieving symbols' stamp: 'CamilloBruni 7/19/2012 11:51'! loadSymbol: aSymbolName ^ self loadSymbol: aSymbolName fromModule: ''! ! !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: '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: 'system startup' stamp: 'IgorStasenko 5/11/2011 00:55'! 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 isNil ifTrue: [ self unsupportedPlatform ]. ^ Current ! ! !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: 'testing' stamp: 'Igor.Stasenko 9/26/2010 06:28'! insideCallback ^ self forCurrentPlatform insideCallback! ! !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: 'testing' stamp: 'IgorStasenko 5/28/2012 03:49'! isEnabledOrNil "Answer flag indicating whether running a native code enabled by plugin" ^ nil! ! !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: '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: 'private' stamp: 'IgorStasenko 5/11/2011 00:48'! resetInstance "!!!!!!!! Never use it !!!!!!!! It is here only for development purposes" Current := nil.! ! SharedPool subclass: #NativeBoostConstants instanceVariableNames: '' classVariableNames: 'ErrInvalidPlatformId ErrInvalidPrimitiveVoltageUse ErrNoNBPrimitive ErrNoNativeCodeInMethod ErrNotEnabled ErrRunningViaInterpreter Linux32PlatformId Mac32PlatformId NBErrorBase NBErrorDescriptions NBPrimErrBadArgument NBPrimErrBadIndex NBPrimErrBadMethod NBPrimErrBadNumArgs NBPrimErrBadReceiver NBPrimErrGenericFailure NBPrimErrInappropriate NBPrimErrLimitExceeded NBPrimErrNamedInternal NBPrimErrNoCMemory NBPrimErrNoMemory NBPrimErrNoModification NBPrimErrNotFound NBPrimErrObjectMayMove NBPrimErrUnsupported NBPrimNoErr Win32PlatformId' poolDictionaries: '' category: 'NativeBoost-Pools'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NativeBoostConstants class instanceVariableNames: ''! !NativeBoostConstants class methodsFor: 'as yet unclassified' stamp: 'Igor.Stasenko 4/9/2010 11:00'! currentPlatformId self primitiveFailed! ! !NativeBoostConstants class methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'Igor.Stasenko 4/14/2010 15:03'! linux32PlatformId ^ Linux32PlatformId! ! !NativeBoostConstants class methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 9/10/2012 12:07'! mac32PlatformId ^ Mac32PlatformId! ! !NativeBoostConstants class methodsFor: 'as yet unclassified' stamp: 'Igor.Stasenko 4/9/2010 11:03'! win32PlatformId ^ Win32PlatformId! ! !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.! ! !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.! ! NativeBoost subclass: #NativeBoostLinux32 instanceVariableNames: 'heap' classVariableNames: '' poolDictionaries: 'NBUnixConstants' category: 'NativeBoost-Unix'! !NativeBoostLinux32 methodsFor: 'accessing' stamp: 'IgorStasenko 8/5/2011 08:48'! newAssembler ^ AJx86Assembler new.! ! !NativeBoostLinux32 methodsFor: 'accessing' stamp: 'Igor.Stasenko 9/22/2010 03:25'! pointerSize ^ 4! ! !NativeBoostLinux32 methodsFor: 'accessing' stamp: 'IgorStasenko 8/3/2011 08:08'! stackAlignment ^ 1! ! !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: 'bootstrapping' stamp: 'Igor.Stasenko 9/26/2010 03:50'! initializeExternalHeap "initialize external memory heap" heap := NBUnixExternalHeapManager new. ! ! !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: '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: 'primitives' stamp: 'Igor.Stasenko 9/25/2010 06:31'! primitiveDlopen "retrieve a pointer to dlopen(...) function" ^ self primitiveFailed! ! !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: '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: '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/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: '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 class instanceVariableNames: ''! !NativeBoostLinux32 class methodsFor: 'platform id' stamp: 'Igor.Stasenko 9/22/2010 03:12'! targetPlatformId ^ Linux32PlatformId ! ! NativeBoostLinux32 subclass: #NativeBoostMac32 instanceVariableNames: '' classVariableNames: '' poolDictionaries: 'NBMacConstants' category: 'NativeBoost-Mac'! !NativeBoostMac32 methodsFor: 'assembler' stamp: 'IgorStasenko 8/5/2011 08:48'! newAssembler ^ AJx86Assembler 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: 'bootstrapping' stamp: 'Igor.Stasenko 12/5/2010 18:32'! initializeExternalHeap "initialize external memory heap" heap := NBMacExternalHeapManager new. ! ! !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: 'platform-specific' stamp: 'IgorStasenko 8/2/2011 06:33'! stackAlignment ^ 16! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NativeBoostMac32 class instanceVariableNames: ''! !NativeBoostMac32 class methodsFor: 'as yet unclassified' stamp: 'Igor.Stasenko 12/4/2010 22:21'! targetPlatformId ^ Mac32PlatformId ! ! NativeBoost subclass: #NativeBoostWin32 instanceVariableNames: 'heapHandle' classVariableNames: '' poolDictionaries: 'NBWinConstants NBWinTypes' category: 'NativeBoost-Win32'! !NativeBoostWin32 methodsFor: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'IgorStasenko 8/5/2011 08:48'! newAssembler ^ AJx86Assembler new.! ! !NativeBoostWin32 methodsFor: 'as yet unclassified' stamp: 'Igor.Stasenko 5/3/2010 10:44'! pointerSize ^ 4! ! !NativeBoostWin32 methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'IgorStasenko 8/3/2011 08:08'! stackAlignment ^ 1! ! !NativeBoostWin32 methodsFor: 'retrieving symbols' stamp: 'IgorStasenko 2/8/2013 12:56'! VMModule ^ self class getVMModuleHandle handle! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NativeBoostWin32 class instanceVariableNames: ''! !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: '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: '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: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'IgorStasenko 11/24/2012 16:18'! loadLibrary: libName ^ self nbCallout stdcall function: #( long LoadLibraryA ( String libName )) module: #Kernel32 ! ! !NativeBoostWin32 class methodsFor: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'tbn 11/11/2012 00:47'! squeakWindowHandle "This is slow, but efficient" ^(self loadFunction: 'stWindow' from: '') nbUInt32AtOffset: 0 ! ! !NativeBoostWin32 class methodsFor: 'platform id' stamp: 'Igor.Stasenko 4/29/2010 04:31'! targetPlatformId ^ Win32PlatformId! ! Object subclass: #NaturalLanguageFormTranslator instanceVariableNames: 'id generics' classVariableNames: 'CachedTranslations' poolDictionaries: '' category: 'System-Localization'! !NaturalLanguageFormTranslator commentStamp: 'LaurentLaffont 3/4/2011 22:44' prior: 0! Provides support for looking up Forms by name for presentation in the UI. Different forms can be registered for a name for different locales allowing images presented in the UI to be localised. Typically used where images contain language dependent text. E.g. buttonForm := (NaturalLanguageFormTranslator localeID: Locale current localeID) translate: 'submit button' Form translations are added like so: (NaturalLanguageFormTranslator isoLanguage: 'en' isoCountry: 'gb') name: 'submit button' form: aForm! !NaturalLanguageFormTranslator methodsFor: 'accessing' stamp: 'yo 1/13/2005 11:15'! generics ^generics ifNil: [generics := Dictionary new]! ! !NaturalLanguageFormTranslator methodsFor: 'accessing' stamp: 'yo 1/13/2005 11:27'! localeID ^id! ! !NaturalLanguageFormTranslator methodsFor: 'accessing' stamp: 'yo 1/13/2005 11:26'! localeID: anID id := anID! ! !NaturalLanguageFormTranslator methodsFor: 'accessing' stamp: 'yo 1/13/2005 11:17'! name: formName form: translatedForm self generics at: formName put: translatedForm. ! ! !NaturalLanguageFormTranslator methodsFor: 'utilities' stamp: 'yo 1/13/2005 11:35'! translate: aString ^ (self generics at: aString ifAbsent: [nil]) deepCopy. "Do you like to write 'form ifNotNil: [form deepCopy]'?" ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NaturalLanguageFormTranslator class instanceVariableNames: ''! !NaturalLanguageFormTranslator class methodsFor: 'accessing' stamp: 'yo 1/13/2005 11:13'! cachedTranslations "CachedTranslations := nil" ^CachedTranslations ifNil: [CachedTranslations := Dictionary new]! ! !NaturalLanguageFormTranslator class methodsFor: 'accessing' stamp: 'yo 1/13/2005 11:13'! isoLanguage: isoLanguage "Return the generic language translator as there is no information about the country code" ^self isoLanguage: isoLanguage isoCountry: nil! ! !NaturalLanguageFormTranslator class methodsFor: 'accessing' stamp: 'yo 1/13/2005 11:13'! isoLanguage: isoLanguage isoCountry: isoCountry ^self localeID: (LocaleID isoLanguage: isoLanguage isoCountry: isoCountry)! ! !NaturalLanguageFormTranslator class methodsFor: 'accessing' stamp: 'yo 1/13/2005 11:13'! localeID: localeID ^ self cachedTranslations at: localeID ifAbsentPut: [self new localeID: localeID]! ! !NaturalLanguageFormTranslator class methodsFor: 'cleanup' stamp: 'StephaneDucasse 3/9/2010 22:11'! cleanUp "Flush caches" CachedTranslations := nil! ! Object subclass: #NaturalLanguageTranslator instanceVariableNames: '' classVariableNames: 'AllKnownPhrases' poolDictionaries: '' category: 'System-Localization'! !NaturalLanguageTranslator commentStamp: 'HilaireFernandes 5/13/2010 11:48' prior: 0! A NaturalLanguageTranslator is a dummy translator. The localization framework is found in the gettext package. ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NaturalLanguageTranslator class instanceVariableNames: ''! !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 ^ aString! ! !NaturalLanguageTranslator class methodsFor: 'translate' stamp: 'HilaireFernandes 5/13/2010 11:43'! translate: aString toLocale: localeID ^ aString! ! Object subclass: #Nautilus instanceVariableNames: 'announcer browsedEnvironment browsingHistory plugins selectedCategory selectedClass selectedGroup selectedMethod selectedPackage showCategories showComment showGroups showHierarchy showInstance showPackages ui uiClass' classVariableNames: 'CommentPosition HistoryMaxSize OpenOnGroups PluginClasses RecentClasses ShowAnnotationPane ShowHierarchy SwitchClassesAndPackages WarningLimit' poolDictionaries: '' category: 'Nautilus'! !Nautilus commentStamp: '' prior: 0! 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: 'accessing'! browsedEnvironment ^ browsedEnvironment ifNil: [ browsedEnvironment := RBBrowserEnvironment new ]! ! !Nautilus methodsFor: 'accessing'! browsedEnvironment: anEnvironment browsedEnvironment := anEnvironment! ! !Nautilus methodsFor: 'accessing'! browsingHistory ^ browsingHistory ifNil: [ browsingHistory := NavigationHistory new ]! ! !Nautilus methodsFor: 'accessing'! classes ^ self browsedEnvironment classes! ! !Nautilus methodsFor: 'accessing'! commentPosition ^ self class commentPosition! ! !Nautilus methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/14/2012 15:45'! groupsManager ^ self class groupsManagerFrom: self! ! !Nautilus methodsFor: 'accessing'! packages ^ self browsedEnvironment packages asArray! ! !Nautilus methodsFor: 'accessing'! plugins ^ plugins ifNil: [ plugins := OrderedCollection new ]! ! !Nautilus methodsFor: 'accessing'! recentClasses ^ self class recentClasses! ! !Nautilus methodsFor: 'accessing'! selectedCategory ^ selectedCategory! ! !Nautilus methodsFor: 'accessing'! selectedCategory: anObject selectedCategory := anObject. self selectedMethod: nil. self announcer announce: ( NautilusProtocolSelected category: anObject )! ! !Nautilus methodsFor: 'accessing'! selectedClass ^ selectedClass! ! !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: 'accessing'! selectedGroup ^ selectedGroup! ! !Nautilus methodsFor: 'accessing'! selectedGroup: anObject selectedGroup := anObject. self announcer announce: ( NautilusGroupSelected group: anObject ).! ! !Nautilus methodsFor: 'accessing'! selectedMethod ^ selectedMethod! ! !Nautilus methodsFor: 'accessing'! selectedMethod: anObject selectedMethod := anObject. self announcer announce: ( NautilusMethodSelected method: anObject )! ! !Nautilus methodsFor: 'accessing'! selectedPackage ^ selectedPackage! ! !Nautilus methodsFor: 'accessing'! selectedPackage: anObject selectedPackage := anObject. self announcer announce: ( NautilusPackageSelected package: anObject )! ! !Nautilus methodsFor: 'accessing'! showCategories ^ showCategories ifNil: [ showCategories := true ]! ! !Nautilus methodsFor: 'accessing'! showCategories: aBoolean showCategories := aBoolean. self announcer announce: ( NautilusShowCategoriesChanged boolean: aBoolean )! ! !Nautilus methodsFor: 'accessing'! showComment ^ showComment ifNil: [ showComment := false ]! ! !Nautilus methodsFor: 'accessing'! showComment: aBoolean showComment := aBoolean. self announcer announce: ( NautilusShowCommentChanged boolean: aBoolean )! ! !Nautilus methodsFor: 'accessing'! showGroups ^ showGroups ifNil: [ showGroups := self shouldOpenOnGroups ]! ! !Nautilus methodsFor: 'accessing'! showGroups: aBoolean showGroups := aBoolean. self announcer announce: ( NautilusShowGroupsChanged boolean: aBoolean )! ! !Nautilus methodsFor: 'accessing'! showHierarchy ^ showHierarchy ifNil: [ showHierarchy := self class showHierarchy ]! ! !Nautilus methodsFor: 'accessing'! showHierarchy: aBoolean showHierarchy := aBoolean. self announcer announce: ( NautilusShowHierarchyChanged boolean: aBoolean )! ! !Nautilus methodsFor: 'accessing'! showInstance ^ showInstance ifNil: [ showInstance := true ]! ! !Nautilus methodsFor: 'accessing'! showInstance: aBoolean showInstance := aBoolean. self announcer announce: ( NautilusShowInstanceChanged boolean: aBoolean )! ! !Nautilus methodsFor: 'accessing'! showPackages ^ showPackages ifNil: [ showPackages := true ]! ! !Nautilus methodsFor: 'accessing'! showPackages: aBoolean showPackages := aBoolean. self announcer announce: ( NautilusShowPackagesChanged boolean: aBoolean )! ! !Nautilus methodsFor: 'accessing'! switchClassesAndPackages ^ self class switchClassesAndPackages! ! !Nautilus methodsFor: 'accessing'! ui ^ ui! ! !Nautilus methodsFor: 'accessing'! uiClass ^ uiClass ifNil: [ self defaultUIClass ]! ! !Nautilus methodsFor: 'accessing'! uiClass: aClass uiClass := aClass! ! !Nautilus methodsFor: 'announcement'! announcer ^ announcer ifNil: [ announcer := NautilusAnnouncer new ]! ! !Nautilus methodsFor: 'browser compatibility'! codeTextMorph ^ self ui codeTextMorph! ! !Nautilus methodsFor: 'browser compatibility'! contents: aText self ui sourceCode: aText! ! !Nautilus methodsFor: 'browser compatibility'! labelString ^ self ui ifNil: [ 'Nautilus' ] ifNotNil: [:UI | UI title ]! ! !Nautilus methodsFor: 'browser compatibility'! openEditString: aString " Dunno what to do"! ! !Nautilus methodsFor: 'browser compatibility'! setClass: aClass selector: aSelector | method protocol | method := aClass methodDict at: aSelector ifAbsent: [ nil ]. protocol := method ifNil: [ nil ] ifNotNil: [ method protocol ]. self showGroups: false; selectedPackage: aClass package; selectedClass: aClass; showInstance: aClass isMeta not; selectedCategory: protocol; selectedMethod: method ! ! !Nautilus methodsFor: 'browser compatibility'! spawnHierarchy self showHierarchy:true; open. self ui showPackages: false! ! !Nautilus methodsFor: 'browser compatibility' stamp: 'BenjaminVanRyseghem 4/6/2012 17:44'! spawnHierarchyForClass: aClass selector: aSelector self setClass: aClass selector: aSelector. self spawnHierarchy! ! !Nautilus methodsFor: 'comparing'! = 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: 'displaying' stamp: 'CamilloBruni 9/21/2012 13:46'! close ui close! ! !Nautilus methodsFor: 'displaying'! defaultUIClass ^ NautilusUI! ! !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: 'events-registering'! announce: anAnnouncement self announcer announce: anAnnouncement ! ! !Nautilus methodsFor: 'history' stamp: 'BenjaminVanRyseghem 4/18/2012 19:16'! adopt: anAssociation | nautilusWrapper | nautilusWrapper := anAssociation key. self ui ifNotNil: [:interface | interface resetSelections]. self selectedPackage: nautilusWrapper selectedPackage; selectedClass: nautilusWrapper selectedClass; selectedCategory: nautilusWrapper selectedCategory. nautilusWrapper selectedMethod ifNil: [ self selectedMethod: nil ] ifNotNil: [:sel | self selectedMethod: (nautilusWrapper selectedClass methodDict at: sel ifAbsent: [ nil ])]. self selectedGroup: nautilusWrapper selectedGroup; showPackages: nautilusWrapper showPackages; showGroups: nautilusWrapper showGroups; showHierarchy: nautilusWrapper showHierarchy; showComment: nautilusWrapper showComment; showInstance: nautilusWrapper showInstance; showCategories: nautilusWrapper showCategories. self ui ifNotNil: [:interface || cl | cl := nautilusWrapper selectedClass. interface showPackages: self showPackages. cl ifNil: [ interface showInstance: false ] ifNotNil: [ interface showInstance: cl isMeta not. cl := cl theNonMetaClass ]. interface selectedPackageWithoutChangingSelectionInternally: nautilusWrapper selectedPackage; selectedClassWithoutChangingSelectionInternally: cl; selectedCategoryInternally: nautilusWrapper selectedCategory. nautilusWrapper selectedMethod ifNil: [ interface selectedMethod: nil ] ifNotNil: [:sel | interface selectedMethod: (nautilusWrapper selectedClass methodDict at: sel ifAbsent: [ nil ])]. interface updateBothView. interface update]. "self registerHistoryNewEntry"! ! !Nautilus methodsFor: 'history'! hasNext ^self browsingHistory hasNext! ! !Nautilus methodsFor: 'history'! hasPrevious ^self browsingHistory hasPrevious! ! !Nautilus methodsFor: 'history'! historyEntries ^ self browsingHistory entries! ! !Nautilus methodsFor: 'history' stamp: 'CamilloBruni 10/4/2012 11:31'! next self browsingHistory pauseDuring: [ self adopt: self browsingHistory next. self triggerEvent: #historyChanged ].! ! !Nautilus methodsFor: 'history'! package: aPackage class: aClass category: aCategory method: aMethod self selectedPackage: aPackage; selectedClass: aClass; selectedCategory: aCategory; selectedMethod: aMethod. self registerHistoryNewEntry.! ! !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 9/14/2012 15:48'! recentClassesElements | classes | classes := self browsedEnvironment classes. ^ self recentClasses mostViewedElements collect: [:nm | classes detect: [:e | e name = nm ] ifNone: [ nil ]] thenSelect: [:e | e notNil ]! ! !Nautilus methodsFor: 'history' stamp: 'CamilloBruni 10/4/2012 11:32'! registerHistoryNewEntry | lastEntry wrapper | self browsingHistory isPaused ifTrue: [ ^ self ]. wrapper := NautilusWrapper 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 ]]. wrapper showGroups ifTrue: [ wrapper selectedGroup ifNil:[ ^ self ]] ifFalse: [ wrapper selectedClass ifNil:[ ^ self ]]. self browsingHistory add: wrapper. self triggerEvent: #historyChanged.! ! !Nautilus methodsFor: 'private'! 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: 'private'! foundExtentionsIn: aClass ^ aClass extendingPackages. ! ! !Nautilus methodsFor: 'private'! 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'! 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: 'private' stamp: 'BenjaminVanRyseghem 9/14/2012 15:52'! shouldOpenOnGroups ^ self class openOnGroups and: [ (self class groupsManagerFrom: self) isEmpty not ]! ! !Nautilus methodsFor: 'private'! warningLimit ^ self class warningLimit! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Nautilus class instanceVariableNames: 'populateMethodList emptyCommentWarning groups cachedLastClasses maxSize useOldStyleKeys'! !Nautilus class methodsFor: '*Tools' stamp: 'EstebanLorenzano 2/19/2013 16:24'! cleanUpForProduction AbstractNautilusUI resetIconCaches. Nautilus resetCachedLastClasses. ! ! !Nautilus class methodsFor: 'accessing'! groupsManager ^ groups ifNil: [ groups := self buildGroupManager]! ! !Nautilus class methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/14/2012 15:46'! groupsManagerFrom: anInstance ^ groups ifNil: [ groups := self buildGroupManagerFor: anInstance]! ! !Nautilus class methodsFor: 'accessing'! historyMaxSize ^ HistoryMaxSize ifNil: [ HistoryMaxSize := self defaultMaxSize ]! ! !Nautilus class methodsFor: 'accessing'! historyMaxSize: anInteger (anInteger isKindOf: Integer) ifFalse: [ ^ self ]. anInteger > 0 ifFalse: [ ^ self ]. HistoryMaxSize := anInteger! ! !Nautilus class methodsFor: 'accessing'! maxSize ^ maxSize ifNil: [ maxSize := 10]! ! !Nautilus class methodsFor: 'accessing'! maxSize: anInteger maxSize := anInteger. self recentClasses maxSize: anInteger.! ! !Nautilus class methodsFor: 'accessing'! openOnGroups ^ OpenOnGroups ifNil: [ OpenOnGroups := false ]! ! !Nautilus class methodsFor: 'accessing'! openOnGroups:aBoolean OpenOnGroups := aBoolean! ! !Nautilus class methodsFor: 'accessing'! pluginClasses ^ PluginClasses ifNil: [ PluginClasses := OrderedCollection new ].! ! !Nautilus class methodsFor: 'accessing'! pluginClasses: aCollection PluginClasses := aCollection! ! !Nautilus class methodsFor: 'accessing'! recentClasses ^ RecentClasses ifNil: [ RecentClasses := HistoryCollection maxSize: self maxSize ]! ! !Nautilus class methodsFor: 'accessing'! showAnnotationPane: aBoolean ShowAnnotationPane := aBoolean! ! !Nautilus class methodsFor: 'accessing'! showHierarchy ^ ShowHierarchy ifNil: [ ShowHierarchy := true ]! ! !Nautilus class methodsFor: 'accessing'! showHierarchy: aBoolean ShowHierarchy := aBoolean! ! !Nautilus class methodsFor: 'accessing'! warningLimit ^ WarningLimit ifNil: [ WarningLimit := 350 ]! ! !Nautilus class methodsFor: 'accessing'! warningLimit: anInteger WarningLimit := anInteger! ! !Nautilus class methodsFor: 'browser compatibility' stamp: 'BenjaminVanRyseghem 4/14/2012 12:09'! addGroupForClasses: aCollection named: aName self groupsManager addADynamicClassGroupSilentlyNamed: aName name block: [ aCollection ].! ! !Nautilus class methodsFor: 'browser compatibility' stamp: 'BenjaminVanRyseghem 4/14/2012 12:09'! addGroupForPackage: aPackage self groupsManager addADynamicClassGroupSilentlyNamed: aPackage name block: [ aPackage orderedClasses ].! ! !Nautilus class methodsFor: 'browser compatibility'! fullOnClass: aClass ^ self openOnClass: aClass! ! !Nautilus class methodsFor: 'browser compatibility' stamp: 'BenjaminVanRyseghem 5/13/2012 20:10'! fullOnClass: aClass selector: aSelector ^ aSelector ifNil: [ self openOnClass: aClass ] ifNotNil: [| method | method := aClass methodDict at: aSelector ifAbsent: [ nil ]. method ifNotNil: [ self openOnMethod: method ]]! ! !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: 'browser compatibility'! fullOnEnvironment: anEnvironment self openInEnvironment: anEnvironment! ! !Nautilus class methodsFor: 'browser compatibility'! newOnClass: aClass ^ self fullOnClass: aClass! ! !Nautilus class methodsFor: 'browser compatibility' stamp: 'BernardoContreras 7/17/2012 21:20'! newOnClass: aClass selector: aSelector ^ self fullOnClass: aClass selector: aSelector ! ! !Nautilus class methodsFor: 'browser compatibility' stamp: 'BenjaminVanRyseghem 4/19/2012 13:08'! openBrowser self open.! ! !Nautilus class methodsFor: 'browser compatibility'! openBrowserView: aNautilus label: aString aNautilus open. aNautilus ui selectedMethod: aNautilus selectedMethod. aNautilus ui update. aNautilus ui title: aString! ! !Nautilus class methodsFor: 'class initialization' stamp: 'BenjaminVanRyseghem 9/15/2012 21:34'! initialize SystemBrowser default: self! ! !Nautilus class methodsFor: 'events' stamp: 'CamilleTeruel 7/29/2012 18:46'! stopNotifications " self stopNotifications " SystemAnnouncer uniqueInstance unsubscribe: self! ! !Nautilus class methodsFor: 'groups'! importAGroup: aGroup self groupsManager addAGroup: aGroup! ! !Nautilus class methodsFor: 'groups'! lastModifiedClasses ^ cachedLastClasses ifNil: [ cachedLastClasses := RecentMessageList uniqueInstance lastClasses: 10 ]! ! !Nautilus class methodsFor: 'groups'! resetCachedLastClasses ^ cachedLastClasses := nil! ! !Nautilus class methodsFor: 'icon'! icon ^ AbstractNautilusUI icon! ! !Nautilus class methodsFor: 'icon'! taskbarIcon ^ AbstractNautilusUI icon! ! !Nautilus class methodsFor: 'instance creation'! browsedEnvironment: anEnvironment ^ self new browsedEnvironment: anEnvironment! ! !Nautilus class methodsFor: 'opening'! open ^ self openInEnvironment: self defaultBrowsedEnvironment! ! !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: 'opening'! openOnCategory: aCategory ofClass: aClass ^ self openOnCategory: aCategory ofClass: aClass inEnvironment: self defaultBrowsedEnvironment! ! !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'! openOnClass: aClass ^ self openOnClass: aClass inEnvironment: self defaultBrowsedEnvironment! ! !Nautilus class methodsFor: 'opening' stamp: 'CamilloBruni 9/14/2012 00:58'! openOnClass: aClass inEnvironment: anEnvironment | instance | instance := self new. instance browsedEnvironment: anEnvironment; showInstance: aClass isMeta not; showGroups: false; package: aClass package class: aClass category: nil method: nil; open. instance ui showPackages: (self switchClassesAndPackages not); giveFocusToProtocol. ^ instance! ! !Nautilus class methodsFor: 'opening'! openOnClass: aClass onGroup: aGroup ^ self openOnClass: aClass onGroup: aGroup inEnvironment: self defaultBrowsedEnvironment.! ! !Nautilus class methodsFor: 'opening'! 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: 'opening' stamp: 'BenjaminVanRyseghem 6/26/2012 23:57'! openOnClass: aClass onProtocol: aProtocol ^ self openOnClass: aClass onProtocol: aProtocol inEnvironment: self defaultBrowsedEnvironment! ! !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'! openOnGroup: aGroup ^ self openOnGroup: aGroup inEnvironment: self defaultBrowsedEnvironment! ! !Nautilus class methodsFor: 'opening'! openOnGroup: aGroup inEnvironment: anEnvironment | instance | instance := self new. instance browsedEnvironment: anEnvironment. instance showGroups: true. instance selectedGroup: aGroup. instance open. ^ instance! ! !Nautilus class methodsFor: 'opening'! openOnMethod: aMethod ^ self openOnMethod: aMethod inEnvironment: self defaultBrowsedEnvironment! ! !Nautilus class methodsFor: 'opening' stamp: 'CamilloBruni 9/14/2012 01:03'! openOnMethod: aMethod inEnvironment: anEnvironment | instance class | class := aMethod methodClass. instance := self new. instance browsedEnvironment: anEnvironment; showInstance: class isMeta not; showGroups: false; package: class package class: class category: aMethod protocol asString method: aMethod; open. instance ui showPackages: (self switchClassesAndPackages not); giveFocusToMethod. ^ instance! ! !Nautilus class methodsFor: 'opening'! openOnPackage: aPackage ^ self openOnPackage: aPackage inEnvironment: self defaultBrowsedEnvironment! ! !Nautilus class methodsFor: 'opening'! 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'! 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'! commentPosition ^ CommentPosition ifNil: [ self defaultCommentPosition ]! ! !Nautilus class methodsFor: 'settings'! commentPosition: aSymbol (self commentPositions includes: aSymbol) ifFalse: [ ^ self ]. CommentPosition := aSymbol! ! !Nautilus class methodsFor: 'settings'! commentPositions ^ { #right. #bottom. #left. #top }! ! !Nautilus class methodsFor: 'settings' stamp: 'EstebanLorenzano 2/4/2013 17:47'! emptyCommentWarning ^emptyCommentWarning ifNil: [ emptyCommentWarning := true ]! ! !Nautilus class methodsFor: 'settings' stamp: 'EstebanLorenzano 2/4/2013 17:53'! emptyCommentWarning:aBoolean emptyCommentWarning := aBoolean. AbstractNautilusUI resetClassesIconsCache! ! !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: 'settings' stamp: 'BenjaminVanRyseghem 2/5/2013 14:35'! populateMethodList ^ populateMethodList ifNil: [ populateMethodList := self defaultPopulateMethodList ]! ! !Nautilus class methodsFor: 'settings' stamp: 'BenjaminVanRyseghem 2/5/2013 14:34'! populateMethodList: aBoolean populateMethodList := aBoolean! ! !Nautilus class methodsFor: 'settings'! switchClassesAndPackages ^ SwitchClassesAndPackages ifNil: [ SwitchClassesAndPackages := false ]! ! !Nautilus class methodsFor: 'settings'! switchClassesAndPackages: aBoolean SwitchClassesAndPackages := aBoolean! ! !Nautilus class methodsFor: 'settings' stamp: 'EstebanLorenzano 2/6/2013 14:03'! useOldStyleKeys ^useOldStyleKeys ifNil: [ useOldStyleKeys := false ]! ! !Nautilus class methodsFor: 'settings' stamp: 'EstebanLorenzano 2/6/2013 14:27'! useOldStyleKeys: aBoolean useOldStyleKeys := aBoolean! ! !Nautilus class methodsFor: 'private' stamp: 'BenjaminVanRyseghem 9/14/2012 15:49'! buildGroupManagerFor: anInstance | holder | holder := GroupsHolder new. (holder addADynamicClassGroupSilentlyNamed: 'Most Viewed Classes' block: [ anInstance 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: 'private'! defaultAnnotationInfo "see annotationRequests comment" ^ #(timeStamp messageCategory sendersCount implementorsCount allChangeSets)! ! !Nautilus class methodsFor: 'private'! defaultBrowsedEnvironment ^ RBBrowserEnvironment new! ! !Nautilus class methodsFor: 'private'! defaultCommentPosition ^ #right! ! !Nautilus class methodsFor: 'private'! defaultMaxSize ^ NavigationHistory defaultMaxSize! ! !Nautilus class methodsFor: 'private' stamp: 'BenjaminVanRyseghem 2/5/2013 14:35'! defaultPopulateMethodList ^ false! ! SystemAnnouncer subclass: #NautilusAnnouncer instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Announcements'! !NautilusAnnouncer commentStamp: '' prior: 0! an Announcer dedicated to Nautilus relative announcements! Announcement subclass: #NautilusBooleanAnnouncement instanceVariableNames: 'boolean' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Announcements'! !NautilusBooleanAnnouncement commentStamp: '' prior: 0! Announcement raised when a boolean value changed! !NautilusBooleanAnnouncement methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/12/2011 11:21'! boolean ^ boolean! ! !NautilusBooleanAnnouncement methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/12/2011 11:21'! boolean: anObject boolean := anObject! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NautilusBooleanAnnouncement class instanceVariableNames: ''! !NautilusBooleanAnnouncement class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 5/12/2011 11:21'! boolean: aBoolean ^ self new boolean: aBoolean! ! AbstractNautilusPlugin subclass: #NautilusBreadcrumbsPlugin instanceVariableNames: 'classButton container methodButton packageButton protocolButton hFill groupButton' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Plugin'! !NautilusBreadcrumbsPlugin commentStamp: '' prior: 0! A NautilusBreadcrumbsPlugin is a plugin which add breadcrumbs (for Igor ;) ) ! !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: '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: '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: '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: '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 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: 'display' stamp: 'BenjaminVanRyseghem 3/9/2012 21:34'! display ^ container! ! !NautilusBreadcrumbsPlugin methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 3/9/2012 21:46'! initialize "Initialization code for NautilusBreadcrumbsPlugin" 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: 'menus' stamp: 'BenjaminVanRyseghem 5/13/2012 17:09'! classMenu: aMenu ^ self model ui menu2: aMenu shifted: false. ! ! !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:31'! methodMenu: aMenu ^ self model ui methodWidget elementsMenu: 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: '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: 'private' stamp: 'BenjaminVanRyseghem 3/9/2012 21:46'! hFill ^ hFill ifNil: [ hFill := Morph new height: 0; width: 2; hResizing: #spaceFill; vResizing: #rigid; yourself ].! ! !NautilusBreadcrumbsPlugin methodsFor: 'private' stamp: 'BenjaminVanRyseghem 3/9/2012 21:48'! resetContainer container removeAllMorphs! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NautilusBreadcrumbsPlugin class instanceVariableNames: ''! !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! ! Announcement subclass: #NautilusChanged instanceVariableNames: 'symbol' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Announcements'! !NautilusChanged commentStamp: '' prior: 0! 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 instanceVariableNames: ''! !NautilusChanged class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 6/13/2012 21:34'! symbol: symbol ^ self new symbol: symbol; yourself! ! Announcement subclass: #NautilusClassSelected instanceVariableNames: 'class' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Announcements'! !NautilusClassSelected commentStamp: '' prior: 0! 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 instanceVariableNames: ''! !NautilusClassSelected class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 5/10/2011 14:48'! class: aClass ^ self new class: aClass! ! Announcement subclass: #NautilusGroupSelected instanceVariableNames: 'group' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Announcements'! !NautilusGroupSelected commentStamp: '' prior: 0! A NautilusGroupSelected is raised when a group is selected! !NautilusGroupSelected methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/10/2011 14:46'! group ^ group! ! !NautilusGroupSelected methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/10/2011 14:46'! group: anObject group := anObject! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NautilusGroupSelected class instanceVariableNames: ''! !NautilusGroupSelected class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 5/10/2011 14:48'! group: aGroup ^ self new group: aGroup! ! CustomHelp subclass: #NautilusHelp instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Nautilus-Help'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NautilusHelp class instanceVariableNames: ''! !NautilusHelp class methodsFor: 'as yet unclassified' stamp: 'SeanDeNigris 2/6/2013 14:42'! bookName ^ 'Nautilus'.! ! !NautilusHelp class methodsFor: 'as yet unclassified' 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'! ! !NautilusHelp class methodsFor: 'as yet unclassified' stamp: 'SeanDeNigris 2/6/2013 14:46'! pages ^ #(contextMenus). ! ! Object subclass: #NautilusIcons instanceVariableNames: '' classVariableNames: 'Icons Instance' poolDictionaries: '' category: 'NautilusCommon'! !NautilusIcons commentStamp: 'lr 7/10/2009 11:12' prior: 0! Most of these icons come from http://www.famfamfam.com/lab/icons. They are licensed under the Creative Commons Attribution 3.0 License by Mark James.! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 2/21/2012 01:53'! abstract ^(Form extent: 12@12 depth: 32 fromArray: #(16777215 16777215 369098752 1912602624 2717908992 3019898880 3640655872 3841982464 3674210304 3405774848 385875968 16777215 16777215 1811939328 1845493760 352321536 16777215 16777215 134217728 2432696320 3539992576 3590324224 16777215 16777215 1442840576 2264924160 16777215 16777215 16777215 50331648 2667577344 1241513984 3053453312 2952790016 16777215 16777215 3154116608 1543503872 16777215 16777215 16777215 1509949440 2617245696 16777215 3422552064 2650800128 16777215 16777215 4060086272 2399141888 16777215 16777215 16777216 3523215360 671088640 16777215 3607101440 2399141888 16777215 16777215 3439329280 1325400064 16777215 16777215 1342177280 3019898880 16777215 16777215 3472883712 2533359616 16777215 16777215 436207616 16777215 16777215 16777215 3087007744 1426063360 16777215 16777215 3238002688 2952790016 16777215 16777215 16777215 16777215 16777215 520093696 4244635648 4060086272 4026531840 3825205248 3690987520 3472883712 16777215 16777215 16777215 16777215 16777215 2231369728 1996488704 16777215 16777215 16777215 2483027968 3992977408 16777215 16777215 16777215 16777215 201326592 3321888768 134217728 16777215 16777215 16777215 1962934272 4278190080 318767104 16777215 16777215 771751936 2583691264 922746880 83886080 16777215 16777215 16777215 1090519040 4278190080 2617245696 1811939328 1929379840 3707764736 3875536896 3254779904 201326592 16777215 16777215 16777215 134217728 3791650816 2214592512 419430400) offset: 0@0)! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 8/23/2011 17:49'! alert ^(Form extent: 16@16 depth: 32 fromArray: #(16777215 16777215 16777215 16777215 16777215 16777215 16777215 2919235584 2919235584 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1207959552 4278190080 4278190080 1207959552 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 3338665984 4278255616 4278255616 3338665984 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1207959552 4278190080 4283633923 4283633923 4278190080 1207959552 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 3338665984 4278255616 4291897863 4291897863 4278255616 3338665984 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1207959552 4278190080 4283633923 4294914824 4294914824 4283633923 4278190080 1207959552 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 3338665984 4278255616 4291897863 4294914824 4294914824 4291897863 4278255616 3338665984 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1207959552 4278190080 4283568131 4294914824 4294914824 4294914824 4294914824 4283568131 4278190080 1207959552 16777215 16777215 16777215 16777215 16777215 16777215 3338665984 4278255616 4291832327 4294914824 4294914824 4294914824 4294914824 4291832327 4278255616 3338665984 16777215 16777215 16777215 16777215 16777215 1207959552 4278190080 4283502595 4294914824 4294914824 4294914824 4294914824 4294914824 4294914824 4283502595 4278190080 1207959552 16777215 16777215 16777215 16777215 3338665984 4278255616 4291832327 4294914824 4294914824 4294914824 4294914824 4294914824 4294914824 4291832327 4278255616 3338665984 16777215 16777215 16777215 1207959552 4278190080 4283437059 4294914824 4294914824 4294914824 4294914824 4294914824 4294914824 4294914824 4294914824 4283437059 4278190080 1207959552 16777215 16777215 3338665984 4278255616 4291766534 4294914824 4294914824 4294914824 4294914824 4294914824 4294914824 4294914824 4294914824 4291766534 4278255616 3338665984 16777215 1207959552 4278190080 4283437059 4294914824 4294914824 4294914824 4294914824 4294914824 4294914824 4294914824 4294914824 4294914824 4294914824 4283437059 4278190080 1207959552 3288334336 4278190080 4280813569 4282322178 4282322178 4282322178 4282322178 4282322178 4282322178 4282322178 4282322178 4282322178 4282322178 4280813569 4278190080 3321888768 3238068224 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 3254845440) offset: 0@0)! ! !NautilusIcons methodsFor: 'icons' stamp: 'lr 7/10/2009 11:17'! announcement ^ ((ColorForm extent: 12@12 depth: 8 fromArray: #( 168300858 976894522 976888885 34288443 993737531 993722369 959979575 673982238 103889690 87761712 705236742 120273668 87758851 152641799 789920516 959985427 204284436 488586007 34289723 993723152 926613505 168311098 976632635 473311541 1010580540 1007826230 840318012 1010580540 456396046 1010580540 1010580526 623262780 1010580540 1010580540 1010580540 1010580540) offset: 0@0) colorsFromArray: #(#(0.706 0.788 0.875) #(0.439 0.596 0.761) #(0.545 0.674 0.807) #(0.887 0.934 0.996) #(0.538 0.667 0.804) #(0.423 0.585 0.753) #(0.859 0.918 0.992) #(0.844 0.91 0.992) #(0.577 0.694 0.819) #(0.879 0.93 0.996) #(0.953 0.969 0.98) #(0.663 0.757 0.855) #(0.863 0.922 0.992) #(0.372 0.549 0.733) #(0.71 0.792 0.879) #(0.867 0.926 0.996) #(0.815 0.891 0.992) #(0.361 0.542 0.729) #(0.435 0.592 0.761) #(0.875 0.926 0.996) #(0.827 0.902 0.992) #(0.819 0.894 0.992) #(0.678 0.768 0.863) #(0.49 0.635 0.784) #(0.898 0.941 0.996) #(0.867 0.922 0.996) #(0.482 0.628 0.78) #(0.639 0.741 0.848) #(0.937 0.953 0.973) #(0.815 0.894 0.992) #(0.871 0.926 0.996) #(0.819 0.894 0.988) #(0.941 0.965 0.996) #(0.855 0.914 0.992) #(0.84 0.906 0.992) #(0.91 0.945 0.996) #(0.522 0.655 0.796) #(0.431 0.592 0.757) #(0.745 0.815 0.891) #(0.883 0.934 0.996) #(0.902 0.945 0.996) #(0.458 0.612 0.768) #(0.891 0.937 0.996) #(0.836 0.902 0.992) #(0.894 0.937 0.996) #(0.851 0.914 0.992) #(0.914 0.937 0.965) #(0.831 0.902 0.992) #(0.902 0.941 0.996) #(0.863 0.918 0.992) #(0.365 0.545 0.729) #(0.984 0.988 0.992) #(0.6 0.714 0.831) #(0.906 0.934 0.961) #(0.616 0.721 0.836) #(0.914 0.949 0.996) #(0.992 0.996 0.996) #(0.353 0.534 0.725) #(0.345 0.53 0.721) #(1.0 1.0 1.0)))! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 4/7/2011 14:10'! arrowDoubleDown ^ Form extent: 12@6 depth: 32 fromArray: #(16777215 16777215 16777215 16777215 1711418368 4278893824 4278893824 1711418368 16777215 16777215 16777215 16777215 16777215 16777215 1644306688 3540342528 3590744064 4278961664 4278961664 3590744064 3540342528 1644306688 16777215 16777215 16777215 16777215 33554432 3120842496 4278962176 4278962688 4278962688 4278962176 3120842496 33554432 16777215 16777215 16777215 16777215 16777215 402722560 3590744064 4278962688 4278962688 3590744064 402722560 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1308764928 3959984384 3959984384 1308764928 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 2315466752 2315466752 16777215 16777215 16777215 16777215 16777215) offset: 0@0! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 4/7/2011 14:09'! arrowDoubleUp ^ Form extent: 12@6 depth: 32 fromArray: #(16777215 16777215 16777215 16777215 16777215 2315466752 2315466752 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1308764928 3959984384 3959984384 1308764928 16777215 16777215 16777215 16777215 16777215 16777215 16777215 402722560 3590744064 4278962688 4278962688 3590744064 402722560 16777215 16777215 16777215 16777215 16777215 33554432 3120842496 4278962176 4278962688 4278962688 4278962176 3120842496 33554432 16777215 16777215 16777215 16777215 1644306688 3540342528 3590744064 4278961664 4278961664 3590744064 3540342528 1644306688 16777215 16777215 16777215 16777215 16777215 16777215 1711418368 4278893824 4278893824 1711418368 16777215 16777215 16777215 16777215) offset: 0@0! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 4/7/2011 13:49'! arrowDown ^ Form extent: 12@12 depth: 32 fromArray: #(16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1157900544 3154467840 3154467840 1157900544 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1711483648 4278893824 4278893824 1711483648 16777215 16777215 16777215 16777215 16777215 16777215 1661149440 3624228608 3657853952 4278961664 4278961664 3657853952 3624228608 1661149440 16777215 16777215 16777215 16777215 16777216 3070510592 4278962176 4278962688 4278962688 4278962176 3070510592 16777216 16777215 16777215 16777215 16777215 16777215 352324608 3573966336 4278962688 4278962688 3573966336 352324608 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1258499072 3959984128 3959984128 1258499072 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 2315532032 2315532032 16777215 16777215 16777215 16777215 16777215) offset: 0@0! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 4/7/2011 13:48'! arrowUp ^ Form extent: 12@12 depth: 32 fromArray: #(16777215 16777215 16777215 16777215 16777215 2315532032 2315532032 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1275276288 3959984384 3959984384 1275276288 16777215 16777215 16777215 16777215 16777215 16777215 16777215 369104640 3573967104 4278962688 4278962688 3573967104 369104640 16777215 16777215 16777215 16777215 16777215 16777216 3087288576 4278962176 4278962688 4278962688 4278962176 3087288576 16777216 16777215 16777215 16777215 16777215 1610818304 3540342528 3590744320 4278961664 4278961664 3590744064 3540342528 1610818304 16777215 16777215 16777215 16777215 16777215 16777215 1711483648 4278893824 4278893824 1711483648 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1157900544 3154467840 3154467840 1157900544 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215) offset: 0@0! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 4/7/2011 13:46'! arrowUpAndDown ^ Form extent: 12@12 depth: 32 fromArray: #(16777215 16777215 16777215 16777215 16777215 2315532032 2315532032 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1308830464 3959984128 3959984128 1308830464 16777215 16777215 16777215 16777215 16777215 16777215 16777215 402658560 3590744064 4278962688 4278962688 3590744064 402658560 16777215 16777215 16777215 16777215 16777215 33554432 3120842496 4278962176 4278962688 4278962688 4278962176 3120842496 33554432 16777215 16777215 16777215 16777215 1644372480 3540342528 3590744064 4278961664 4278961664 3590744064 3540342528 1644372480 16777215 16777215 16777215 16777215 16777215 16777215 1711483648 4278893824 4278893824 1711483648 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1711483648 4278893824 4278893824 1711483648 16777215 16777215 16777215 16777215 16777215 16777215 1644372480 3540342528 3590744064 4278961664 4278961664 3590744064 3540342528 1644372480 16777215 16777215 16777215 16777215 33554432 3120842496 4278962176 4278962688 4278962688 4278962176 3120842496 33554432 16777215 16777215 16777215 16777215 16777215 402658560 3590744064 4278962688 4278962688 3590744064 402658560 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1308830464 3959984128 3959984128 1308830464 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 2315532032 2315532032 16777215 16777215 16777215 16777215 16777215) offset: 0@0! ! !NautilusIcons methodsFor: 'icons' stamp: 'lr 3/28/2009 16:04'! blank ^ Form extent: 12 @ 12 depth: 8! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 3/30/2011 12:44'! 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)! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 1/24/2013 11:32'! breakpoint ^ (Form extent: 12@12 depth: 32 fromArray: #(65793 263172 723723 1118481 1118481 986895 2105376 2763306 2763306 67103462 268432883 2763306 592137 4292120661 4294091872 4294091873 4294157409 4293761359 4293692217 4292966190 4291188009 4290667050 3788336426 2697513 1842204 4293896029 4294950266 4294951566 4294952079 4294946163 4294679882 4293560119 4291455268 4290408752 3781443373 2236962 2434341 4293634672 4294947176 4293104482 4293298523 4293889090 4294283834 4292508724 4289353754 4288703298 3779669784 460551 2763306 4294090583 4294944865 4294414649 4294412365 4294740308 4294347083 4292442425 4290340132 4289030722 3781115940 0 2763306 4293628243 4294416447 4293757242 4293558847 4293558846 4293428282 4292576052 4291195169 4289356842 3784068364 0 100637231 4293560659 4294345772 4293425455 4293292847 4292965164 4293096750 4292770607 4291784990 4289290532 3781376536 0 268414300 4290343737 4288897835 4289357356 4289357355 4289357356 4289621035 4288765476 4287250199 4288964671 3780194070 0 1447446 2500134 2697513 2763306 2763306 2697513 2500134 1447446 4284691226 4288243004 3780655396 0 263172 1118481 1973790 2368548 2368548 1973790 1118481 263172 4283972646 4288182882 3780721959 0 0 0 263172 526344 526344 263172 0 0 4283777067 4286604879 3780524581 0 0 0 0 0 0 0 0 0 3997841701 3999418930 3528274204 0) offset: 0@0)! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 1/21/2012 23:23'! byteCodePressedIcon ^ Form extent: 24 @ 24 depth: 32 fromArray: #(4281084972 4283979864 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4292335575 4285229931 4281084972 4283979864 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4292335575 4285229931 4281084972 4283979864 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4292335575 4285229931 4281084972 4283979864 4289769648 4289769648 4289769648 4289769648 4289638062 4289374890 4289374890 4289374890 4289374890 4289374890 4289638062 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4292335575 4285229931 4281084972 4283979864 4289769648 4289769648 4289769648 4288782753 4280098078 4278190080 4278190080 4278190080 4278190080 4278190080 4278255873 4279045389 4280098077 4283124555 4287730065 4289769648 4289769648 4289769648 4289769648 4289769648 4292335575 4285229931 4281084972 4283979864 4289769648 4289769648 4289769648 4285295724 4278190080 4278190595 4278191367 4278191367 4278191367 4278191367 4278190853 4278190080 4278190080 4278190080 4278255873 4284703587 4289769648 4289769648 4289769648 4289769648 4292335575 4285229931 4281084972 4283979864 4289769648 4289769648 4289769648 4285295724 4278190080 4278206556 4278232557 4278231527 4278211962 4278209903 4278211448 4278219685 4278222774 4278207843 4278190337 4278255873 4287006342 4289769648 4289769648 4289769648 4292335575 4285229931 4281084972 4283979864 4289769648 4289769648 4289769648 4285295724 4278190080 4278206556 4278232557 4278207329 4278190080 4278190080 4278190080 4278190080 4278210932 4278232557 4278208616 4278190080 4283256141 4289769648 4289769648 4289769648 4292335575 4285229931 4281084972 4283979864 4289769648 4289769648 4289769648 4285295724 4278190080 4278206556 4278232557 4278202695 4278190080 4282532418 4282992969 4278190080 4278192397 4278232299 4278219943 4278190080 4281282351 4289769648 4289769648 4289769648 4292335575 4285229931 4281084972 4283979864 4289769648 4289769648 4289769648 4285295724 4278190080 4278206556 4278232557 4278202695 4278190080 4282203453 4282664004 4278190080 4278193169 4278232300 4278212991 4278190080 4282729797 4289769648 4289769648 4289769648 4292335575 4285229931 4281084972 4283979864 4289769648 4289769648 4289769648 4285295724 4278190080 4278206556 4278232557 4278208100 4278190080 4278190080 4278190080 4278190080 4278212734 4278217625 4278191624 4278190080 4285887861 4289769648 4289769648 4289769648 4292335575 4285229931 4281084972 4283979864 4289769648 4289769648 4289769648 4285295724 4278190080 4278206556 4278232557 4278231784 4278213249 4278211190 4278213507 4278224834 4278231013 4278191624 4278190080 4279703319 4289506476 4289769648 4289769648 4289769648 4292335575 4285229931 4281084972 4283979864 4289769648 4289769648 4289769648 4285295724 4278190080 4278206556 4278232557 4278222259 4278191882 4278190080 4278191110 4278200635 4278217368 4278210674 4278190337 4278190080 4283124555 4289769648 4289769648 4289769648 4292335575 4285229931 4281084972 4283979864 4289769648 4289769648 4289769648 4285295724 4278190080 4278206556 4278232557 4278202695 4278190080 4278190080 4278190080 4278190080 4278190080 4278223547 4278220457 4278190080 4279045389 4289703855 4289769648 4289769648 4292335575 4285229931 4281084972 4283979864 4289769648 4289769648 4289769648 4285295724 4278190080 4278206556 4278232557 4278202695 4278190080 4286348412 4288980132 4282466625 4278190080 4278208358 4278232557 4278195487 4278190080 4287203721 4289769648 4289769648 4292335575 4285229931 4281084972 4283979864 4289769648 4289769648 4289769648 4285295724 4278190080 4278206556 4278232557 4278202695 4278190080 4284243036 4286019447 4280624421 4278190080 4278211448 4278232557 4278201664 4278190080 4286151033 4289769648 4289769648 4292335575 4285229931 4281084972 4283979864 4289769648 4289769648 4289769648 4285295724 4278190080 4278206556 4278232557 4278203982 4278190080 4278190080 4278190080 4278190080 4278257676 4278227665 4278229983 4278193427 4278190080 4288387995 4289769648 4289769648 4292335575 4285229931 4281084972 4283979864 4289769648 4289769648 4289769648 4285295724 4278190080 4278206556 4278232557 4278228438 4278202694 4278200635 4278201665 4278211447 4278226121 4278223289 4278200121 4278190080 4280492835 4289769648 4289769648 4289769648 4292335575 4285229931 4281084972 4283979864 4289769648 4289769648 4289769648 4285295724 4278190080 4278194198 4278200635 4278200635 4278200635 4278200635 4278200378 4278197030 4278192140 4278190080 4278190080 4279111182 4288256409 4289769648 4289769648 4289769648 4292335575 4285229931 4281084972 4283979864 4289769648 4289769648 4289769648 4287795858 4278848267 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4279111182 4283716692 4288651167 4289769648 4289769648 4289769648 4289769648 4292335575 4285229931 4281084972 4283979864 4289769648 4289769648 4289769648 4289769648 4288322202 4286874756 4286874756 4286874756 4286874756 4286874756 4286940549 4287664272 4288848546 4289703855 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4292335575 4285229931 4281084972 4283979864 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4292335575 4285229931 4281084972 4283979864 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4292335575 4285229931 4281084972 4283979864 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4292335575 4285229931) offset: 0 @ 0! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 1/21/2012 21:37'! byteCodeSelectedIcon ^ (Form extent: 24@24 depth: 32 fromArray: #(4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4285690740 4283388242 4283388242 4283388242 4283388242 4283388242 4283914072 4284900966 4286019447 4289045925 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4278981398 4278210160 4278212477 4278212477 4278212477 4278212477 4278278012 4278601314 4278858308 4278586382 4282205255 4289506476 4289769648 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4278981398 4278227923 4278232557 4278232557 4278231784 4278231270 4278232042 4278232557 4278232557 4278229725 4278596680 4282204997 4289769648 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4278981398 4278227923 4278232557 4278227151 4278388489 4278387974 4278454282 4278793287 4278229982 4278232557 4278231013 4278388232 4289374890 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4278981398 4278227923 4278232557 4278224062 4279837479 4289769648 4289111718 4281349688 4278279815 4278232557 4278232557 4278787366 4287532686 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4278981398 4278227923 4278232557 4278224062 4279837479 4289769648 4288651167 4281086517 4278280588 4278232557 4278231527 4278454539 4288848546 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4278981398 4278227923 4278232557 4278227665 4278388746 4278190080 4278454796 4278729295 4278230497 4278232299 4278405738 4280165673 4289769648 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4278981398 4278227923 4278232557 4278232557 4278232557 4278232557 4278232557 4278232557 4278232557 4278280844 4278716939 4288453788 4289769648 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4278981398 4278227923 4278232557 4278231784 4278213249 4278211190 4278212992 4278223547 4278232299 4278229983 4278664018 4279573535 4288914339 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4278981398 4278227923 4278232557 4278224062 4278980883 4283979864 4283256913 4279573793 4278729811 4278232557 4278232557 4278662988 4285295724 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4278981398 4278227923 4278232557 4278224062 4279837479 4289769648 4289769648 4289177511 4278586125 4278229468 4278232557 4278217111 4281350203 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4278981398 4278227923 4278232557 4278224062 4279837479 4289769648 4289769648 4287795858 4278586897 4278231270 4278232557 4278222517 4280100651 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4278981398 4278227923 4278232557 4278225349 4278520075 4280298031 4279705635 4278520589 4278541957 4278232557 4278232557 4278214280 4282533705 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4278981398 4278227923 4278232557 4278232557 4278223805 4278222002 4278223804 4278231785 4278232557 4278232557 4278225091 4278652691 4287203721 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4278981398 4278218398 4278222002 4278222002 4278222002 4278222002 4278221745 4278218656 4278214537 4278727752 4278717968 4285624947 4289769648 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4282994771 4280298031 4280298031 4280298031 4280298031 4280298031 4280363824 4281284668 4282731084 4285164138 4289243304 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4174039754) offset: 0@0)! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 1/21/2012 21:38'! byteCodeUnselectedIcon ^ (Form extent: 24@24 depth: 32 fromArray: #(4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4285756275 4283519313 4283519313 4283519313 4283519313 4283519313 4283914071 4284900966 4286019447 4289045925 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4279308561 4282137660 4282664004 4282664004 4282664004 4282664004 4282598211 4281874488 4280887593 4278848010 4282532418 4289506476 4289769648 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4279308561 4285690482 4286611584 4286611584 4286414205 4286348412 4286479998 4286611584 4286611584 4286019447 4280887593 4282532418 4289769648 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4279308561 4285690482 4286611584 4285558896 4278584838 4278519045 4278650631 4281019179 4286085240 4286611584 4286282619 4278584838 4289374890 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4279308561 4285690482 4286611584 4284900966 4280361249 4289769648 4289111718 4281677109 4282992969 4286611584 4286611584 4279834905 4287532686 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4279308561 4285690482 4286611584 4284900966 4280361249 4289769648 4288651167 4281413937 4283190348 4286611584 4286414205 4278716424 4288848546 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4279308561 4285690482 4286611584 4285624689 4278650631 4278190080 4278716424 4281282351 4286151033 4286545791 4282006074 4280558628 4289769648 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4279308561 4285690482 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4283190348 4278848010 4288453788 4289769648 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4279308561 4285690482 4286611584 4286414205 4282795590 4282400832 4282729797 4284835173 4286545791 4286085240 4281282351 4279966491 4288914339 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4279308561 4285690482 4286611584 4284900966 4279242768 4283979864 4283387727 4280032284 4281348144 4286611584 4286611584 4281084972 4285295724 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4279308561 4285690482 4286611584 4284900966 4280361249 4289769648 4289769648 4289177511 4278848010 4286019447 4286611584 4283519313 4281742902 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4279308561 4285690482 4286611584 4284900966 4280361249 4289769648 4289769648 4287795858 4278979596 4286348412 4286611584 4284637794 4280558628 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4279308561 4285690482 4286611584 4285164138 4278716424 4280821800 4280163870 4278782217 4283058762 4286611584 4286611584 4282992969 4282795590 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4279308561 4285690482 4286611584 4286611584 4284900966 4284506208 4284835173 4286479998 4286611584 4286611584 4285098345 4279045389 4287203721 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4279308561 4283782485 4284506208 4284506208 4284506208 4284506208 4284440415 4283848278 4283058762 4280953386 4278979596 4285690482 4289769648 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4283387727 4280821800 4280821800 4280821800 4280821800 4280821800 4280887593 4281742902 4282992969 4285164138 4289243304 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4174039754 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4174039754) offset: 0@0)! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 1/21/2012 23:46'! classVarsPressedIcon ^ (Form extent: 24@24 depth: 32 fromArray: #(4244767234 4283979864 4287401100 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290690750 4292335575 4244898820 4244767234 4283979864 4287401100 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290690750 4292335575 4244898820 4244767234 4283979864 4287401100 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289572269 4286874756 4284900966 4282992969 4281611316 4282598211 4283979864 4287072135 4289769648 4289769648 4289769648 4289769648 4290690750 4292335575 4244898820 4244767234 4283979864 4287401100 4289769648 4289769648 4289769648 4289769648 4289769648 4287137928 4280163870 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4279966491 4287664272 4289769648 4289769648 4290690750 4292335575 4244898820 4244767234 4283979864 4287401100 4289769648 4289769648 4289769648 4289769648 4283716692 4278255873 4278190080 4278190125 4278190199 4278190242 4278190255 4278190240 4278190204 4278190114 4278190080 4281940281 4289769648 4289769648 4290690750 4292335575 4244898820 4244767234 4283979864 4287401100 4289769648 4289769648 4289769648 4286348412 4278190080 4278255883 4278190222 4278190321 4278190189 4278190107 4278190080 4278190084 4278190119 4278190158 4278190080 4281611316 4289769648 4289769648 4290690750 4292335575 4244898820 4244767234 4283979864 4287401100 4289769648 4289769648 4289111718 4279440147 4278190080 4278190247 4278190321 4278190124 4278190080 4278190080 4279242768 4278782217 4278190080 4278190080 4278190080 4281611316 4289769648 4289769648 4290690750 4292335575 4244898820 4244767234 4283979864 4287401100 4289769648 4289769648 4284769380 4278190080 4278190153 4278190335 4278190200 4278190080 4280492835 4288059030 4289769648 4289769648 4287993237 4282400832 4278255873 4283585106 4289769648 4289769648 4290690750 4292335575 4244898820 4244767234 4283979864 4287401100 4289769648 4289769648 4282664004 4278190080 4278190238 4278190332 4278190091 4278387459 4288059030 4289769648 4289769648 4289769648 4289769648 4289769648 4289374890 4289703855 4289769648 4289769648 4290690750 4292335575 4244898820 4244767234 4283979864 4287401100 4289769648 4289769648 4280756007 4278190080 4278190281 4278190301 4278190080 4280229663 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290690750 4292335575 4244898820 4244767234 4283979864 4287401100 4289769648 4289769648 4279308561 4278190080 4278190312 4278190273 4278190080 4281216558 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290690750 4292335575 4244898820 4244767234 4283979864 4287401100 4289769648 4289769648 4280690214 4278190080 4278190281 4278190300 4278190080 4280229663 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290690750 4292335575 4244898820 4244767234 4283979864 4287401100 4289769648 4289769648 4282664004 4278190080 4278190239 4278190331 4278190090 4278387459 4288059030 4289769648 4289769648 4289769648 4289769648 4289769648 4289374890 4289769648 4289769648 4289769648 4290690750 4292335575 4244898820 4244767234 4284572001 4287466893 4289769648 4289769648 4284703587 4278190080 4278190156 4278190335 4278190200 4278190080 4230095394 4070086808 4038111408 4021334192 4237661589 4282400832 4278255873 4283848278 4289769648 4289769648 4290559164 4292138196 4244898820 4110681092 4283716692 4286940549 4289769648 4289769648 4289111718 4279374354 4278190080 4278190245 4278190321 4278190120 4278190080 4278190080 4279308561 4278782217 4278190080 4278190080 4278190080 4281611316 4289769648 4289769648 4290756543 4291480266 4111207436 3691645450 4282664004 4286085240 4289769648 4289769648 4289769648 4286151033 4278190080 4278255885 4278190229 4278190321 4278190186 4278190102 4278190080 4278190082 4278190117 4278190158 4278190080 4281611316 4289769648 4289769648 4291151301 4289703855 3826915866 2147615234 4196935720 4284440415 4289703855 4289769648 4289769648 4289769648 4283387727 4278190080 4278190080 4278190131 4278190199 4278190239 4278190252 4278190242 4278190211 4278190116 4278190080 4281940281 4289769648 4289769648 4292006610 4271018642 3037662991 738197504 4127853066 4283979864 4288387995 4289769648 4289769648 4289769648 4289769648 4286940549 4280163870 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4279966491 4287664272 4289769648 4290230199 4292335575 4047256636 1728053248 14684133 3892708870 4282729797 4286151033 4289769648 4289769648 4289769648 4289769648 4289769648 4289572269 4286611584 4284703587 4282927176 4281479730 4282400832 4283914071 4287072135 4289769648 4289769648 4289769648 4291217094 4290493371 4077521418 150994944 14684133 1392640514 4077981969 4283914071 4288190616 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290361785 4292138196 4097259319 2064058119 14684133 14684133 14684133 2986541827 4078968864 4284572001 4289374890 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289901234 4291875024 4149367378 2987133964 16777216 14684133 14684133 14684133 134217728 3188065798 4162723358 4284045657 4288848546 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290230199 4289374890 4213844522 3205632530 117440512 14684133 14684133 14684133 14684133 14684133 67108864 2147681027 4093969669 4179697953 4284308829 4287203721 4289177511 4289769648 4289769648 4289769648 4289769648 4289374890 4287861651 4284637794 4196672548 3994030096 1594427657 14684133 14684133 14684133 14684133 14684133 14684133 14684133 14684133 14684133 167772160 1862599941 3255964178 3741911305 4161210119 4228055811 4227990018 4227990018 4228055811 4177921542 3708751631 2602573856 822346756 14684133 14684133 14684133 14684133 14684133 14684133) offset: 0@0)! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 1/21/2012 23:46'! classVarsSelectedIcon ^ (Form extent: 24@24 depth: 32 fromArray: #(4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290032820 4292335575 3954620086 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290032820 4292335575 3954620086 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4288519581 4287006342 4287927444 4289309097 4289769648 4289769648 4289769648 4289769648 4289769648 4290032820 4292335575 3954620086 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4285690483 4279900714 4278519052 4278716443 4278913850 4278848038 4278387465 4280361263 4285361517 4289638062 4289769648 4289769648 4290032820 4292335575 3954620086 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4289769648 4288190616 4280690227 4278716465 4278190269 4278190323 4278190335 4278190335 4278190335 4278190331 4278190259 4278650662 4286282619 4289769648 4289769648 4290032820 4292335575 3954620086 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4289243304 4279242778 4278256016 4278190333 4278190335 4278190312 4278190237 4278387569 4278256001 4278190247 4278190319 4278782296 4285953654 4289769648 4289769648 4290032820 4292335575 3954620086 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4282664011 4278584928 4278190335 4278190335 4278190258 4278650646 4281940294 4284703588 4283848281 4281150779 4278650643 4278387485 4285953654 4289769648 4289769648 4290032820 4292335575 3954620086 4165947215 4283979864 4289572269 4289769648 4289769648 4288059030 4278650646 4278190320 4278190335 4278190308 4278650642 4287401100 4289769648 4289769648 4289769648 4289769648 4288322202 4283124562 4288453788 4289769648 4289769648 4290032820 4292335575 3954620086 4165947215 4283979864 4289572269 4289769648 4289769648 4285822068 4278848084 4278190335 4278190335 4278584939 4283321940 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290032820 4292335575 3954620086 4182724431 4283979864 4289572269 4289769648 4289769648 4283650902 4278256002 4278190335 4278190335 4278848054 4286874756 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290032820 4292335575 3954620086 4216344656 4283979864 4289572269 4289769648 4289769648 4281479743 4278190248 4278190335 4278190335 4278716441 4288453788 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290032820 4292335575 3988174518 4249899088 4283979864 4289572269 4289769648 4289769648 4282927182 4278256014 4278190335 4278190335 4278848045 4287335307 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290032820 4292335575 4122458039 4249964881 4283979864 4289572269 4289769648 4289769648 4285229931 4278782304 4278190335 4278190335 4278716502 4284703588 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290032820 4292335575 4189501110 4233253458 4284045657 4289638062 4289769648 4289769648 4287335307 4278848039 4278190333 4278190335 4278190281 4279045400 4221937061 4222660784 4222660784 4222660784 4272992432 4289638062 4286348412 4289374890 4289769648 4289769648 4289967027 4292335575 4155946678 3813362507 4283979864 4289309097 4289769648 4289769648 4289703855 4280624432 4278321807 4278190335 4278190335 4278519161 4279111193 4285295724 4287598479 4286874756 4284703587 4279440159 4278321671 4285953654 4289769648 4289769648 4290032820 4292335575 3669802172 3696448339 4283979864 4288651167 4289769648 4289769648 4289769648 4288256409 4278716435 4278190290 4278190335 4278190335 4278190267 4278716505 4278913837 4278913852 4278584933 4278190271 4278782296 4285953654 4289769648 4289769648 4290361785 4292335575 3602430136 2706789974 4283979864 4286940549 4289769648 4289769648 4289769648 4289769648 4286019448 4278782227 4278519155 4278190323 4278190335 4278190335 4278190335 4278190335 4278190335 4278190315 4278584893 4285953654 4289769648 4289769648 4291085508 4292335575 2829757098 1195064123 4267202648 4285098345 4289769648 4289769648 4289769648 4289769648 4289769648 4288848546 4282071876 4278387465 4278848048 4278716507 4278255999 4278650727 4278913856 4278584846 4282006084 4288980132 4289769648 4289769648 4291940817 4275624152 1299740792 33554432 3746516815 4283979864 4288980132 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4288980132 4287072135 4285295724 4283914071 4285032552 4286479998 4289243304 4289769648 4289769648 4289769648 4290230199 4292335575 3703356604 83886080 14684133 2102612819 4267202648 4285624689 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4291743438 4275558359 2089980562 14684133 14684133 33554432 2957856077 4283979864 4287466893 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4291019715 4292335575 2879628195 33554432 14684133 14684133 14684133 268435456 3444461134 4284243036 4288059030 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290756543 4292138196 3299716525 154613559 14684133 14684133 14684133 14684133 14684133 239618120 2706789974 4115747153 4286743170 4289703855 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289901234 4291282887 3955146430 2376114336 41975936 14684133 14684133 14684133 14684133 14684133 14684133 14684133 14684133 673588774 2706724181 3462356831 3446369131 4237398417 4221147545 4120484249 4103772826 4187593113 4087390368 3047860906 3098718898 2192157097 234881023 14684133 14684133 14684133 14684133 14684133) offset: 0@0)! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 1/21/2012 23:45'! classVarsUnselectedIcon ^ (Form extent: 24@24 depth: 32 fromArray: #(4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290032820 4292335575 3954620086 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290032820 4292335575 3954620086 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4288519581 4287006342 4287927444 4289309097 4289769648 4289769648 4289769648 4289769648 4289769648 4290032820 4292335575 3954620086 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4285756275 4280427042 4278716424 4279308561 4280492835 4279769112 4278584838 4280821800 4285361517 4289638062 4289769648 4289769648 4290032820 4292335575 3954620086 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4289769648 4288190616 4281084972 4280032284 4284440415 4286216826 4286611584 4286611584 4286611584 4286479998 4284111450 4279703319 4286282619 4289769648 4289769648 4290032820 4292335575 3954620086 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4289243304 4279571733 4282992969 4286545791 4286611584 4285822068 4283387727 4282006074 4282466625 4283716692 4286085240 4281413937 4285953654 4289769648 4289769648 4290032820 4292335575 3954620086 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4282927176 4281545523 4286611584 4286611584 4284045657 4279111182 4282335039 4284769380 4283979864 4281611316 4279045389 4279242768 4285953654 4289769648 4289769648 4290032820 4292335575 3954620086 4165947215 4283979864 4289572269 4289769648 4289769648 4288059030 4279111182 4286085240 4286611584 4285690482 4279045389 4287401100 4289769648 4289769648 4289769648 4289769648 4288322202 4283387727 4288453788 4289769648 4289769648 4290032820 4292335575 3954620086 4165947215 4283979864 4289572269 4289769648 4289769648 4285822068 4281282351 4286611584 4286611584 4281940281 4283519313 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290032820 4292335575 3954620086 4182724431 4283979864 4289572269 4289769648 4289769648 4283716692 4282532418 4286611584 4286611584 4280295456 4286874756 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290032820 4292335575 3954620086 4216344656 4283979864 4289572269 4289769648 4289769648 4281940281 4283716692 4286611584 4286611584 4279308561 4288453788 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290032820 4292335575 3988174518 4249899088 4283979864 4289572269 4289769648 4289769648 4283124555 4282927176 4286611584 4286611584 4279966491 4287335307 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290032820 4292335575 4122458039 4249964881 4283979864 4289572269 4289769648 4289769648 4285229931 4281677109 4286611584 4286611584 4281282351 4284769380 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290032820 4292335575 4189501110 4233253458 4284045657 4289638062 4289769648 4289769648 4287335307 4279834905 4286545791 4286611584 4284835173 4279440147 4221937061 4222660784 4222660784 4222660784 4272992432 4289638062 4286348412 4289374890 4289769648 4289769648 4289967027 4292335575 4155946678 3813362507 4283979864 4289309097 4289769648 4289769648 4289703855 4280953386 4282992969 4286611584 4286611584 4282335039 4279440147 4285295724 4287598479 4286874756 4284703587 4279834905 4278519045 4285953654 4289769648 4289769648 4290032820 4292335575 3669802172 3696448339 4283979864 4288651167 4289769648 4289769648 4289769648 4288256409 4279111182 4285098345 4286611584 4286611584 4284374622 4281413937 4280032284 4280492835 4281677109 4284506208 4281413937 4285953654 4289769648 4289769648 4290361785 4292335575 3602430136 2706789974 4283979864 4286940549 4289769648 4289769648 4289769648 4289769648 4286085240 4279111182 4282137660 4286216826 4286611584 4286611584 4286611584 4286611584 4286611584 4285953654 4280427042 4285953654 4289769648 4289769648 4291085508 4292335575 2829757098 1195064123 4267202648 4285098345 4289769648 4289769648 4289769648 4289769648 4289769648 4288848546 4282400832 4278584838 4280098077 4281413937 4282400832 4281808695 4280690214 4278848010 4282335039 4288980132 4289769648 4289769648 4291940817 4275624152 1299740792 33554432 3746516815 4283979864 4288980132 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4288980132 4287072135 4285295724 4283914071 4285032552 4286479998 4289243304 4289769648 4289769648 4289769648 4290230199 4292335575 3703356604 83886080 14684133 2102612819 4267202648 4285624689 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4291743438 4275558359 2089980562 14684133 14684133 33554432 2957856077 4283979864 4287466893 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4291019715 4292335575 2879628195 33554432 14684133 14684133 14684133 268435456 3444461134 4284243036 4288059030 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290756543 4292138196 3299716525 154613559 14684133 14684133 14684133 14684133 14684133 239618120 2706789974 4115747153 4286743170 4289703855 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289901234 4291282887 3955146430 2376114336 41975936 14684133 14684133 14684133 14684133 14684133 14684133 14684133 14684133 673588774 2706724181 3462356831 3446369131 4237398417 4221147545 4120484249 4103772826 4187593113 4087390368 3047860906 3098718898 2192157097 234881023 14684133 14684133 14684133 14684133 14684133) offset: 0@0)! ! !NautilusIcons methodsFor: 'icons' stamp: 'lr 3/29/2009 14:02'! collection ^ ((ColorForm extent: 12@12 depth: 8 fromArray: #( 168952850 171324982 909522486 255008812 271977989 285543990 706029348 70649368 724044854 254681884 271986469 689508662 135534100 137758237 890965046 909522486 909513472 436212534 909508866 151126326 909522486 909511457 807338806 909522486 909521969 841353526 909522486 909511458 504824630 909522486 909511943 755436854 909522486 909522486 909522486 909522486) offset: 0@0) colorsFromArray: #(#(0.565 0.764 0.538) #(0.992 0.98 0.934) #(0.957 0.879 0.549) #(0.953 0.867 0.514) #(1.0 0.569 0.286) #(0.577 0.772 0.553) #(0.557 0.761 0.53) #(0.957 0.875 0.538) #(1.0 0.949 0.914) #(0.937 0.827 0.369) #(1.0 0.953 0.922) #(0.953 0.871 0.53) #(0.542 0.753 0.518) #(0.992 0.98 0.926) #(0.937 0.965 0.934) #(1.0 0.678 0.466) #(1.0 0.667 0.451) #(0.408 0.678 0.372) #(1.0 0.694 0.494) #(0.93 0.961 0.926) #(1.0 0.682 0.478) #(0.918 0.631 0.447) #(1.0 0.557 0.271) #(0.848 0.757 0.384) #(0.545 0.745 0.506) #(0.561 0.686 0.522) #(0.392 0.671 0.357) #(0.466 0.659 0.423) #(0.887 0.53 0.298) #(0.514 0.71 0.474) #(0.807 0.737 0.458) #(0.887 0.796 0.423) #(0.91 0.628 0.443) #(0.93 0.84 0.466) #(0.894 0.804 0.435) #(0.831 0.553 0.372) #(0.823 0.542 0.357) #(0.643 0.772 0.604) #(0.804 0.733 0.443) #(0.871 0.588 0.408) #(0.498 0.698 0.462) #(0.612 0.733 0.573) #(1.0 0.577 0.306) #(0.639 0.764 0.6) #(0.926 0.569 0.337) #(0.937 0.823 0.353) #(0.937 0.581 0.349) #(0.419 0.686 0.388) #(0.883 0.811 0.53) #(0.894 0.823 0.534) #(0.848 0.776 0.494) #(0.973 0.612 0.38) #(0.941 0.831 0.384) #(0.573 0.694 0.534) #( ) ))! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 1/21/2012 23:33'! decompilePressedIcon ^ Form extent: 24 @ 24 depth: 32 fromArray: #(4244767234 4283979864 4287401100 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290690750 4292335575 4244898820 4244767234 4283979864 4287401100 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290690750 4292335575 4244898820 4244767234 4283979864 4287401100 4289769648 4289769648 4289572269 4284703587 4284308829 4284308829 4284308829 4284572001 4285164138 4285624689 4287072135 4289111718 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290690750 4292335575 4244898820 4244767234 4283979864 4287401100 4289769648 4289769648 4282927176 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278255873 4281282351 4286743170 4289769648 4289769648 4289769648 4289769648 4290690750 4292335575 4244898820 4244767234 4283979864 4287401100 4289769648 4289769648 4281479730 4278190080 4280246784 4280843520 4280843520 4280776960 4280512000 4280246528 4279516928 4278522112 4278190080 4278190080 4283256141 4289703855 4289769648 4289769648 4290690750 4292335575 4244898820 4244767234 4283979864 4287401100 4289769648 4289769648 4281479730 4278190080 4282103808 4283231488 4281108992 4279450368 4279782144 4280445696 4281705728 4283098624 4281175040 4278455041 4278190080 4284637794 4289769648 4289769648 4290690750 4292335575 4244898820 4244767234 4283979864 4287401100 4289769648 4289769648 4281479730 4278190080 4282103808 4282568448 4278190080 4278190080 4278190080 4278190080 4278190080 4279450368 4282833664 4281971200 4278190336 4278650887 4288322202 4289769648 4290690750 4292335575 4244898820 4244767234 4283979864 4287401100 4289769648 4289769648 4281479730 4278190080 4282103808 4282501632 4278190080 4280163870 4286677377 4284769380 4279571733 4278190080 4279914496 4283231488 4280379136 4278190080 4282598211 4289769648 4290690750 4292335575 4244898820 4244767234 4283979864 4287401100 4289769648 4289769648 4281479730 4278190080 4282103808 4282501632 4278190080 4280624421 4289769648 4289769648 4288848546 4279111182 4278190080 4282369280 4282567936 4278190080 4280163870 4289769648 4290690750 4292335575 4244898820 4244767234 4283979864 4287401100 4289769648 4289769648 4281479730 4278190080 4282103808 4282501632 4278190080 4280624421 4289769648 4289769648 4289769648 4282729797 4278190080 4281506560 4283165440 4278388736 4278453252 4289572269 4290690750 4292335575 4244898820 4244767234 4283979864 4287401100 4289769648 4289769648 4281479730 4278190080 4282103808 4282501632 4278190080 4280624421 4289769648 4289769648 4289769648 4283979864 4278190080 4280910080 4283231488 4278985728 4278190080 4288453788 4290690750 4292335575 4244898820 4244767234 4283979864 4287401100 4289769648 4289769648 4281479730 4278190080 4282103808 4282501632 4278190080 4280624421 4289769648 4289769648 4289769648 4282664004 4278190080 4281506816 4283165440 4278388736 4278453252 4289572269 4290690750 4292335575 4244898820 4244767234 4283979864 4287401100 4289769648 4289769648 4281479730 4278190080 4282103808 4282501632 4278190080 4280624421 4289769648 4289769648 4288651167 4278979596 4278190080 4282435328 4282567936 4278190080 4280163870 4289769648 4290690750 4292335575 4244898820 4244767234 4284572001 4287466893 4289769648 4289769648 4281479730 4278190080 4282103808 4282501632 4278190080 4246543645 4118773631 4167065696 4262597138 4278190080 4279981312 4283231488 4280379136 4278190080 4282598211 4289769648 4290559164 4292138196 4244898820 4110681092 4283716692 4286940549 4289769648 4289769648 4281479730 4278190080 4282103808 4282568448 4278190080 4278190080 4278190080 4278190080 4278190080 4279582976 4282899712 4282036992 4278256128 4278650887 4288322202 4289769648 4290756543 4291480266 4111207436 3691645450 4282664004 4286085240 4289769648 4289769648 4281479730 4278190080 4282103808 4283231488 4281108992 4279450368 4279781888 4280445440 4281705984 4283098624 4281175040 4278388992 4278190080 4284637794 4289769648 4289769648 4291085508 4289703855 3826915866 2147615234 4196869927 4284440415 4289703855 4289769648 4281479730 4278190080 4280246784 4280843520 4280843520 4280776960 4280512000 4280246528 4279516928 4278522112 4278190080 4278190080 4283256141 4289703855 4289769648 4289769648 4291940817 4271018642 3037662991 738197504 4111075850 4283979864 4288387995 4289769648 4282927176 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278255873 4281348144 4286743170 4289769648 4289769648 4289769648 4290164406 4292335575 4047388222 1728053248 14684133 3875931654 4282729797 4286151033 4289769648 4289572269 4284703587 4284308829 4284308829 4284308829 4284572001 4285164138 4285690482 4287072135 4289111718 4289769648 4289769648 4289769648 4289769648 4289769648 4291217094 4290756543 4060809995 150994944 14684133 1375731712 4061204753 4283914071 4288190616 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290361785 4292138196 4097193526 2064058119 14684133 14684133 14684133 2986541827 4078968864 4284572001 4289374890 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289901234 4291875024 4149367378 2987133964 16777216 14684133 14684133 14684133 134217728 3188065798 4162591772 4283979864 4288848546 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290230199 4289374890 4213844522 3205632530 117440512 14684133 14684133 14684133 14684133 14684133 67108864 2147681027 4093969669 4179632160 4284308829 4287203721 4289177511 4289769648 4289769648 4289769648 4289769648 4289374890 4287861651 4284637794 4213449764 4010807312 1594427657 14684133 14684133 14684133 14684133 14684133 14684133 14684133 14684133 14684133 167772160 1862599941 3255964178 3741911305 4161210119 4228055811 4227990018 4227990018 4228055811 4177921542 3708751631 2602573856 839387144 14684133 14684133 14684133 14684133 14684133 14684133) offset: 0 @ 0! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 1/21/2012 21:44'! decompileSelectedIcon ^ (Form extent: 24@24 depth: 32 fromArray: #(4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4292335575 3939487695 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4292335575 3939487695 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4292335575 3939487695 4165947215 4283979864 4289572269 4289769648 4289769648 4285624689 4278256129 4278387970 4278387970 4278453763 4278387970 4278651397 4279046922 4280692769 4282993991 4287137928 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4292335575 3939487695 4165947215 4283979864 4289572269 4289769648 4289769648 4284111450 4280644353 4283231488 4283231488 4283231488 4283231232 4283032320 4282767104 4282037504 4281041921 4279379209 4280955430 4288651167 4289769648 4289769648 4289769648 4289769648 4292335575 3939487695 4165947215 4283979864 4289572269 4289769648 4289769648 4284111450 4280644353 4283231488 4283231488 4282767104 4282104064 4282435840 4283098880 4283231488 4283231488 4283231232 4280908291 4279375887 4289045925 4289769648 4289769648 4289769648 4292335575 3939487695 4165947215 4283979864 4289572269 4289769648 4289769648 4284111450 4280644353 4283231488 4283231488 4279577865 4280297500 4279771412 4278454019 4280042505 4282435584 4283231488 4283231488 4280508934 4282336316 4289769648 4289769648 4289769648 4292335575 3939487695 4165947215 4283979864 4289572269 4289769648 4289769648 4284111450 4280644353 4283231488 4283231488 4279444746 4287795858 4289769648 4289572269 4284703842 4278784006 4282568448 4283231488 4283032320 4279180552 4286940549 4289769648 4289769648 4292335575 3939487695 4165947215 4283979864 4289572269 4289769648 4289769648 4284111450 4280644353 4283231488 4283231488 4279444746 4287795858 4289769648 4289769648 4289769648 4284309339 4280175624 4283231488 4283231488 4280642818 4283980119 4289769648 4289769648 4292335575 3939487695 4182790224 4283979864 4289572269 4289769648 4289769648 4284111450 4280644353 4283231488 4283231488 4279444746 4287795858 4289769648 4289769648 4289769648 4288782753 4278850566 4283231488 4283231488 4281440768 4281810739 4289769648 4289769648 4292335575 3939487695 4216344656 4283979864 4289572269 4289769648 4289769648 4284111450 4280644353 4283231488 4283231488 4279444746 4287795858 4289769648 4289769648 4289769648 4289769648 4278454019 4283032320 4283231488 4282302464 4280100633 4289769648 4289769648 4292335575 3973042127 4249964881 4283979864 4289572269 4289769648 4289769648 4284111450 4280644353 4283231488 4283231488 4279444746 4287795858 4289769648 4289769648 4289769648 4289111718 4278651908 4283231488 4283231488 4281705728 4281284651 4289769648 4289769648 4292335575 4090416846 4249964881 4283979864 4289572269 4289769648 4289769648 4284111450 4280644353 4283231488 4283231488 4279444746 4287795858 4289769648 4289769648 4289769648 4285888117 4279777545 4283231488 4283231488 4280842753 4283454031 4289769648 4289769648 4292335575 4174237133 4250030674 4284045657 4289638062 4289769648 4289769648 4284111450 4280644353 4283231488 4283231488 4279444746 4237464210 4222660784 4222660784 4237069452 4279244556 4282104064 4283231488 4283231232 4279644936 4285887861 4289769648 4289769648 4292335575 4157394124 3813296714 4283979864 4289309097 4289769648 4289769648 4284111450 4280644353 4283231488 4283231488 4279445002 4282598722 4282402365 4280429342 4278916358 4281572609 4283231488 4283231488 4281108225 4280494880 4289703855 4289769648 4289901234 4292335575 3654209230 3696448339 4283979864 4288651167 4289769648 4289769648 4284111450 4280644353 4283231488 4283231488 4281904896 4280843520 4281175296 4281905152 4283032320 4283231488 4283231488 4281970944 4278783494 4287993237 4289769648 4289769648 4290230199 4292335575 3603482824 2706789974 4283979864 4286940549 4289769648 4289769648 4284111450 4280644353 4283231488 4283231488 4283231488 4283231488 4283231488 4283231488 4283164928 4282236416 4280441607 4279178508 4286743170 4289769648 4289769648 4289769648 4290953922 4292335575 2847455416 1195064123 4267202648 4285098345 4289769648 4289769648 4284506208 4279048966 4279842571 4279842571 4279842571 4279709963 4279445002 4279180553 4278585604 4279968791 4284309084 4288914339 4289769648 4289769648 4289769648 4289769648 4291743438 4275624152 1267699599 33554432 3746516815 4283979864 4288980132 4289769648 4289440683 4286940549 4286874756 4286874756 4286940549 4287203721 4287730065 4288256409 4289572269 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290032820 4292335575 3721252301 50331648 16777215 2102612819 4267202648 4285624689 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4291480266 4275558359 2107876259 16777215 16777215 33554432 2957856077 4283979864 4287466893 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290624957 4292335575 2880944055 16777216 16777215 16777215 16777215 268435456 3444461134 4284243036 4288059030 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290427578 4292138196 3300966592 174548839 16777215 16777215 16777215 16777215 16777215 239618120 2706855767 4099035730 4286743170 4289703855 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290953922 3939487695 2461118897 50331647 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 640297514 2656524119 3462422624 3429591915 4237398417 4221147545 4120484249 4120484249 4187593113 4070481566 2998055602 3065888189 2176564155 352321535 16777215 16777215 16777215 16777215 16777215) offset: 0@0)! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 1/21/2012 21:45'! decompileUnselectedIcon ^ (Form extent: 24@24 depth: 32 fromArray: #(4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4292335575 3939487695 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4292335575 3939487695 4165947215 4283979864 4289572269 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4292335575 3939487695 4165947215 4283979864 4289572269 4289769648 4289769648 4285624689 4278321666 4278453252 4278453252 4278519045 4278387459 4278716424 4279176975 4280887593 4283058762 4287137928 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4292335575 3939487695 4165947215 4283979864 4289572269 4289769648 4289769648 4284111450 4282269246 4286611584 4286611584 4286611584 4286545791 4286216826 4285822068 4284637794 4282927176 4279769112 4281084972 4288651167 4289769648 4289769648 4289769648 4289769648 4292335575 3939487695 4165947215 4283979864 4289572269 4289769648 4289769648 4284111450 4282269246 4286611584 4286611584 4285822068 4284769380 4285295724 4286414205 4286611584 4286611584 4286545791 4282598211 4279505940 4289045925 4289769648 4289769648 4289769648 4292335575 3939487695 4165947215 4283979864 4289572269 4289769648 4289769648 4284111450 4282269246 4286611584 4286611584 4280098077 4280492835 4279966491 4278519045 4280887593 4285295724 4286611584 4286611584 4281874488 4282466625 4289769648 4289769648 4289769648 4292335575 3939487695 4165947215 4283979864 4289572269 4289769648 4289769648 4284111450 4282269246 4286611584 4286611584 4279834905 4287795858 4289769648 4289572269 4284703587 4278979596 4285558896 4286611584 4286216826 4279440147 4286940549 4289769648 4289769648 4292335575 3939487695 4165947215 4283979864 4289572269 4289769648 4289769648 4284111450 4282269246 4286611584 4286611584 4279834905 4287795858 4289769648 4289769648 4289769648 4284374622 4281150765 4286611584 4286611584 4282137660 4283979864 4289769648 4289769648 4292335575 3939487695 4182790224 4283979864 4289572269 4289769648 4289769648 4284111450 4282269246 4286611584 4286611584 4279834905 4287795858 4289769648 4289769648 4289769648 4288782753 4279045389 4286611584 4286611584 4283650899 4281940281 4289769648 4289769648 4292335575 3939487695 4216344656 4283979864 4289572269 4289769648 4289769648 4284111450 4282269246 4286611584 4286611584 4279834905 4287795858 4289769648 4289769648 4289769648 4289769648 4278519045 4286216826 4286611584 4285032552 4280295456 4289769648 4289769648 4292335575 3973042127 4249964881 4283979864 4289572269 4289769648 4289769648 4284111450 4282269246 4286611584 4286611584 4279834905 4287795858 4289769648 4289769648 4289769648 4289111718 4278716424 4286611584 4286611584 4284045657 4281479730 4289769648 4289769648 4292335575 4090416846 4249964881 4283979864 4289572269 4289769648 4289769648 4284111450 4282269246 4286611584 4286611584 4279834905 4287795858 4289769648 4289769648 4289769648 4285953654 4280492835 4286611584 4286611584 4282532418 4283519313 4289769648 4289769648 4292335575 4174237133 4250030674 4284045657 4289638062 4289769648 4289769648 4284111450 4282269246 4286611584 4286611584 4279834905 4237464210 4222660784 4222660784 4237069452 4279374354 4284769380 4286611584 4286545791 4280229663 4285887861 4289769648 4289769648 4292335575 4157394124 3813296714 4283979864 4289309097 4289769648 4289769648 4284111450 4282269246 4286611584 4286611584 4279834905 4282664004 4282532418 4280624421 4279111182 4283782485 4286611584 4286611584 4283058762 4280690214 4289703855 4289769648 4289901234 4292335575 3654209230 3696448339 4283979864 4288651167 4289769648 4289769648 4284111450 4282269246 4286611584 4286611584 4284374622 4282664004 4283190348 4284440415 4286216826 4286611584 4286611584 4284440415 4278848010 4287993237 4289769648 4289769648 4290230199 4292335575 3603482824 2706789974 4283979864 4286940549 4289769648 4289769648 4284111450 4282269246 4286611584 4286611584 4286611584 4286611584 4286611584 4286611584 4286479998 4284900966 4281611316 4279308561 4286743170 4289769648 4289769648 4289769648 4290953922 4292335575 2847455416 1195064123 4267202648 4285098345 4289769648 4289769648 4284506208 4279374354 4280492835 4280492835 4280492835 4280229663 4279834905 4279505940 4278650631 4280163870 4284308829 4288914339 4289769648 4289769648 4289769648 4289769648 4291743438 4275624152 1267699599 33554432 3746516815 4283979864 4288980132 4289769648 4289440683 4286940549 4286874756 4286874756 4286940549 4287203721 4287730065 4288256409 4289572269 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290032820 4292335575 3721252301 50331648 16777215 2102612819 4267202648 4285624689 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4291480266 4275558359 2107876259 16777215 16777215 33554432 2957856077 4283979864 4287466893 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290624957 4292335575 2880944055 16777216 16777215 16777215 16777215 268435456 3444461134 4284243036 4288059030 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290427578 4292138196 3300966592 174548839 16777215 16777215 16777215 16777215 16777215 239618120 2706855767 4099035730 4286743170 4289703855 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290953922 3939487695 2461118897 50331647 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 640297514 2656524119 3462422624 3429591915 4237398417 4221147545 4120484249 4120484249 4187593113 4070481566 2998055602 3065888189 2176564155 352321535 16777215 16777215 16777215 16777215 16777215) offset: 0@0)! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 2/21/2012 02:37'! dirtyMonticelloPackageIcon ^ (Form extent: 16@16 depth: 32 fromArray: #(16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 722731779 2235369994 3106932744 3394768655 301989888 16777215 16777215 100663296 2707033871 2689666317 3240297990 16777215 16777215 16777215 1985285646 3527478027 3207858441 3040217353 3577022729 4241039649 1496975882 16777215 673974023 3692692484 4156563488 3157854473 3023636745 16777215 16777215 16777215 1817054477 2200963080 16777215 2725122578 2859602707 3583055896 2674987795 959645704 3609199877 2486634761 4021558814 3257271814 924976646 16777215 16777215 16777215 16777215 33554432 16777215 3381204759 2169310477 2792296978 3464303893 3642819845 268435456 2943750931 3279885589 3408004614 16777215 16777215 16777215 16777215 16777215 16777215 706675973 3967620373 606012677 2186087693 4105248029 857801989 50331648 3667007512 2487290635 3207399175 16777215 16777215 16777215 16777215 16777215 16777215 2438729487 3094811668 16777215 3375040263 4088405277 503316480 975635974 4171504411 2350777605 2285767178 16777215 16777215 16777215 16777215 16777215 150994944 3715371795 1564477962 1598294795 3324184070 4189134109 1278085128 1984236299 3750762520 2721778186 1092551941 16777215 16777215 16777215 16777215 16777215 2270104845 3278114832 16777216 3593209607 1124598017 4120516889 637927681 2355040272 3246396693 3240625927 167772160 16777215 16777216 16777215 16777215 959908105 3747549200 858916872 1093601288 3023702538 1782516234 3598915094 33554432 2590839314 2910327828 3357607173 16777215 16777215 2065368068 16777215 1278806281 3612675598 1682771213 16777215 2605059084 1664682249 3026587921 2371227150 16777215 2506625297 2472874257 3324052741 33554432 16777215 2721253384 3694200840 3444116492 1296042506 16777215 16777215 1950485259 3693544966 3376548619 100663296 83886080 3259763981 3727624200 3927376900 3726115844 689570820 16777215 67108864 16777215 16777215 16777215 16777215 16777215 637534208 33554432 16777215 639042564 3056273159 67108864 538248196 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215) offset: 0@0)! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 3/31/2011 17:27'! dirtyPackageIcon ^ (Form extent: 15@16 depth: 32 fromArray: #(16777215 16777215 16777215 16777215 16777215 16777215 55924053 417994005 50331647 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 33554432 465965843 3031638305 3903537987 3402577205 1055007009 55924053 16777215 16777215 16777215 16777215 16777215 16777215 33554432 211096853 2898203925 3903533104 4286542707 4286545791 4286874242 4037368410 3520342827 602025004 75530368 16777215 16777215 16777215 67108864 1907822094 3651740708 4254094677 4107417399 4122498132 4286807935 4189741923 4141438293 4238769019 3970982755 2898412355 399008868 41975936 50331648 3569165862 4155256623 4285098345 4285690482 4286019447 4239415384 4242881853 4191310675 4287269514 4287730065 4288848546 4290879648 4140590437 212511402 16777215 3417454134 4220740451 4173088326 4254618194 4106502465 4123936326 4287004286 4189741923 4141438550 4239162492 4191255676 4207711637 4057304204 284159983 16777215 3433903670 4285164138 4285754990 4240068945 4190259015 4287196782 4286545791 4286939521 4173685089 4258814040 4288185990 4288585374 3989996162 234881023 16777215 3618122282 4284571744 4285032552 4154738503 4286280049 4189085535 4190129742 4173682262 4220874350 4123479116 4286743170 4287269514 3990118753 150994943 16777215 3751747873 4218959157 4235610184 4170400322 4285229931 4285558896 4257240919 4285493103 4285822068 4123411524 4288113515 4107945542 4091689787 83886079 16777215 3548454687 4282203453 4233968957 4270077237 4285551186 4284966759 4290072142 4285229931 4286277479 4242418475 4123019079 4286609271 3854453836 83886079 16777216 3664647188 4280756007 4281742902 4284427822 4285086523 4286790202 4289611848 4290390056 4290652200 4291308588 4285690482 4285953654 3870967366 67108863 117440512 3313569037 4263906830 4280163613 4282654238 4282203453 4283319878 4289282112 4286729806 4284900966 4290194476 4285361517 4253703003 3486721317 41975936 16777216 134217728 1603340296 4016639245 4281337864 4280690214 4281611316 4287577405 4284835173 4284835173 4239861543 3820561958 2127435286 75513920 16777215 16777215 16777215 33554432 218103808 2543520266 4149480717 4280424986 4286460980 4285292640 4004129836 2832208402 296026112 16777215 16777215 16777215 16777215 16777215 16777215 16777215 50331648 372899840 3012103437 4187497251 3083409432 565772288 16777216 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 83886080 134217728 33554432 16777215 16777215 16777215 16777215 16777215 16777215) offset: 0@0)! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 5/11/2011 14:41'! down ^(Form extent: 24@24 depth: 32 fromArray: #(16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 251658240 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 251658240 16777215 16777215 16777215 16777215 16777215 1293352960 3894738944 1847590912 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1847590912 3894738944 1293352960 16777215 16777215 16777215 991559680 3846701056 4291952640 3915644928 1562247168 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1562247168 3915644928 4291952640 3846701056 991559680 16777215 16777215 554172416 3694657536 4291624960 4292083712 3881107456 1276837888 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1276837888 3881107456 4292083712 4291624960 3694657536 554172416 16777215 16777215 16777215 738983936 3745382400 4291821568 4292018176 3830054912 1008336896 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1008336896 3830054912 4292018176 4291821568 3745382400 738983936 16777215 16777215 16777215 16777215 16777215 906887168 3796172800 4291952640 4291887104 3779002368 772472832 16777215 16777215 16777215 16777215 16777215 16777215 772472832 3779002368 4291887104 4291952640 3796172800 906887168 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1125318656 3830317056 4292083712 4291690496 3728211968 570949632 16777215 16777215 16777215 16777215 570949632 3728211968 4291690496 4292083712 3830317056 1125318656 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1343881216 3864592384 4292083712 4291428352 3660644352 402653184 16777215 16777215 402653184 3660644352 4291428352 4292083712 3864592384 1343881216 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1595604992 3898867712 4292083712 4291035136 3559718912 285212672 285212672 3559718912 4291035136 4292083712 3898867712 1595604992 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1847459840 3949985792 4292083712 4290641920 3458793472 3458793472 4290641920 4292083712 3949985792 1847459840 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 2115895296 4001169408 4292083712 4273733632 4273733632 4292083712 4001169408 2115895296 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 2367619072 4035510272 4292083712 4292083712 4035510272 2367619072 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 2602500096 4103340032 4103340032 2602500096 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 2770337792 2770337792 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215) offset: 0@0)! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 5/11/2011 14:42'! downFull ^(Form extent: 24@24 depth: 32 fromArray: #(16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 251658240 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 251658240 16777215 16777215 16777215 16777215 16777215 1293352960 3894738944 1847590912 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1847590912 3894738944 1293352960 16777215 16777215 16777215 991559680 3846701056 4291952640 3915644928 1562247168 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1562247168 3915644928 4291952640 3846701056 991559680 16777215 16777215 554172416 3694657536 4291624960 4292083712 3881107456 1276837888 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1276837888 3881107456 4292083712 4291624960 3694657536 554172416 16777215 16777215 16777215 738983936 3745382400 4291821568 4292018176 3830054912 1008336896 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1008336896 3830054912 4292018176 4291821568 3745382400 738983936 16777215 16777215 16777215 16777215 16777215 906887168 3796172800 4291952640 4291887104 3779002368 772472832 16777215 16777215 16777215 16777215 16777215 16777215 772472832 3779002368 4291887104 4291952640 3796172800 906887168 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1125318656 3830317056 4292083712 4291690496 3728211968 570949632 16777215 16777215 16777215 16777215 570949632 3728211968 4291690496 4292083712 3830317056 1125318656 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1343881216 3864592384 4292083712 4291428352 3660644352 402653184 16777215 16777215 402653184 3660644352 4291428352 4292083712 3864592384 1343881216 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1595604992 3898867712 4292083712 4291035136 3559718912 285212672 285212672 3559718912 4291035136 4292083712 3898867712 1595604992 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1847459840 3949985792 4292083712 4290641920 3458793472 3458793472 4290641920 4292083712 3949985792 1847459840 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 2115895296 4001169408 4292083712 4273733632 4273733632 4292083712 4001169408 2115895296 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 2367619072 4035510272 4292083712 4292083712 4035510272 2367619072 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 2602500096 4103340032 4103340032 2602500096 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1260322816 3089432576 3089432576 3089432576 3089432576 3089432576 3089432576 3089432576 3089432576 3089432576 3861184512 3861184512 3089432576 3089432576 3089432576 3089432576 3089432576 3089432576 3089432576 3089432576 3089432576 1260322816 16777215 16777215 2552365056 4290772992 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4290772992 2552365056 16777215 16777215 2552365056 4290772992 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4290772992 2552365056 16777215 16777215 2552365056 4290772992 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4292083712 4290772992 2552365056 16777215 16777215 1260322816 3089432576 3089432576 3089432576 3089432576 3089432576 3089432576 3089432576 3089432576 3089432576 3089432576 3089432576 3089432576 3089432576 3089432576 3089432576 3089432576 3089432576 3089432576 3089432576 3089432576 1260322816 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215) offset: 0@0)! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 4/7/2011 19:12'! emptyPackageIcon ^ (Form extent: 14@16 depth: 32 fromArray: #(16777215 16777215 16777215 16777215 16777215 33554432 61516458 61516458 16777216 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777216 87241523 1012027986 3211488107 2927262330 613125003 61516458 16777216 16777215 16777215 16777215 16777215 16777216 50331648 541344836 2539346779 4201672816 3530321004 3782637174 4135353468 2407102841 379099288 93952409 16777215 16777215 16777216 252710928 2085704017 3966002276 3344982112 1582519123 109084800 290147147 2070637419 3783097725 3968502410 2323677312 243302528 16777215 67108864 3277478490 4284900966 3797769565 1330071367 138428480 55924053 55924053 208300650 1919576682 4170421139 4272795053 3348008590 164021958 16777215 4134366573 3848824679 3781979244 3681644913 2992857955 1280463442 1365139038 3128325750 3868036493 3851916950 3970081185 3937382319 234881023 16777215 4150749031 3966528620 4268715887 3698224750 4017452405 4252728187 4252991359 3951396229 3599140229 4287203721 4137722016 3903498922 218103807 16777215 4099562074 1684300900 1802004584 3899617135 4184829807 3648550775 3598745471 4202330746 3598548349 1754567828 2492896918 3700790677 150994943 16777215 4047980359 1599625304 16777215 158429553 3261885548 4151604340 4286019190 2557768820 264027324 117440511 2055570821 3531768450 83886079 16777215 4197725236 1750028111 16777215 16777215 2741265508 4167921005 4285756018 1466986608 33554431 50331647 2172419196 3715857275 83886079 16777215 4212989213 3627431478 826820680 16777215 2673235542 3982516063 3698356079 1248422249 16777215 510553710 3178460019 3698816887 67108863 16777215 2586586156 4195751446 4247004196 3091218496 3209185352 4166078544 4235095405 1432774246 2003331176 4134234987 3849351280 1601993852 33554431 16777215 16777215 473183284 3274123047 4263123482 4280953386 4215094589 4285427053 4167394661 3831981927 2188077931 244486802 33554431 16777215 16777215 16777215 16777215 16777215 1093874483 3760267553 4213581093 4268649837 2758108517 492921185 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1832598331 1014528120 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215) offset: 0@0)! ! !NautilusIcons methodsFor: 'icons' stamp: 'lr 3/29/2009 14:10'! exception ^ ((ColorForm extent: 12@12 depth: 8 fromArray: #( 1583238196 1191577949 759500554 1583225870 390089009 36066088 1578711384 857557019 906518110 1581393173 991970905 1549688414 722677332 570761514 1583242846 1327383559 1091971346 5322527 792346372 337270359 1297099812 1011548469 286015067 654532190 1583242842 941838926 1432247902 1583242763 221384798 1583242846 1583224899 1029594718 1583242846 1583231050 1583242846 1583242846) offset: 0@0) colorsFromArray: #(#(0.906 0.764 0.392) #(0.945 0.867 0.6) #(0.918 0.776 0.306) #(0.969 0.922 0.815) #(0.945 0.831 0.443) #(0.953 0.84 0.443) #(0.934 0.823 0.388) #(0.953 0.819 0.286) #(0.98 0.949 0.855) #(0.93 0.815 0.376) #(0.992 0.98 0.941) #(0.894 0.733 0.302) #(0.945 0.792 0.4) #(0.898 0.725 0.286) #(0.949 0.863 0.423) #(0.965 0.91 0.737) #(0.984 0.961 0.906) #(0.914 0.772 0.365) #(0.91 0.768 0.384) #(0.941 0.844 0.415) #(0.953 0.844 0.498) #(0.965 0.871 0.4) #(0.953 0.836 0.474) #(0.945 0.859 0.439) #(0.949 0.867 0.651) #(0.988 0.965 0.867) #(0.949 0.815 0.455) #(0.957 0.855 0.542) #(0.953 0.875 0.514) #(0.957 0.836 0.341) #(0.953 0.867 0.474) #(0.914 0.78 0.474) #(0.945 0.8 0.263) #(0.934 0.811 0.431) #(0.941 0.792 0.216) #(0.93 0.788 0.443) #(0.965 0.914 0.796) #(0.965 0.891 0.51) #(0.898 0.733 0.22) #(0.906 0.764 0.435) #(0.992 0.984 0.953) #(0.898 0.737 0.275) #(0.957 0.894 0.71) #(0.992 0.977 0.914) #(0.926 0.815 0.569) #(0.918 0.788 0.333) #(0.973 0.902 0.561) #(0.918 0.788 0.286) #(0.957 0.891 0.725) #(0.937 0.815 0.396) #(0.902 0.757 0.396) #(0.965 0.867 0.369) #(0.937 0.84 0.384) #(0.934 0.836 0.526) #(0.91 0.764 0.306) #(0.887 0.721 0.333) #(0.914 0.764 0.357) #(0.941 0.855 0.412) #(0.949 0.855 0.462) #(0.949 0.811 0.232) #(0.957 0.891 0.635) #(0.945 0.863 0.659) #(0.941 0.776 0.408) #(0.953 0.855 0.474) #(0.945 0.844 0.427) #(0.941 0.78 0.236) #(0.957 0.891 0.608) #(0.875 0.69 0.216) #(0.969 0.883 0.451) #(0.906 0.761 0.286) #(0.957 0.848 0.498) #(0.934 0.836 0.396) #(0.961 0.84 0.415) #(0.941 0.831 0.408) #(0.977 0.941 0.855) #(0.949 0.875 0.604) #(0.965 0.91 0.655) #(0.922 0.757 0.404) #(0.941 0.851 0.635) #(0.965 0.914 0.698) #(0.879 0.69 0.247) #(0.898 0.741 0.353) #(0.891 0.717 0.302) #(0.973 0.934 0.804) #(0.953 0.831 0.279) #(1.0 0.996 0.992) #(0.941 0.796 0.443) #(0.941 0.804 0.486) #(0.98 0.922 0.573) #(0.914 0.772 0.345) #(0.98 0.945 0.859) #(0.902 0.725 0.322) #(0.969 0.918 0.772) #(0.926 0.8 0.357) #( ) ))! ! !NautilusIcons methodsFor: 'icons' stamp: 'lr 8/2/2007 19:32'! flag ^ ((ColorForm extent: 12@12 depth: 8 fromArray: #( 437918234 437918234 437918234 436470535 101584139 387389210 436404481 17105924 303634202 436666638 218827016 35198490 437126412 185075720 1644314 437060363 168298504 1644570 436930320 269422351 370743322 437326099 320082453 387520538 437918234 437918234 387520538 454761243 454761242 387520538 454761243 454761242 387520282 454761243 454761242 387389210) offset: 0@0) colorsFromArray: #(#(0.22 0.396 0.585) #(0.898 0.945 0.996) #(0.228 0.498 0.761) #(0.608 0.796 0.98) #(0.635 0.804 0.98) #(0.655 0.819 0.98) #(0.47 0.729 0.973) #(0.542 0.768 0.977) #(0.251 0.631 0.961) #(0.267 0.639 0.961) #(0.275 0.643 0.961) #(0.286 0.647 0.961) #(0.302 0.659 0.965) #(0.326 0.667 0.965) #(0.353 0.678 0.965) #(0.396 0.714 0.965) #(0.419 0.729 0.969) #(0.239 0.686 0.93) #(0.243 0.624 0.772) #(0.236 0.682 0.851) #(0.228 0.667 0.788) #(0.224 0.616 0.671) #(0.384 0.228 0.082) #(0.349 0.212 0.098) #(0.329 0.2 0.094) #(0.694 0.462 0.271) #(1.0 1.0 1.0) #( )))! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 4/6/2011 18:50'! greenArrowUpAndDown ^ Form extent: 9@15 depth: 32 fromArray: #(16777215 16777215 16777215 906042112 3791859456 906042112 16777215 16777215 16777215 16777215 16777215 268435456 3557049600 4278962432 3557049600 268435456 16777215 16777215 16777215 16777216 3137548288 4278894336 4278962688 4278894336 3137548288 16777216 16777215 16777215 2348951296 4161381376 4278962688 4278962688 4278962688 4161381376 2348951296 16777215 1342316032 3926358272 4278962688 4278962688 4278962688 4278962688 4278962688 3926358272 1342316032 3858831104 3842402048 3842402048 4262115584 4278962688 4262115584 3842402048 3842402048 3858831104 251658240 268435456 1140850688 4194866688 4278962688 4194866688 1140850688 268435456 251658240 16777215 16777215 939524096 4194866688 4278962688 4194866688 939524096 16777215 16777215 251658240 268435456 1140850688 4194866688 4278962688 4194866688 1140850688 268435456 251658240 3858831104 3842402048 3842402048 4262115584 4278962688 4262115584 3842402048 3842402048 3858831104 1342316032 3926358272 4278962688 4278962688 4278962688 4278962688 4278962688 3926358272 1342316032 16777215 2348951296 4161381376 4278962688 4278962688 4278962688 4161381376 2348951296 16777215 16777215 16777216 3137548288 4278894336 4278962688 4278894336 3137548288 16777216 16777215 16777215 16777215 268435456 3557049600 4278962432 3557049600 268435456 16777215 16777215 16777215 16777215 16777215 906042112 3791859456 906042112 16777215 16777215 16777215) offset: 0@0! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 4/1/2011 15:26'! groupIcon ^ (Form extent: 15@16 depth: 32 fromArray: #(16777215 16777215 16777215 16777215 16777215 16777215 741343023 3275816768 3075604305 610139997 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 206881045 2468937512 4198039352 4282777413 4283629394 4133486431 2422472547 160417763 16777215 16777215 16777215 16777215 16777215 16777215 1593774888 3892256563 3483734080 3963682109 4282777413 4283563857 3915905900 3816339156 3866464511 1668517887 16777215 16777215 16777215 704196930 3271492893 4294906665 4294909748 4294913088 4143399757 3482178394 3546861469 4234117372 4285237503 4286026495 4286881023 3448151551 544905471 16777215 2212050759 3705883738 3892062268 4294909748 4261359168 3506413903 4043306825 3959223899 3718624710 4285237503 4286026495 3933375999 3813831421 1295737599 16777215 2261264440 4291180100 4225057616 3505218398 3640584759 4294965305 4294965317 4294965585 4294965598 3673156994 3613359861 4248921854 4282673663 1329686527 16777215 2327257906 4289868607 4290721090 3821495878 4041136203 3623152977 4294965316 4261411153 3623876694 4110415943 4015421164 4283133695 4283988479 1397584383 16777215 2255301983 4187107390 4289344061 3887095105 4291281462 4292070714 4007252563 3942249295 4294965308 4294965575 4050224622 4284448511 4068575729 1386704574 16777215 2467771800 4146608763 3898423902 3969339963 4289900083 4290820917 4274767168 4294965068 4294965582 4294965594 4051670252 3704655548 4194271886 1526686578 16777215 2567710594 4279970659 4280431990 4180689000 4269180974 4289439538 4290491968 4294965343 4294965602 4173456753 4058746767 4294936466 4294939806 1593798010 67108864 2919241572 4278982722 4279641432 4280168537 4280713254 4282219052 4288322877 4292864882 4286898294 4286775170 4276918936 4294941604 4294944944 1694069631 83886080 1879052875 4177530951 4278653495 4279377983 4279984923 4280448802 4282093368 4287035781 4287299466 4288151447 4277119914 4294946743 3824456348 669148016 16777216 150994944 587202568 3288339543 4227928107 4279059213 4279654422 4281433136 4288216727 4288610206 4289462187 4109085865 2195417203 150994944 16777216 16777215 16777215 33554432 234881024 1207970826 3858781696 4278664199 4280771878 4289396393 4255841706 3111708280 407587627 33554432 16777215 16777215 16777215 16777215 16777215 16777215 67108864 352321536 2046839040 4028261914 3734040464 1028699728 67108864 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777216 117440512 251658240 117440512 16777216 16777215 16777215 16777215 16777215 16777215) offset: 0@0)! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 1/24/2013 11:37'! haltIcon ^ ((ColorForm extent: 12@12 depth: 8 fromArray: #( 437918234 437918234 437918234 437654804 319885069 26 437590295 404100630 100859930 437524241 269290764 100860442 437327375 235736076 67305498 437261581 218893324 67305754 437130258 303174162 84082970 436931081 134678279 196890 437918234 437918234 196890 454761243 454761242 196890 454761243 454761242 196634 454761243 454761242 26) offset: 0@0) colorsFromArray: #(#(0.349 0.212 0.098) #(0.329 0.2 0.094) #(0.376 0.232 0.109) #(0.694 0.462 0.271) #(0.608 0.271 0.204) #(0.545 0.185 0.113) #(0.784 0.322 0.294) #(0.721 0.023 0.023) #(0.788 0.055 0.055) #(0.848 0.106 0.106) #(0.875 0.137 0.137) #(0.914 0.208 0.208) #(0.953 0.298 0.298) #(0.953 0.318 0.318) #(0.953 0.333 0.333) #(0.953 0.349 0.349) #(0.953 0.365 0.365) #(0.953 0.388 0.388) #(0.922 0.427 0.427) #(0.953 0.482 0.482) #(0.949 0.542 0.538) #(0.957 0.592 0.592) #(0.953 0.624 0.62) #(0.984 0.879 0.879) #(0.988 0.898 0.898) #(0.992 0.918 0.918) #(1.0 1.0 1.0) #( )))! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 1/21/2012 23:49'! instVarsPressedIcon ^ (Form extent: 24@24 depth: 32 fromArray: #(14684133 14684133 14684133 14684133 14684133 167772160 1862599941 3255964178 3741911305 4161210119 4228055811 4227990018 4227990018 4228055811 4177921542 3708751631 2636391460 839387144 14684133 14684133 14684133 14684133 14684133 14684133 14684133 14684133 14684133 67108864 2147681027 4093969669 4179697953 4284308829 4287203721 4289177511 4289769648 4289769648 4289769648 4289769648 4289374890 4287795858 4284506208 4196606755 4010873105 1611270666 14684133 14684133 14684133 14684133 14684133 14684133 134217728 3188065798 4162723358 4284045657 4288848546 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290032820 4289243304 4213844522 3222409746 117440512 14684133 14684133 14684133 14684133 2986541827 4078968864 4284572001 4289374890 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4291743438 4149367378 2987068171 16777216 14684133 14684133 1392640514 4077981969 4283914071 4288190616 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290230199 4292138196 4097259319 2047083524 14684133 14684133 3892708870 4282729797 4286151033 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4291151301 4290493371 4060744202 150994944 738197504 4127853066 4283979864 4288387995 4289769648 4289769648 4289769648 4289769648 4289769648 4287664272 4279308561 4278519045 4278519045 4278584838 4285164138 4289769648 4289769648 4289769648 4289769648 4289769648 4290164406 4292335575 4030413627 1711276032 2147615234 4196935720 4284440415 4289703855 4289769648 4289769648 4289769648 4289769648 4289769648 4282729797 4278190080 4278517760 4278648832 4278190080 4279440147 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4291940817 4270952849 2970225162 3691645450 4282664004 4286085240 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4282729797 4278190080 4289396736 4294180864 4278190080 4279440147 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4291151301 4289703855 3776386839 4110681092 4283716692 4286940549 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4282729797 4278190080 4289396736 4294180864 4278190080 4279440147 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290756543 4291480266 4094364427 4244767234 4284572001 4287532686 4289769648 4289769648 4289769648 4289769648 4289769648 4256149423 4181869122 4278190080 4289396736 4294180864 4278190080 4245819922 4222660784 4289769648 4289769648 4289769648 4289769648 4289769648 4290690750 4292138196 4244898820 4244767234 4283979864 4287401100 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4282729797 4278190080 4289396736 4294180864 4278190080 4279440147 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290756543 4292335575 4244898820 4244767234 4283979864 4287401100 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4282729797 4278190080 4289396736 4294180864 4278190080 4279440147 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290756543 4292335575 4244898820 4244767234 4283979864 4287401100 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4282729797 4278190080 4289396736 4294180864 4278190080 4279440147 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290756543 4292335575 4244898820 4244767234 4283979864 4287401100 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4282729797 4278190080 4289396736 4294180864 4278190080 4279440147 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290756543 4292335575 4244898820 4244767234 4283979864 4287401100 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4282729797 4278190080 4289396736 4294180864 4278190080 4279440147 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290756543 4292335575 4244898820 4244767234 4283979864 4287401100 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4282729797 4278190080 4289396736 4294180864 4278190080 4279440147 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290756543 4292335575 4244898820 4244767234 4283979864 4287401100 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4282729797 4278190080 4289396736 4294180864 4278190080 4279440147 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290756543 4292335575 4244898820 4244767234 4283979864 4287401100 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4282729797 4278190080 4289396736 4294180864 4278190080 4279440147 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290756543 4292335575 4244898820 4244767234 4283979864 4287401100 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4282729797 4278190080 4289396736 4294180864 4278190080 4279440147 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290756543 4292335575 4244898820 4244767234 4283979864 4287401100 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4282729797 4278190080 4278517760 4278648832 4278190080 4279440147 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290756543 4292335575 4244898820 4244767234 4283979864 4287401100 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4287664272 4279308561 4278519045 4278519045 4278584838 4285164138 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290756543 4292335575 4244898820 4244767234 4283979864 4287401100 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290756543 4292335575 4244898820 4244767234 4216805207 4186672011 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4190093247 4225226711 4228121604) offset: 0@0)! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 1/21/2012 23:44'! instVarsSelectedIcon ^ (Form extent: 24@24 depth: 32 fromArray: #(14684133 14684133 14684133 14684133 14684133 572991271 2623035480 3445645408 3412814699 4237332624 4221147545 4120484249 4103707033 4187593113 4137458844 3030623139 3115035563 2393417896 434891755 14684133 14684133 14684133 14684133 14684133 14684133 14684133 14684133 223169869 2656655705 4099035730 4286611584 4289703855 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290822336 4022386880 2661590180 177838489 14684133 14684133 14684133 14684133 14684133 234881024 3444526927 4284243036 4287927444 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290361785 4292138196 3568415153 341268311 14684133 14684133 14684133 16777216 2907787601 4283979864 4287335307 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290559164 4292335575 3215830445 117440512 14684133 14684133 2069189973 4267202648 4285493103 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4291414473 4292335575 2493291676 14684133 33554432 3763359824 4283979864 4288914339 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289967027 4292335575 3972384197 201326592 1195261502 4267202648 4285032552 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4288980132 4281871147 4281344032 4281344032 4281409825 4287006342 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4291677645 4292335575 1653509774 2723567190 4283979864 4286808963 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4287401100 4280551432 4290707456 4290707456 4284219649 4284177243 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290822336 4292335575 3182144427 3696514132 4283979864 4288453788 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4287401100 4281272842 4294901760 4294901760 4286185729 4284177243 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290098613 4292335575 3870799799 3813362507 4283979864 4289111718 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4287401100 4281272842 4294901760 4294901760 4286185729 4284177243 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 3904617403 4233187665 4284045657 4289440683 4289769648 4289769648 4289769648 4289769648 4289769648 4272992432 4237069452 4281272842 4294901760 4294901760 4286185729 4250557018 4272992432 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292269782 4240095930 4249964881 4283979864 4289374890 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4287401100 4281272842 4294901760 4294901760 4286185729 4284177243 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4256873146 4249899088 4283979864 4289374890 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4287401100 4281272842 4294901760 4294901760 4286185729 4284177243 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4240161723 4216344656 4283979864 4289374890 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4287401100 4281272842 4294901760 4294901760 4286185729 4284177243 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4206607291 4182724431 4283979864 4289374890 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4287401100 4281272842 4294901760 4294901760 4286185729 4284177243 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4172987066 4165947215 4283979864 4289374890 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4287401100 4281272842 4294901760 4294901760 4286185729 4284177243 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4172987066 4165947215 4283979864 4289374890 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4287401100 4281272842 4294901760 4294901760 4286185729 4284177243 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4172987066 4165947215 4283979864 4289374890 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4287401100 4281272842 4294901760 4294901760 4286185729 4284177243 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4172987066 4165947215 4283979864 4289374890 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4287401100 4281272842 4294901760 4294901760 4286185729 4284177243 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4172987066 4165947215 4283979864 4289374890 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4287401100 4281272842 4294901760 4294901760 4286185729 4284177243 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4172987066 4165947215 4283979864 4289374890 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4287401100 4279764486 4286513152 4286513152 4282188033 4284177243 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4172987066 4165947215 4283979864 4289374890 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289572269 4284506208 4283979864 4283979864 4283979864 4288387995 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4172987066 4165947215 4283979864 4289374890 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4172987066 4115483981 4216805207 4171934378 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172394929 4225226711 4105878202) offset: 0@0)! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 1/21/2012 23:44'! instVarsUnselectedIcon ^ (Form extent: 24@24 depth: 32 fromArray: #(14684133 14684133 14684133 14684133 14684133 572991271 2623035480 3445645408 3412814699 4237332624 4221147545 4120484249 4103707033 4187593113 4137458844 3030623139 3115035563 2393417896 434891755 14684133 14684133 14684133 14684133 14684133 14684133 14684133 14684133 223169869 2656655705 4099035730 4286611584 4289703855 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290822336 4022386880 2661590180 177838489 14684133 14684133 14684133 14684133 14684133 234881024 3444526927 4284243036 4287927444 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290361785 4292138196 3568415153 341268311 14684133 14684133 14684133 16777216 2907787601 4283979864 4287335307 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290559164 4292335575 3215830445 117440512 14684133 14684133 2069189973 4267202648 4285493103 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4291414473 4292335575 2493291676 14684133 33554432 3763359824 4283979864 4288914339 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289967027 4292335575 3972384197 201326592 1195261502 4267202648 4285032552 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4288980132 4281479730 4280821800 4280821800 4280887593 4287006342 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4291677645 4292335575 1653509774 2723567190 4283979864 4286808963 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4287401100 4279637526 4284506208 4284506208 4281216558 4284177243 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290822336 4292335575 3182144427 3696514132 4283979864 4288453788 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4287401100 4280032284 4286611584 4286611584 4282269246 4284177243 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290098613 4292335575 3870799799 3813362507 4283979864 4289111718 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4287401100 4280032284 4286611584 4286611584 4282269246 4284177243 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 3904617403 4233187665 4284045657 4289440683 4289769648 4289769648 4289769648 4289769648 4289769648 4272992432 4237069452 4280032284 4286611584 4286611584 4282269246 4250557018 4272992432 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292269782 4240095930 4249964881 4283979864 4289374890 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4287401100 4280032284 4286611584 4286611584 4282269246 4284177243 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4256873146 4249899088 4283979864 4289374890 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4287401100 4280032284 4286611584 4286611584 4282269246 4284177243 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4240161723 4216344656 4283979864 4289374890 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4287401100 4280032284 4286611584 4286611584 4282269246 4284177243 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4206607291 4182724431 4283979864 4289374890 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4287401100 4280032284 4286611584 4286611584 4282269246 4284177243 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4172987066 4165947215 4283979864 4289374890 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4287401100 4280032284 4286611584 4286611584 4282269246 4284177243 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4172987066 4165947215 4283979864 4289374890 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4287401100 4280032284 4286611584 4286611584 4282269246 4284177243 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4172987066 4165947215 4283979864 4289374890 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4287401100 4280032284 4286611584 4286611584 4282269246 4284177243 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4172987066 4165947215 4283979864 4289374890 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4287401100 4280032284 4286611584 4286611584 4282269246 4284177243 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4172987066 4165947215 4283979864 4289374890 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4287401100 4280032284 4286611584 4286611584 4282269246 4284177243 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4172987066 4165947215 4283979864 4289374890 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4287401100 4279176975 4282400832 4282400832 4280229663 4284177243 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4172987066 4165947215 4283979864 4289374890 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289572269 4284506208 4283979864 4283979864 4283979864 4288387995 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4172987066 4165947215 4283979864 4289374890 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4172987066 4115483981 4216805207 4171934378 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172394929 4225226711 4105878202) offset: 0@0)! ! !NautilusIcons methodsFor: 'icons' stamp: 'lr 3/29/2009 14:19'! magnitude ^ ((ColorForm extent: 12@12 depth: 8 fromArray: #( 874447653 738461995 85013556 875824136 573444634 471217204 875826957 607204404 875115572 875836464 489816628 875836468 875836468 50409268 875836468 875836468 268902708 875836468 875836418 101004340 875836468 875836448 167851060 873804852 875825163 204747815 874722356 875763995 321259818 335557684 875042605 102243847 930868 875836468 875836468 875836468) offset: 0@0) colorsFromArray: #(#(0.372 0.372 0.372) #(0.608 0.608 0.608) #(0.961 0.961 0.961) #(0.506 0.506 0.506) #(0.588 0.588 0.588) #(0.415 0.415 0.415) #(0.419 0.419 0.419) #(0.384 0.384 0.384) #(0.745 0.745 0.745) #(0.561 0.561 0.561) #(0.447 0.447 0.447) #(0.435 0.435 0.435) #(0.427 0.427 0.427) #(0.545 0.545 0.545) #(0.522 0.522 0.522) #(0.902 0.902 0.902) #(0.761 0.761 0.761) #(0.53 0.53 0.53) #(0.686 0.686 0.686) #(0.628 0.628 0.628) #(0.181 0.181 0.181) #(0.204 0.204 0.204) #(0.604 0.604 0.604) #(0.455 0.455 0.455) #(0.408 0.408 0.408) #(0.341 0.341 0.341) #(0.659 0.659 0.659) #(0.333 0.333 0.333) #(0.663 0.663 0.663) #(0.624 0.624 0.624) #(0.396 0.396 0.396) #(0.875 0.875 0.875) #(0.542 0.542 0.542) #(0.592 0.592 0.592) #(0.569 0.569 0.569) #(0.236 0.236 0.236) #(0.565 0.565 0.565) #(0.494 0.494 0.494) #(0.62 0.62 0.62) #(0.953 0.953 0.953) #(0.733 0.733 0.733) #(0.502 0.502 0.502) #(0.298 0.298 0.298) #(0.451 0.451 0.451) #(0.585 0.585 0.585) #(0.439 0.439 0.439) #(0.698 0.698 0.698) #(0.714 0.714 0.714) #(0.721 0.721 0.721) #(0.855 0.855 0.855) #(0.474 0.474 0.474) #(0.871 0.871 0.871) #( ) ))! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 2/21/2012 02:32'! monticelloPackage ^(Form extent: 16@16 depth: 32 fromArray: #(16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 722736128 2235383040 3106942976 3394787328 301989888 16777215 16777215 100663296 2707053056 2689683712 3240305408 16777215 16777215 16777215 1985303808 3527491840 3207869440 3040228864 3577033984 4241082624 1496988160 16777215 673983488 3692698112 4156604416 3157866752 3023649024 16777215 16777215 16777215 1817071104 2200973312 16777215 2725146112 2859627008 3583086848 2675011840 959656704 3609206784 2486646528 4021597184 3257280000 924983808 16777215 16777215 16777215 16777215 33554432 16777215 3381233920 2169326848 2792320768 3464330496 3642827008 268435456 2943776256 3279912704 3408011776 16777215 16777215 16777215 16777215 16777215 16777215 706682624 3967646976 606019328 2186104064 4105285888 857809152 50331648 3667038720 2487304448 3207408896 16777215 16777215 16777215 16777215 16777215 16777215 2438749184 3094836992 16777215 3375049472 4088442880 503316480 975644416 4171539456 2350784000 2285780480 16777215 16777215 16777215 16777215 16777215 150994944 3715396608 1564491776 1598309376 3324191488 4189171968 1278094848 1984251136 3750793216 2721790720 1092558592 16777215 16777215 16777215 16777215 16777215 2270121728 3278136320 16777216 3593219072 1124599808 4120549888 637928960 2355060480 3246424064 3240634368 167772160 16777215 16777216 16777215 16777215 959919872 3747569408 858927616 1093611264 3023714816 1782529792 3598942976 33554432 2590862592 2910353408 3357614336 16777215 16777215 2065373952 16777215 1278818560 3612693760 1682787584 16777215 2605073920 1664694528 3026609664 2371245568 16777215 2506647552 2472895744 3324059904 33554432 16777215 2721264384 3694211328 3444132096 1296056320 16777215 16777215 1950499328 3693553408 3376562688 100663296 83886080 3259780096 3727634176 3927381760 3726120960 689576448 16777215 67108864 16777215 16777215 16777215 16777215 16777215 637534208 33554432 16777215 639047424 3056282368 67108864 538252544 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215) offset: 0@0)! ! !NautilusIcons methodsFor: 'icons' stamp: 'lr 3/29/2009 14:13'! morph ^ ((ColorForm extent: 12@12 depth: 8 fromArray: #( 1578631802 292362797 539127618 1895825665 2117994270 1445606482 202325275 1997372285 33573212 859313989 1763509875 1213866361 1064308758 192424752 1645101626 793665883 476466020 85208644 1751792704 621947215 1414349622 527711064 676669009 1346794755 1617375851 1095982919 656635516 1819423020 354700362 1695037706 154613091 420699479 75263577 2139062143 2139062143 2139062143) offset: 0@0) colorsFromArray: #(#(0.557 0.714 0.898) #(0.526 0.686 0.887) #(0.557 0.706 0.887) #(0.494 0.604 0.796) #(0.494 0.6 0.792) #(0.585 0.811 1.0) #(0.879 0.93 0.883) #(0.514 0.671 0.867) #(0.84 0.867 0.902) #(0.581 0.667 0.804) #(0.474 0.577 0.753) #(0.729 0.851 0.674) #(0.51 0.678 0.883) #(0.565 0.71 0.918) #(0.733 0.894 1.0) #(0.538 0.694 0.883) #(0.455 0.741 1.0) #(0.553 0.69 0.871) #(0.969 0.867 0.78) #(0.506 0.635 0.815) #(0.757 0.906 1.0) #(0.851 0.879 0.922) #(0.655 0.844 1.0) #(0.836 0.918 0.992) #(0.604 0.741 0.902) #(0.518 0.631 0.804) #(0.542 0.678 0.855) #(0.549 0.698 0.883) #(0.753 0.875 0.725) #(0.815 0.894 0.823) #(0.51 0.667 0.863) #(0.639 0.733 0.91) #(0.522 0.659 0.84) #(0.686 0.757 0.867) #(0.542 0.671 0.836) #(1.0 0.949 0.612) #(0.848 0.859 0.894) #(0.988 0.949 0.918) #(1.0 0.682 0.514) #(0.984 0.871 0.415) #(1.0 0.796 0.674) #(0.977 0.914 0.867) #(0.518 0.671 0.859) #(0.585 0.776 0.518) #(0.836 0.879 0.922) #(0.534 0.671 0.851) #(0.706 0.757 0.855) #(0.643 0.745 0.879) #(0.819 0.918 1.0) #(0.827 0.871 0.906) #(0.458 0.721 0.404) #(0.62 0.737 0.891) #(0.51 0.631 0.8) #(0.577 0.663 0.848) #(0.506 0.612 0.776) #(0.565 0.671 0.84) #(0.926 0.961 0.992) #(0.581 0.659 0.792) #(0.545 0.639 0.792) #(0.4 0.686 0.353) #(0.811 0.898 0.827) #(0.561 0.706 0.883) #(0.518 0.674 0.871) #(0.659 0.757 0.891) #(0.887 0.945 0.902) #(1.0 0.84 0.717) #(0.717 0.776 0.863) #(0.678 0.745 0.859) #(0.538 0.628 0.776) #(0.898 0.945 0.992) #(1.0 0.918 0.549) #(0.996 0.961 0.757) #(0.863 0.93 0.992) #(0.474 0.628 0.827) #(0.844 0.871 0.914) #(0.62 0.807 0.581) #(0.848 0.867 0.91) #(0.988 0.977 0.898) #(0.804 0.914 1.0) #(0.98 0.977 0.934) #(0.957 0.84 0.365) #(0.961 0.93 0.714) #(0.596 0.678 0.815) #(1.0 0.6 0.314) #(0.953 0.937 0.823) #(1.0 0.538 0.243) #(0.502 0.659 0.855) #(0.498 0.596 0.768) #(0.549 0.792 0.577) #(0.612 0.682 0.807) #(0.914 0.957 0.992) #(0.706 0.863 1.0) #(0.482 0.616 0.8) #(0.498 0.624 0.792) #(0.694 0.757 0.863) #(1.0 0.737 0.569) #(0.631 0.721 0.902) #(0.522 0.772 1.0) #(0.549 0.792 1.0) #(0.553 0.647 0.823) #(0.836 0.926 1.0) #(0.84 0.863 0.891) #(0.423 0.717 0.423) #(0.788 0.898 0.733) #(0.612 0.729 0.887) #(0.918 0.953 0.922) #(0.934 0.965 0.934) #(0.616 0.831 0.628) #(0.53 0.643 0.807) #(0.545 0.686 0.863) #(0.502 0.596 0.753) #(0.616 0.702 0.823) #(0.772 0.898 1.0) #(0.581 0.686 0.844) #(0.851 0.891 0.934) #(0.937 0.965 0.992) #(0.729 0.859 0.686) #(0.671 0.745 0.879) #(0.682 0.749 0.879) #(0.545 0.698 0.898) #(0.388 0.682 0.341) #(0.534 0.639 0.8) #(0.561 0.702 0.883) #(0.553 0.706 0.91) #(0.486 0.588 0.776) #(0.542 0.698 0.887) #(0.522 0.678 0.875) #( ) ))! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 3/30/2011 19:10'! packageIcon ^ (Form extent: 15@16 depth: 32 fromArray: #(16777215 16777215 16777215 16777215 16777215 16777215 55924053 75530368 50331647 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 33554432 138428480 1750488662 3547295599 2256173690 261724569 55924053 16777215 16777215 16777215 16777215 16777215 16777215 33554432 103492395 1178944837 3361890914 4286085240 4286545791 4286808963 3900275065 1819834488 162179754 75530368 16777215 16777215 16777215 67108864 741618740 2874693720 4235029869 3514399097 3783229311 4286677377 4119234182 3499200913 4203580813 3683026566 1736672131 245671076 41975936 50331648 1902206815 3948896095 4285098345 4285690482 4286019447 4185685116 3213527690 3817441673 4287269514 4287730065 4288848546 4289638062 3180762774 212511402 16777215 2523490665 4084692598 3631641716 4235161455 3497621881 3783229311 4286677377 4119299975 3482555283 4203778192 3919684001 4004358826 3786387375 284159983 16777215 2556847718 4285164138 4285558896 3665656699 3732371319 4286151033 4286545791 4286808963 3968502410 3515912079 4287532686 4288585374 3701974951 234881023 16777215 2639878489 4284506208 4285032552 3715067759 4285822068 3850272125 3883761021 3632563075 4202527868 3582034305 4286743170 4287269514 3583218579 150994943 16777215 2672643405 3863957327 4200291163 3814941539 4285229931 4285558896 4185421687 4285493103 4285822068 3564928124 4286414205 3498542983 3196421509 83886079 16777215 2822651454 4282203453 4182395466 4081929549 4284374622 4284966759 4268715630 4285229931 4285493103 3698027371 3698948473 4286282619 3480976251 83886079 16777216 3039636781 4280756007 4281742902 4265360444 4283058762 4283519313 4284966502 4284243036 4266939476 4233977181 4285690482 4285953654 3480647286 67108863 117440512 2518687776 4246148887 4280098077 4280821800 4282203453 4282992969 4284374365 4284637794 4284900966 4267071062 4285361517 4235095662 2305452650 41975936 16777216 134217728 873731092 3659670050 4245885715 4280690214 4281611316 4283913814 4284835173 4284835173 4065744470 3294255706 844255826 55924053 16777215 16777215 16777215 33554432 218103808 1461131031 3978305568 4280098077 4249635659 4284835173 3730463322 1246514252 100663296 16777215 16777215 16777215 16777215 16777215 16777215 16777215 50331648 285212672 2115903006 3645129539 1833979984 150994944 16777216 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 83886080 134217728 33554432 16777215 16777215 16777215 16777215 16777215 16777215) offset: 0@0)! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 3/30/2011 14:23'! 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)! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 3/31/2011 01:59'! removeIcon ^ (Form extent: 16@16 depth: 32 fromArray: #(0 0 0 0 0 16777216 975118106 1948196125 2233408797 505551386 0 0 0 0 0 0 0 0 0 740105501 2485067036 3913366574 4287266903 4291870588 4290358386 4234896198 2770871586 723394078 0 0 0 0 0 169482778 2803834139 4266346036 4290226543 4292129381 4291006529 4287127849 4290939191 4289826121 4292857218 4270292053 3056281379 991829530 0 0 0 2048727835 4289170770 4293777803 4291932517 4286537258 4278912771 4278190080 4279044356 4285747232 4289428791 4293645446 4293515148 4285162053 1461525786 0 0 2233014039 4292059214 4291203136 4290485594 4293186183 4288648552 4283518790 4284439625 4290950264 4292989063 4292791942 4294041488 4289240168 2535004182 0 0 1141837583 4079033886 4283716440 4291862608 4291794755 4292721001 4294896278 4294436244 4293515404 4294436244 4291016058 4286086513 4079889188 1712262925 0 0 134217728 3676117787 4280495698 4280627542 4282731358 4290877268 4294104192 4289439097 4284839294 4283921301 4284976569 4284516277 2786662166 469762048 0 0 0 3407682073 4283195017 4283194246 4282338678 4281351266 4282406780 4283791527 4284188861 4284124357 4283993287 4282936985 2249528595 0 0 0 0 3122338329 4283195018 4283194246 4283194246 4283194246 4283198876 4283927751 4283927751 4283927751 4283927751 4282408577 1746145553 0 0 0 0 2837125656 4283063944 4283194246 4283194246 4283194246 4283463079 4283927751 4283927751 4283927751 4283927751 4281880424 1225657870 0 0 0 0 2518292504 4282932356 4283194246 4283194246 4283194246 4283594409 4283927751 4283927751 4283927751 4283927751 4264641108 688260614 0 0 0 0 2199459607 4282800510 4283194246 4283194246 4283194246 4283395998 4283927751 4283927751 4283927751 4283927751 4062984519 436207616 0 0 0 0 1192366610 4248059475 4283195017 4283194246 4283194246 4283066516 4283927751 4283927751 4283927751 4283729855 3676448299 285212672 0 0 0 0 67108864 1494289934 3827639852 4282932356 4283194246 4282803083 4283927751 4283729598 4282408577 4230492216 2434077971 67108864 0 0 0 0 0 0 503908617 2887325720 4265496687 4282340983 4281682014 4062323235 2836928279 1225394698 268435456 0 0 0 0 0 0 0 0 67108864 1662326034 2904102936 2216105237 604440327 67108864 0 0 0 0 0) offset: 0@0)! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 4/13/2011 11:45'! separatorIcon ^ (Form extent: 24@5 depth: 32 fromArray: #(16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1329216058 1463828544 1463828544 1463828544 1463828544 1463828544 1463828544 1463828544 1463828544 1463828544 1463828544 1463828544 1463828544 1463828544 1463828544 1463828544 1463828544 1463828544 1463828544 1463828544 1463828544 1463828544 1463828544 1329216058 3869089181 4291019715 4291019715 4291019715 4291019715 4291019715 4291019715 4291019715 4291019715 4291019715 4291019715 4291019715 4291019715 4291019715 4291019715 4291019715 4291019715 4291019715 4291019715 4291019715 4291019715 4291019715 4291019715 3869089181 1329216058 1463828544 1463828544 1463828544 1463828544 1463828544 1463828544 1463828544 1463828544 1463828544 1463828544 1463828544 1463828544 1463828544 1463828544 1463828544 1463828544 1463828544 1463828544 1463828544 1463828544 1463828544 1463828544 1329216058 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215) offset: 0@0)! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 1/21/2012 23:19'! sourcePressedIcon ^ (Form extent: 24@24 depth: 32 fromArray: #(14684133 14684133 14684133 738197504 2852126720 4227858432 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 3959620355 2399141888 234881024 14684133 14684133 14684133 14684133 14684133 1107296256 4093640704 4278190080 4278321666 4281677109 4286151033 4287664272 4289111718 4289769648 4289769648 4289769648 4289769648 4289111718 4287466893 4284111450 4280624421 4278190080 4278190080 3842048257 1090519040 14684133 14684133 14684133 1207959552 4160749568 4278190080 4280295456 4287269514 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4287993237 4280953386 4278190080 4110417920 922746880 14684133 268435456 3875536896 4278190080 4280821800 4287598479 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290361785 4283585106 4278190080 3942645760 520093696 2533359616 4278190080 4279505940 4285822068 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4291217094 4282335039 4278190080 2583691264 4043309056 4278190080 4282992969 4289243304 4289769648 4289769648 4289769648 4289769648 4289703855 4286940549 4285361517 4283914071 4283782485 4284703587 4286019447 4288387995 4289769648 4289769648 4289769648 4289769648 4289901234 4290098613 4278255873 4160749568 4278190080 4279242768 4285361517 4289769648 4289769648 4289769648 4289769648 4286216826 4280032284 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4279111182 4286611584 4289769648 4289769648 4289769648 4291611852 4282532418 4278190080 4278190080 4281150765 4287203721 4289769648 4289769648 4289769648 4286216826 4278190080 4278190080 4280226816 4284300032 4286205440 4286139648 4284825856 4282920448 4279569920 4278190080 4280492835 4289769648 4289769648 4289769648 4290822336 4286940549 4278190080 4278190080 4282861383 4288848546 4289769648 4289769648 4289111718 4278979596 4278190080 4285482496 4292446976 4285614080 4282263552 4280358144 4282066432 4284234496 4286270976 4278190080 4280361249 4289769648 4289769648 4289769648 4290098613 4288716960 4278190080 4278190080 4283716692 4289506476 4289769648 4289769648 4286479998 4278190080 4281277952 4293694976 4283051776 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4280361249 4289769648 4289769648 4289769648 4289835441 4290559164 4278190080 4278190080 4283979864 4289769648 4289769648 4289769648 4284440415 4278190080 4284825856 4293169408 4278190080 4278190080 4284966759 4287927444 4286808963 4284506208 4280624421 4278190080 4282335039 4289769648 4289769648 4289769648 4289835441 4291480266 4278190080 4278190080 4283979864 4289769648 4289769648 4289769648 4284835173 4278190080 4284431360 4293694976 4280555264 4278190080 4278321666 4280492835 4282729797 4285887861 4289177511 4288980132 4289703855 4289769648 4289769648 4289769648 4289835441 4291480266 4278190080 4278190080 4283979864 4289769648 4289769648 4289769648 4287072135 4278190080 4279372800 4292578304 4291264256 4283314688 4278715648 4278190080 4278190080 4278190080 4278519045 4283914071 4289506476 4289769648 4289769648 4289769648 4289835441 4291480266 4278190080 4278190080 4283979864 4289769648 4289769648 4289769648 4289769648 4281019179 4278190080 4280095232 4288044800 4292972288 4293300736 4290344448 4286731008 4282066432 4278321408 4278190080 4281545523 4289769648 4289769648 4289769648 4289835441 4291480266 4278190080 4278190080 4283979864 4289769648 4289769648 4289769648 4289769648 4288387995 4280558628 4278190080 4278190080 4278584320 4281803520 4285876992 4291592704 4293760768 4290278656 4279241472 4278190080 4285953654 4289769648 4289769648 4289835441 4291480266 4278190080 4278190080 4283979864 4289769648 4289769648 4289769648 4289769648 4289769648 4289572269 4285164138 4281216558 4278321666 4278190080 4278190080 4278190080 4285876992 4293760768 4286270976 4278190080 4282795590 4289769648 4289769648 4289835441 4291480266 4278190080 4278190080 4283979864 4289769648 4289769648 4289769648 4288651167 4281216558 4283124555 4287927444 4289769648 4289111718 4286611584 4282729797 4278255873 4278584320 4292906752 4289096192 4278190080 4281348144 4289769648 4289769648 4289835441 4291480266 4278190080 4278190080 4283979864 4289769648 4289769648 4289769648 4285427310 4278190080 4278190080 4278190080 4280821800 4283058762 4284572001 4282795590 4278255873 4278518528 4292840960 4287387904 4278190080 4282598211 4289769648 4289769648 4289835441 4291480266 4278190080 4278190080 4283979864 4289769648 4289769648 4289769648 4285427310 4278190080 4279898368 4278978304 4278190080 4278190080 4278190080 4278190080 4278190080 4285876992 4293760768 4282460416 4278190080 4284769380 4289769648 4289769648 4289835441 4291480266 4278190080 4278190080 4283979864 4289769648 4289769648 4289769648 4285427310 4278190080 4281409280 4288964608 4289030400 4287059456 4284891392 4286402560 4290081536 4292249600 4284365824 4278190080 4278979596 4288651167 4289769648 4289769648 4289835441 4291480266 4278190080 4278190080 4283979864 4289769648 4289769648 4289769648 4287598479 4278452995 4278190080 4278190080 4278650112 4280358144 4281803520 4281803520 4280095232 4278452736 4278190080 4278321666 4286216826 4289769648 4289769648 4289769648 4289835441 4291480266 4278190080 4278190080 4283979864 4289769648 4289769648 4289769648 4289769648 4287203721 4283585106 4280427042 4278255873 4278190080 4278190080 4278190080 4278190080 4278453252 4282269246 4287795858 4289769648 4289769648 4289769648 4289769648 4289835441 4291480266 4278190080 4278190080 4283979864 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289440683 4288256409 4287072135 4287006342 4288453788 4289638062 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4291480266 4278190080 4278190080 4216805207 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172394929 4224305609 4278190080) offset: 0@0)! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 1/21/2012 22:07'! sourceSelectedIcon ^ (Form extent: 24@24 depth: 32 fromArray: #(14684133 14684133 14684133 14684133 14684133 572991271 2623035480 3445645408 3412814699 4237332624 4221147545 4120484249 4103707033 4187593113 4137458844 3030623139 3115035563 2393417896 434891755 14684133 14684133 14684133 14684133 14684133 14684133 14684133 14684133 223169869 2656655705 4099035730 4286611584 4289703855 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290822336 4022386880 2661590180 177838489 14684133 14684133 14684133 14684133 14684133 234881024 3444526927 4284243036 4287927444 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290361785 4292138196 3568415153 341268311 14684133 14684133 14684133 16777216 2907787601 4283979864 4287335307 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290559164 4292335575 3215830445 117440512 14684133 14684133 2069189973 4267202648 4285493103 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4291414473 4292335575 2476646046 14684133 33554432 3763359824 4283979864 4288914339 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289703855 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289967027 4292335575 3955672774 184549376 1195261502 4267202648 4285032552 4289769648 4289769648 4289769648 4289769648 4289769648 4286940549 4282004781 4280097041 4278584579 4278518786 4279439370 4280688921 4282860607 4285229931 4289572269 4289769648 4289769648 4289769648 4291677645 4292335575 1653509774 2723567190 4283979864 4286808963 4289769648 4289769648 4289769648 4289769648 4283189572 4280227592 4287979264 4291658496 4293432320 4293432320 4292249600 4290409984 4287190784 4280161542 4286282619 4289769648 4289769648 4289769648 4290822336 4292335575 3182144427 3696514132 4283979864 4288453788 4289769648 4289769648 4289769648 4285756274 4280490248 4293103616 4293760768 4293498112 4291001344 4288833280 4290278656 4292380928 4293760768 4282921226 4286085240 4289769648 4289769648 4289769648 4290098613 4292335575 3870799799 3813362507 4283979864 4289111718 4289769648 4289769648 4289769648 4281610279 4288964608 4293760768 4292052480 4279373061 4280426005 4282333744 4281149213 4279241992 4281344522 4280292869 4286085240 4289769648 4289769648 4289769648 4289835441 4292335575 3904617403 4233187665 4284045657 4289440683 4289769648 4289769648 4289769648 4279439370 4291986944 4293760768 4285285891 4249832779 4222660784 4222660784 4222660784 4222529198 4269834368 4283321159 4288519581 4289769648 4289769648 4289769648 4289835441 4292269782 4240095930 4249964881 4283979864 4289374890 4289769648 4289769648 4289769648 4279768334 4291855616 4293760768 4289490432 4279176199 4283255622 4286348412 4288782753 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4256873146 4249899088 4283979864 4289374890 4289769648 4289769648 4289769648 4282070832 4287256577 4293760768 4293760768 4291592704 4286337026 4282264330 4279176198 4280754714 4284308570 4289243304 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4240161723 4216344656 4283979864 4289374890 4289769648 4289769648 4289769648 4287927444 4279241991 4288899072 4293760768 4293760768 4293760768 4293760768 4293563648 4289884672 4283972103 4279965457 4287927444 4289769648 4289769648 4289769648 4289835441 4292335575 4206607291 4182724431 4283979864 4289374890 4289769648 4289769648 4289769648 4289769648 4287203721 4280228885 4280884746 4286008579 4289950208 4293235200 4293760768 4293760768 4293760768 4287191041 4280952352 4289769648 4289769648 4289769648 4289835441 4292335575 4172987066 4165947215 4283979864 4289374890 4289769648 4289769648 4289769648 4289769648 4289769648 4289703855 4287269514 4283716175 4281083678 4279044613 4284037894 4292578304 4293760768 4293694976 4279110405 4288651167 4289769648 4289769648 4289835441 4292335575 4172987066 4165947215 4283979864 4289374890 4289769648 4289769648 4289769648 4288453788 4288980132 4289769648 4289769648 4289769648 4289769648 4288585374 4282137143 4285417219 4293760768 4293760768 4281213194 4287203721 4289769648 4289769648 4289835441 4292335575 4172987066 4165947215 4283979864 4289374890 4289769648 4289769648 4289769648 4280426007 4278847492 4282794813 4287006342 4288914339 4289769648 4288848546 4282531900 4285351685 4293760768 4293760768 4279635975 4288387995 4289769648 4289769648 4289835441 4292335575 4172987066 4165947215 4283979864 4289374890 4289769648 4289769648 4289769648 4280294163 4290016000 4286468354 4281278730 4279110405 4278847493 4278979077 4282592778 4292709632 4293760768 4291592704 4278979078 4289703855 4289769648 4289769648 4289835441 4292335575 4172987066 4165947215 4283979864 4289374890 4289769648 4289769648 4289769648 4280294163 4290804480 4293760768 4293760768 4293760768 4292840960 4293629440 4293760768 4293760768 4292775424 4281278728 4284769121 4289769648 4289769648 4289769648 4289835441 4292335575 4172987066 4165947215 4283979864 4289374890 4289769648 4289769648 4289769648 4283386949 4278781700 4282001674 4286205441 4288044800 4289555968 4289753088 4288044800 4284957443 4279176198 4283255365 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4172987066 4165947215 4283979864 4289374890 4289769648 4289769648 4289769648 4289769648 4289309097 4286414205 4283913555 4282794554 4281609765 4281412643 4282662969 4283979606 4288322202 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4172987066 4165947215 4283979864 4289374890 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4172987066 4115483981 4216805207 4171934378 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172394929 4225226711 4105878202) offset: 0@0)! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 1/21/2012 22:07'! sourceUnselectedIcon ^ (Form extent: 24@24 depth: 32 fromArray: #(14684133 14684133 14684133 14684133 14684133 572991271 2623035480 3445645408 3412814699 4237332624 4221147545 4120484249 4103707033 4187593113 4137458844 3030623139 3115035563 2393417896 434891755 14684133 14684133 14684133 14684133 14684133 14684133 14684133 14684133 223169869 2656655705 4099035730 4286611584 4289703855 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290822336 4022386880 2661590180 177838489 14684133 14684133 14684133 14684133 14684133 234881024 3444526927 4284243036 4287927444 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290361785 4292138196 3568415153 341268311 14684133 14684133 14684133 16777216 2907787601 4283979864 4287335307 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4290559164 4292335575 3215830445 117440512 14684133 14684133 2069189973 4267202648 4285493103 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4291414473 4292335575 2476646046 14684133 33554432 3763359824 4283979864 4288914339 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289703855 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289967027 4292335575 3955672774 184549376 1195261502 4267202648 4285032552 4289769648 4289769648 4289769648 4289769648 4289769648 4286940549 4281611316 4279769112 4278519045 4278387459 4279176975 4280295456 4282598211 4285229931 4289572269 4289769648 4289769648 4289769648 4291677645 4292335575 1653509774 2723567190 4283979864 4286808963 4289769648 4289769648 4289769648 4289769648 4282992969 4279505940 4283453520 4285493103 4286414205 4286414205 4285756275 4284769380 4283058762 4279440147 4286282619 4289769648 4289769648 4289769648 4290822336 4292335575 3182144427 3696514132 4283979864 4288453788 4289769648 4289769648 4289769648 4285756275 4279703319 4286216826 4286611584 4286479998 4285098345 4283914071 4284703587 4285822068 4286611584 4281019179 4286085240 4289769648 4289769648 4289769648 4290098613 4292335575 3870799799 3813362507 4283979864 4289111718 4289769648 4289769648 4289769648 4281216558 4283979864 4286611584 4285690482 4278979596 4280032284 4281874488 4280624421 4278979596 4280229663 4279505940 4286085240 4289769648 4289769648 4289769648 4289835441 4292335575 3904617403 4233187665 4284045657 4289440683 4289769648 4289769648 4289769648 4279176975 4285624689 4286611584 4282071867 4249701709 4222660784 4222660784 4222660784 4222529198 4269834368 4283124555 4288519581 4289769648 4289769648 4289769648 4289835441 4292269782 4240095930 4249964881 4283979864 4289374890 4289769648 4289769648 4289769648 4279505940 4285558896 4286611584 4284308829 4278913803 4283058762 4286348412 4288782753 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4256873146 4249899088 4283979864 4289374890 4289769648 4289769648 4289769648 4281742902 4283124555 4286611584 4286611584 4285427310 4282664004 4280690214 4278913803 4280361249 4284243036 4289243304 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4240161723 4216344656 4283979864 4289374890 4289769648 4289769648 4289769648 4287927444 4278979596 4283979864 4286611584 4286611584 4286611584 4286611584 4286479998 4284506208 4281479730 4279637526 4287927444 4289769648 4289769648 4289769648 4289835441 4292335575 4206607291 4182724431 4283979864 4289374890 4289769648 4289769648 4289769648 4289769648 4287203721 4279966491 4279966491 4282532418 4284572001 4286282619 4286611584 4286611584 4286611584 4283124555 4280624421 4289769648 4289769648 4289769648 4289835441 4292335575 4172987066 4165947215 4283979864 4289374890 4289769648 4289769648 4289769648 4289769648 4289769648 4289703855 4287269514 4283585106 4280624421 4278782217 4281545523 4285953654 4286611584 4286545791 4278848010 4288651167 4289769648 4289769648 4289835441 4292335575 4172987066 4165947215 4283979864 4289374890 4289769648 4289769648 4289769648 4288453788 4288980132 4289769648 4289769648 4289769648 4289769648 4288585374 4282006074 4282137660 4286611584 4286611584 4280098077 4287203721 4289769648 4289769648 4289835441 4292335575 4172987066 4165947215 4283979864 4289374890 4289769648 4289769648 4289769648 4280098077 4278650631 4282532418 4287006342 4288914339 4289769648 4288848546 4282335039 4282203453 4286611584 4286611584 4279176975 4288387995 4289769648 4289769648 4289835441 4292335575 4172987066 4165947215 4283979864 4289374890 4289769648 4289769648 4289769648 4279900698 4284572001 4282729797 4280163870 4278848010 4278716424 4278782217 4280887593 4286019447 4286611584 4285427310 4278782217 4289703855 4289769648 4289769648 4289835441 4292335575 4172987066 4165947215 4283979864 4289374890 4289769648 4289769648 4289769648 4279900698 4285032552 4286611584 4286611584 4286611584 4286085240 4286545791 4286611584 4286611584 4286085240 4280098077 4284703587 4289769648 4289769648 4289769648 4289835441 4292335575 4172987066 4165947215 4283979864 4289374890 4289769648 4289769648 4289769648 4283124555 4278650631 4280558628 4282532418 4283519313 4284308829 4284440415 4283519313 4281940281 4278913803 4282992969 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4172987066 4165947215 4283979864 4289374890 4289769648 4289769648 4289769648 4289769648 4289309097 4286414205 4283782485 4282400832 4281150765 4281019179 4282335039 4283914071 4288322202 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4172987066 4165947215 4283979864 4289374890 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289769648 4289835441 4292335575 4172987066 4115483981 4216805207 4171934378 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172329136 4172394929 4225226711 4105878202) offset: 0@0)! ! !NautilusIcons methodsFor: 'icons' stamp: 'lr 3/29/2009 14:19'! string ^ ((ColorForm extent: 12@12 depth: 8 fromArray: #( 673716502 100672805 623061032 673717016 118757928 587409448 673710082 33825576 354166824 673717518 268698408 19277864 673714447 504037672 638134312 673720360 302655016 606152744 673720360 673588264 555886632 673720360 673456424 572991528 673720360 671621672 656418856 673720360 673654568 538912808 673720360 671948840 84682792 673720360 673128232 320284712) offset: 0@0) colorsFromArray: #(#(0.439 0.721 0.937) #(0.447 0.674 0.93) #(0.573 0.784 0.953) #(0.451 0.682 0.937) #(0.534 0.761 0.949) #(0.435 0.631 0.926) #(0.439 0.729 0.945) #(0.573 0.788 0.953) #(0.443 0.651 0.926) #(0.443 0.663 0.93) #(0.427 0.671 0.93) #(0.494 0.733 0.945) #(0.431 0.631 0.926) #(0.435 0.643 0.926) #(0.498 0.745 0.945) #(0.478 0.694 0.934) #(0.569 0.78 0.953) #(0.941 0.965 0.992) #(0.941 0.961 0.992) #(0.431 0.628 0.926) #(0.538 0.764 0.949) #(0.447 0.682 0.937) #(0.435 0.706 0.937) #(0.431 0.628 0.918) #(0.522 0.768 0.949) #(0.827 0.898 0.977) #(0.455 0.694 0.937) #(0.419 0.71 0.937) #(0.447 0.682 0.93) #(0.455 0.698 0.937) #(0.443 0.71 0.937) #(0.435 0.635 0.926) #(0.435 0.639 0.926) #(0.443 0.659 0.926) #(0.439 0.651 0.926) #(0.451 0.686 0.937) #(0.443 0.659 0.93) #(0.439 0.717 0.937) #(0.443 0.671 0.93) #(0.435 0.647 0.926) #( ) ))! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 4/6/2011 17:57'! testGreen ^(Form extent: 12@12 depth: 32 fromArray: #(16777215 16777215 16777216 1694498816 3003121664 3858759680 3858759680 3003121664 1694498816 16777216 16777215 16777215 16777215 436207616 3204448256 4278323202 4280376350 4283209800 4283603789 4281625137 4278454788 3204448256 436207616 16777215 16777216 3204448256 4279053323 4284135253 4285913199 4286964095 4287686539 4287686539 4286173300 4279974425 3204448256 16777216 1694498816 4278390018 4281819188 4281322278 4281584939 4283421512 4286701692 4287686539 4287686539 4286502265 4278718727 1694498816 3003121664 4278532866 4279526927 4278962688 4278962688 4278962688 4280077330 4285521256 4287686539 4287686539 4282680896 3003121664 3858759680 4278596868 4279588369 4278962688 4278962688 4278962688 4278962688 4279880718 4286505081 4287686539 4284724574 3858759680 3858759680 4278596100 4279775511 4279091970 4278962688 4278962688 4278962688 4278962688 4282700348 4286964095 4284330585 3858759680 3003121664 4278531331 4279838232 4280186137 4278962688 4278962688 4278962688 4278962688 4280863775 4285913199 4281432365 3003121664 1694498816 4278258432 4279710997 4280959017 4280909604 4279288326 4278962688 4278962688 4280928544 4284924000 4278718727 1694498816 16777216 3204448256 4278592773 4280634914 4281948471 4282806595 4282814529 4282884930 4284523356 4279448081 3204448256 16777216 16777215 436207616 3204448256 4278257409 4279649811 4280902950 4281167401 4279980312 4278388995 3204448256 436207616 16777215 16777215 16777215 16777216 1694498816 3003121664 3858759680 3858759680 3003121664 1694498816 16777216 16777215 16777215) offset: 0@0)! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 4/6/2011 17:54'! testNotRun ^(Form extent: 12@12 depth: 32 fromArray: #(16777215 16777215 16777216 1694498816 3003121664 3858759680 3858759680 3003121664 1694498816 16777216 16777215 16777215 16777215 436207616 3204448256 4278584838 4282795590 4286348412 4286611584 4283848278 4278716424 3204448256 436207616 16777215 16777216 3204448256 4280295456 4287927444 4289967027 4290690750 4291217094 4291217094 4289703855 4281216558 3204448256 16777216 1694498816 4278782217 4283453520 4287664272 4287861651 4288848546 4290559164 4291217094 4291217094 4290032820 4279111182 1694498816 3003121664 4280756007 4282861383 4286743170 4286743170 4286743170 4287269514 4289967027 4291217094 4291217094 4285361517 3003121664 3858759680 4280492835 4282203453 4286743170 4286743170 4286743170 4286743170 4287137928 4290493371 4291217094 4288059030 3858759680 3858759680 4280361249 4280821800 4286479998 4286743170 4286743170 4286743170 4286743170 4288453788 4290690750 4287795858 3858759680 3003121664 4280492835 4280361249 4283716692 4286743170 4286743170 4286743170 4286743170 4287598479 4289967027 4284374622 3003121664 1694498816 4278650631 4280953386 4281874488 4284440415 4286545791 4286743170 4286743170 4287466893 4288585374 4279111182 1694498816 16777216 3204448256 4279834905 4282269246 4283256141 4284572001 4285822068 4286611584 4287203721 4280756007 3204448256 16777216 16777215 436207616 3204448256 4278519045 4281611316 4283387727 4283782485 4282203453 4278650631 3204448256 436207616 16777215 16777215 16777215 16777216 1694498816 3003121664 3858759680 3858759680 3003121664 1694498816 16777216 16777215 16777215) offset: 0@0)! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 4/6/2011 17:58'! testRed ^(Form extent: 12@12 depth: 32 fromArray: #(16777215 16777215 16777216 1694498816 3003121664 3858759680 3858759680 3003121664 1694498816 16777216 16777215 16777215 16777215 436207616 3204448256 4278714882 4284227102 4288170056 4288367949 4285149489 4278846468 3204448256 436207616 16777215 16777216 3204448256 4281076491 4290205013 4292374383 4292968319 4293364619 4293364619 4291851380 4281997593 3204448256 16777216 1694498816 4279042562 4284494900 4291503654 4291636011 4292036680 4292902012 4293364619 4293364619 4292180345 4279305991 1694498816 3003121664 4282057218 4284878607 4291428352 4291428352 4291428352 4291564050 4292700264 4293364619 4293364619 4286988352 3003121664 3858759680 4281664516 4283830545 4291428352 4291428352 4291428352 4291428352 4291563022 4292901241 4293364619 4290076254 3858759680 3858759680 4281467908 4281407255 4290970114 4291428352 4291428352 4291428352 4291428352 4291968060 4292968319 4289878361 3858759680 3003121664 4281664259 4280686616 4285864217 4291428352 4291428352 4291428352 4291428352 4291567391 4292374383 4286131501 3003121664 1694498816 4278910976 4281668885 4282394921 4286522404 4290905606 4291428352 4291428352 4291371040 4290797664 4279305991 1694498816 16777216 3204448256 4280616197 4283310626 4284036919 4285612867 4287643969 4288889410 4288896092 4281471249 3204448256 16777216 16777215 436207616 3204448256 4278649089 4282782483 4284818982 4285409577 4283504664 4278780675 3204448256 436207616 16777215 16777215 16777215 16777216 1694498816 3003121664 3858759680 3858759680 3003121664 1694498816 16777216 16777215 16777215) offset: 0@0)! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 4/6/2011 17:58'! testYellow ^(Form extent: 12@12 depth: 32 fromArray: #(16777215 16777215 16777216 1694498816 3003121664 3858759680 3858759680 3003121664 1694498816 16777216 16777215 16777215 16777215 436207616 3204448256 4278782211 4285164839 4289375827 4289572953 4286020153 4278913797 3204448256 436207616 16777215 16777216 3204448256 4281545744 4291612771 4293915774 4294376077 4294705048 4294705048 4293191809 4282467102 3204448256 16777216 1694498816 4279176964 4285164603 4293850685 4294047809 4294113371 4294376074 4294705048 4294705048 4293521030 4279505928 1694498816 3003121664 4282862090 4286151963 4294377244 4294377244 4294377244 4294311212 4294376312 4294705048 4294705048 4288059722 3003121664 3858759680 4282335499 4284835867 4294377244 4294377244 4294377244 4294377244 4294311465 4294376327 4294705048 4291349354 3858759680 3858759680 4282072330 4281808922 4293785117 4294377244 4294377244 4294377244 4294377244 4294113616 4294376077 4291218021 3858759680 3003121664 4282467082 4280887578 4287204646 4294377244 4294377244 4294377244 4294377244 4294113847 4293915774 4287270200 3003121664 1694498816 4279111170 4282137882 4282795820 4287862577 4293653536 4294377244 4294377244 4293784887 4292139373 4279505928 1694498816 16777216 3204448256 4281019657 4283914536 4284506684 4286283082 4288783436 4290362703 4289836389 4282006550 3204448256 16777216 16777215 436207616 3204448256 4278716418 4283519770 4285756975 4286415155 4284375328 4278848004 3204448256 436207616 16777215 16777215 16777215 16777216 1694498816 3003121664 3858759680 3858759680 3003121664 1694498816 16777216 16777215 16777215) offset: 0@0)! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 11/12/2011 16:12'! trait ^(Form extent: 12@12 depth: 32 fromArray: #(16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 201326592 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 50331648 2734686208 16777215 16777215 855638016 1224736768 1023410176 838860800 1174405120 1207959552 1191182336 1895825408 2181038080 704643072 33554432 2399141888 1409286144 201326592 16777215 83886080 3640655872 922746880 16777215 16777215 16777215 16777215 1426063360 503316480 16777215 16777215 16777215 1862270976 2483027968 16777215 16777215 16777215 16777215 16777215 1258291200 16777215 16777215 16777215 318767104 3556769792 234881024 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 2516582400 1476395008 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 788529152 3254779904 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777216 3238002688 905969664 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1610612736 2801795072 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 67108864 3892314112 1258291200 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 2147483648 1862270976 788529152 16777215 16777215 16777215 16777215 16777215 16777215 16777215) offset: 0@0)! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 11/12/2011 16:25'! uncommentedClass ^(Form extent: 12@12 depth: 32 fromArray: #(16777215 16777215 16777215 16777215 16777215 1361772544 2905276416 1865089024 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 2976382976 4292214784 2402025472 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 2727280640 4294901760 2201354240 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 2055667712 4294574080 1797980160 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1634795520 4293787648 1445658624 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1903165440 4292804608 908787712 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 2256076800 4291231744 254476288 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 2625503232 4088987648 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1350893568 566165504 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 596443136 132186112 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1664483328 4242014208 3669098496 120258560 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1227554816 3985440768 1986789376 16777215 16777215 16777215 16777215 16777215) offset: 0@0)! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 5/11/2011 14:04'! up ^(Form extent: 24@24 depth: 32 fromArray: #(16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1107301120 1107301120 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1006636288 3808439296 3808439296 1006636288 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 805309184 3774883072 4278222336 4278222336 3774883072 805309184 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 637536000 3724550656 4278221824 4278222848 4278222848 4278221824 3724550656 637536000 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 503316480 3674217984 4278221312 4278222848 3841995520 3841995520 4278222848 4278221312 3674217984 503316480 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 385875968 3607108352 4278220800 4278222848 3909105664 1442845184 1442845184 3909105664 4278222848 4278220800 3607108352 385875968 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 285212672 3523221504 4278220032 4278222848 3959439616 1761612544 16777215 16777215 1761612544 3959439616 4278222848 4278220032 3523221504 285212672 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 201326592 3439334912 4278219264 4278222848 4009773568 2046825728 16777215 16777215 16777215 16777215 2046825728 4009773568 4278222848 4278219264 3439334912 201326592 16777215 16777215 16777215 16777215 16777215 16777215 16777215 134217728 3338671360 4261440768 4278222848 4060107264 2365592576 16777215 16777215 16777215 16777215 16777215 16777215 2365592576 4060107264 4278222848 4261440768 3338671360 134217728 16777215 16777215 16777215 16777215 16777215 83886080 3204453376 4244662528 4278222848 4127218176 2634028288 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 2634028288 4127218176 4278222848 4244662528 3204453376 83886080 16777215 16777215 16777215 33554432 3053458432 4194329856 4278222848 4177551616 2885686528 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 2885686528 4177551616 4278222848 4194329856 3053458432 33554432 16777215 16777215 1509951744 4076880384 4278222848 4227885056 3087013120 33554432 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 33554432 3087013120 4227885056 4278222848 4076880384 1509951744 16777215 16777215 33554432 2919240960 4160769280 3271562752 100663296 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 100663296 3271562752 4160769280 2919240960 33554432 16777215 16777215 16777215 33554432 1996492544 167772160 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 167772160 1996492544 33554432 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215) offset: 0@0)! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 5/11/2011 14:08'! upFull ^(Form extent: 24@24 depth: 32 fromArray: #(16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 234881024 805306368 805306368 805306368 805306368 805306368 805306368 805306368 805306368 805306368 805306368 805306368 805306368 805306368 805306368 805306368 805306368 805306368 805306368 805306368 805306368 234881024 16777215 16777215 2483032832 4076880128 4043327744 4043327744 4043327744 4043327744 4043327744 4043327744 4043327744 4043327744 4043327744 4043327744 4043327744 4043327744 4043327744 4043327744 4043327744 4043327744 4043327744 4043327744 4076880128 2483032832 16777215 16777215 2550141952 4278219776 4278222848 4278222848 4278222848 4278222848 4278222848 4278222848 4278222848 4278222848 4278222848 4278222848 4278222848 4278222848 4278222848 4278222848 4278222848 4278222848 4278222848 4278222848 4278219776 2550141952 16777215 16777215 2550141952 4278219776 4278222848 4278222848 4278222848 4278222848 4278222848 4278222848 4278222848 4278222848 4278222848 4278222848 4278222848 4278222848 4278222848 4278222848 4278222848 4278222848 4278222848 4278222848 4278219776 2550141952 16777215 16777215 2231374080 3791660032 3741329664 3741329664 3741329664 3741329664 3741329664 3741329664 3741329664 3741329664 3875547136 3875547136 3741329664 3741329664 3741329664 3741329664 3741329664 3741329664 3741329664 3741329664 3791660032 2231374080 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1006636288 3808439296 3808439296 1006636288 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 805309184 3774883072 4278222336 4278222336 3774883072 805309184 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 637536000 3724550656 4278221824 4278222848 4278222848 4278221824 3724550656 637536000 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 503316480 3674217984 4278221312 4278222848 3841995520 3841995520 4278222848 4278221312 3674217984 503316480 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 385875968 3607108352 4278220800 4278222848 3909105664 1442845184 1442845184 3909105664 4278222848 4278220800 3607108352 385875968 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 285212672 3523221504 4278220032 4278222848 3959439616 1761612544 16777215 16777215 1761612544 3959439616 4278222848 4278220032 3523221504 285212672 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 201326592 3439334912 4278219264 4278222848 4009773568 2046825728 16777215 16777215 16777215 16777215 2046825728 4009773568 4278222848 4278219264 3439334912 201326592 16777215 16777215 16777215 16777215 16777215 16777215 16777215 134217728 3338671360 4261440768 4278222848 4060107264 2365592576 16777215 16777215 16777215 16777215 16777215 16777215 2365592576 4060107264 4278222848 4261440768 3338671360 134217728 16777215 16777215 16777215 16777215 16777215 83886080 3204453376 4244662528 4278222848 4127218176 2634028288 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 2634028288 4127218176 4278222848 4244662528 3204453376 83886080 16777215 16777215 16777215 33554432 3053458432 4194329856 4278222848 4177551616 2885686528 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 2885686528 4177551616 4278222848 4194329856 3053458432 33554432 16777215 16777215 1509951744 4076880384 4278222848 4227885056 3087013120 33554432 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 33554432 3087013120 4227885056 4278222848 4076880384 1509951744 16777215 16777215 33554432 2919240960 4160769280 3271562752 100663296 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 100663296 3271562752 4160769280 2919240960 33554432 16777215 16777215 16777215 33554432 1996492544 167772160 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 167772160 1996492544 33554432 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215) offset: 0@0)! ! !NautilusIcons methodsFor: 'icons' stamp: 'BenjaminVanRyseghem 8/23/2011 17:49'! warning ^(Form extent: 16@16 depth: 32 fromArray: #(16777215 16777215 16777215 16777215 16777215 16777215 16777215 2919235584 2919235584 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1207959552 4278190080 4278190080 1207959552 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 3338665984 4278255872 4278255872 3338665984 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1207959552 4278190080 4283643907 4283643907 4278190080 1207959552 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 3338665984 4278255872 4291923463 4291923463 4278255872 3338665984 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1207959552 4278190080 4283643907 4294946056 4294946056 4283643907 4278190080 1207959552 16777215 16777215 16777215 16777215 16777215 16777215 16777215 16777215 3338665984 4278255872 4291923463 4294946056 4294946056 4291923463 4278255872 3338665984 16777215 16777215 16777215 16777215 16777215 16777215 16777215 1207959552 4278190080 4283578371 4294946056 4294946056 4294946056 4294946056 4283578371 4278190080 1207959552 16777215 16777215 16777215 16777215 16777215 16777215 3338665984 4278255872 4291857671 4294946056 4294946056 4294946056 4294946056 4291857671 4278255872 3338665984 16777215 16777215 16777215 16777215 16777215 1207959552 4278190080 4283512579 4294946056 4294946056 4294946056 4294946056 4294946056 4294946056 4283512579 4278190080 1207959552 16777215 16777215 16777215 16777215 3338665984 4278255872 4291857671 4294946056 4294946056 4294946056 4294946056 4294946056 4294946056 4291857671 4278255872 3338665984 16777215 16777215 16777215 1207959552 4278190080 4283446787 4294946056 4294946056 4294946056 4294946056 4294946056 4294946056 4294946056 4294946056 4283446787 4278190080 1207959552 16777215 16777215 3338665984 4278255872 4291791878 4294946056 4294946056 4294946056 4294946056 4294946056 4294946056 4294946056 4294946056 4291791878 4278255872 3338665984 16777215 1207959552 4278190080 4283446787 4294946056 4294946056 4294946056 4294946056 4294946056 4294946056 4294946056 4294946056 4294946056 4294946056 4283446787 4278190080 1207959552 3288334336 4278190080 4280818433 4282329858 4282329858 4282329858 4282329858 4282329858 4282329858 4282329858 4282329858 4282329858 4282329858 4280818433 4278190080 3321888768 3238068224 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 4278190080 3254845440) offset: 0@0)! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NautilusIcons class instanceVariableNames: ''! !NautilusIcons class methodsFor: 'accessing' stamp: 'lr 3/28/2009 16:15'! default ^ Instance ifNil: [ Instance := self new ]! ! !NautilusIcons class methodsFor: 'accessing' stamp: 'dr 9/4/2008 16:35'! iconNamed: aSymbol ^ Icons at: aSymbol ifAbsentPut: [self default perform: aSymbol]! ! !NautilusIcons class methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 1/24/2013 11:31'! initialize Instance := nil. Icons := IdentityDictionary new! ! Announcement subclass: #NautilusKeyPressed instanceVariableNames: 'key' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Announcements'! !NautilusKeyPressed commentStamp: '' prior: 0! 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 instanceVariableNames: ''! !NautilusKeyPressed class methodsFor: 'as yet unclassified' stamp: 'BenjaminVanRyseghem 5/10/2011 12:26'! key: aKey ^ self new key: aKey! ! Object subclass: #NautilusMCBindings instanceVariableNames: 'bindingsRtoMC bindingsMCtoR' classVariableNames: 'Default' poolDictionaries: '' category: 'Nautilus-MCBindings'! !NautilusMCBindings commentStamp: '' prior: 0! A NautilusMCBindings is a class which basically kept bindings between RPackages and MCPackage! !NautilusMCBindings methodsFor: 'announcements'! mcWorkingCopyCreated: anAnnouncement | package rpackage mcPackage | package := anAnnouncement package. package ifNil: [ ^ self ]. rpackage := RPackageOrganizer default packageNamed: package name. mcPackage := bindingsRtoMC at: rpackage ifAbsent: [ ^ self ]. (bindingsMCtoR at: mcPackage) do: [:pck | bindingsRtoMC removeKey: pck ifAbsent: []]! ! !NautilusMCBindings methodsFor: 'announcements'! mcWorkingCopyDeleted: anAnnouncement | package rpackages | package := anAnnouncement package. package ifNil: [ ^ self ]. rpackages := bindingsMCtoR at: package ifAbsent: [ ^self ]. rpackages do: [:rpackage | bindingsRtoMC removeKey: rpackage ifAbsent: [ ]]. bindingsMCtoR removeKey: package ifAbsent: []! ! !NautilusMCBindings methodsFor: 'initialization'! initialize "Initialization code for NautilusMCBindings" super initialize. bindingsRtoMC := IdentityDictionary new. bindingsMCtoR := IdentityDictionary new. self registerToMCAnnouncements.! ! !NautilusMCBindings methodsFor: 'initialization' stamp: 'EstebanLorenzano 8/3/2012 14:12'! registerToMCAnnouncements SystemAnnouncer uniqueInstance weak on: MCWorkingCopyCreated send: #mcWorkingCopyCreated: to: self; on: MCWorkingCopyDeleted send: #mcWorkingCopyDeleted: to: self! ! !NautilusMCBindings methodsFor: 'protocol'! mcPackageFor: aRPackage ^ bindingsRtoMC at: aRPackage ifAbsent: [ ( self retrieveMCPackageFor: aRPackage ) ifNotNil: [:mcPackage | (bindingsMCtoR at: mcPackage ifAbsentPut: (Set new)) add: aRPackage. bindingsRtoMC at: aRPackage put: mcPackage ] ifNil: [ nil ]]! ! !NautilusMCBindings methodsFor: 'protocol'! rPackagesFor: aMCPackage ^ bindingsMCtoR at: aMCPackage ifAbsentPut: [ self retrieveRPackagesFor: aMCPackage ]! ! !NautilusMCBindings methodsFor: 'private'! retrieveMCPackageFor: aRPackage | name mcPackages | mcPackages := MCWorkingCopy allManagers. name := aRPackage name. [ name isEmpty ] whileFalse: [| package | package := (mcPackages detect: [ :mc | mc package name = name ] ifNone: [ nil ]). package ifNil: [ name := (name subStrings: '-') allButLast joinUsing: '-' ] ifNotNil: [ ^ package package ]]. ^ nil! ! !NautilusMCBindings methodsFor: 'private'! retrieveRPackagesFor: aMCPackage ^ (RPackageOrganizer default packages select: [:e | e name beginsWith: aMCPackage name ]) asSet! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NautilusMCBindings class instanceVariableNames: ''! !NautilusMCBindings class methodsFor: 'initialization'! initialize "Initialization code for NautilusMCBindings class" super initialize. RPackageOrganizer default packages do: [:p | self default mcPackageFor: p ]! ! !NautilusMCBindings class methodsFor: 'instance creation'! default ^ Default ifNil: [ Default := self basicNew initialize ]! ! !NautilusMCBindings class methodsFor: 'instance creation'! new self error: 'I am a singleton'! ! Announcement subclass: #NautilusMethodSelected instanceVariableNames: 'method' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Announcements'! !NautilusMethodSelected commentStamp: '' prior: 0! 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 instanceVariableNames: ''! !NautilusMethodSelected class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 5/10/2011 14:49'! method: aMethod ^ self new method: aMethod! ! Object subclass: #NautilusMonticello instanceVariableNames: '' classVariableNames: 'Default' poolDictionaries: '' category: 'Nautilus'! !NautilusMonticello commentStamp: '' prior: 0! A NautilusMonticello is a class used to handle monticello integration into Nautilus by creating the menu entries! !NautilusMonticello methodsFor: 'display'! 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'! addRepositoryTo: aGroup | repo | (repo := self newRepository) ifNil: [ ^ self ]. aGroup addRepository: repo.! ! !NautilusMonticello methodsFor: 'monticello menus behavior'! addSliceFor: aWindow (MCSliceMaker openFor: aWindow) ifNotNil: [:sliceInfo || workingCopy | workingCopy := sliceInfo makeSlice. workingCopy ifNotNil: [ workingCopy repositoryGroup addRepository: MCHttpRepository inboxRepository. ^ workingCopy ]]. ^ nil! ! !NautilusMonticello methodsFor: 'monticello menus behavior'! commit: workingCopy in: repo | newVersion | newVersion := workingCopy newVersion. newVersion ifNil: [ ^ self ]. Cursor wait showWhile: [ [ repo storeVersion: newVersion. repo storeDependencies: newVersion ] ensure: [ (MCVersionInspector new version: newVersion) show ]]! ! !NautilusMonticello methodsFor: 'monticello menus behavior'! createMCPackageFor: aPackage | name | name := aPackage name. name isEmptyOrNil ifFalse: [ MCWorkingCopy forPackage: (MCPackage new name: name) ]! ! !NautilusMonticello methodsFor: 'monticello menus behavior'! 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'! open: mcpackage in: repo | workingCopy | repo ifNil: [ ^ self ]. workingCopy := mcpackage workingCopy. repo morphicOpen: workingCopy! ! !NautilusMonticello methodsFor: 'monticello menus behavior'! postNewSliceFor: aWindow | workingCopy | (workingCopy := self addSliceFor: aWindow) ifNil: [ ^ self ]. self commit: workingCopy in: MCHttpRepository inboxRepository! ! !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 class instanceVariableNames: ''! !NautilusMonticello class methodsFor: 'instance creation'! new self default! ! !NautilusMonticello class methodsFor: 'monticello menus' stamp: 'EstebanLorenzano 1/30/2013 15:52'! packagesChangesMenu: aBuilder | package mcpackage target | target := aBuilder model. (package := target selectedPackage) ifNil: [ ^ target ]. mcpackage := (NautilusMCBindings default mcPackageFor: package). mcpackage ifNil: [ ^ self ]. mcpackage isDirty ifTrue: [ (aBuilder item: #('Changes with ',package name)) label: 'Changes with...'; order: 1295; help: 'Changes'; icon: (self iconClass iconNamed: #monticelloPackage); 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 1/30/2013 15:52'! packagesCommitsMenu: aBuilder | package mcpackage target | target := aBuilder model. (package := target selectedPackage) ifNil: [ ^ target ]. mcpackage := (NautilusMCBindings default mcPackageFor: package). mcpackage ifNil: [ ^self ]. mcpackage isDirty ifTrue: [ | last group | (aBuilder item: #('Commit in ',package name)) label: 'Commit in...'; order: 1296; help: 'Commit'; icon: (self iconClass iconNamed: #monticelloPackage); 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 ]]! ! !NautilusMonticello class methodsFor: 'monticello menus' stamp: 'EstebanLorenzano 1/30/2013 15:52'! packagesCreateMenu: aBuilder | package mcpackage target | target := aBuilder model. (package := target selectedPackage) ifNil: [ ^ target ]. mcpackage := NautilusMCBindings default mcPackageFor: package. mcpackage ifNotNil: [ ^ self ]. (aBuilder item: #'Create a MC package') order: 1297; help: 'Create a MC package corresponding to my name'; icon: (self iconClass iconNamed: #monticelloPackage); action: [ self default createMCPackageFor: target selectedPackage ]; enabledBlock: [ target selectedPackages size < 2 ].! ! !NautilusMonticello class methodsFor: 'monticello menus' stamp: 'EstebanLorenzano 1/30/2013 15:52'! packagesOpenMenu: aBuilder | package mcpackage target last group | target := aBuilder model. (package := target selectedPackage) ifNil: [ ^ target ]. mcpackage := NautilusMCBindings default mcPackageFor: package. mcpackage ifNil: [ ^ self ]. (aBuilder item: #('Open ',package name)) label: 'Open...'; order: 1297; help: 'Open'; icon: (self iconClass iconNamed: #monticelloPackage); 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: 'monticello menus' stamp: 'EstebanLorenzano 1/30/2013 15:52'! packagesSliceMenu: aBuilder | target | target := aBuilder model. (aBuilder item: #'Create Slice and commit it') order: 1298; help: 'Create a slice and commit it into PharoInbox'; action: [ self default postNewSliceFor: target window ]; icon: (self iconClass iconNamed: #monticelloPackage). (aBuilder item: #'Create Slice') order: 1299; help: 'Create a slice'; action: [ self default addSliceFor: target window ]; icon: (self iconClass iconNamed: #monticelloPackage); withSeparatorAfter.! ! !NautilusMonticello class methodsFor: 'singleton'! default ^ Default ifNil: [ Default := self basicNew initialize ]! ! !NautilusMonticello class methodsFor: 'private'! iconClass ^ NautilusIcons! ! Announcement subclass: #NautilusPackageSelected instanceVariableNames: 'package' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Announcements'! !NautilusPackageSelected commentStamp: '' prior: 0! A NautilusPackageSelected is raised when a package is selected! !NautilusPackageSelected methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/4/2011 14:15'! package ^ package! ! !NautilusPackageSelected methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/4/2011 14:15'! package: anObject package := anObject! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NautilusPackageSelected class instanceVariableNames: ''! !NautilusPackageSelected class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 5/10/2011 12:28'! package: aPackage ^ self new package: aPackage! ! DialogWindow subclass: #NautilusPluginManager instanceVariableNames: 'pluginClassesSelectedIndex pluginClassesSelected pluginsSelected pluginsSelectedIndex pluginsList tree' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Plugin-Manager'! !NautilusPluginManager commentStamp: '' prior: 0! NautilusPluginManager is a manger of plugins used to set up plugin for Nautilus UI! !NautilusPluginManager methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/11/2011 15:51'! pluginClassesSelected ^ pluginClassesSelected! ! !NautilusPluginManager methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/11/2011 15:51'! pluginClassesSelected: anObject pluginClassesSelected := anObject! ! !NautilusPluginManager methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/11/2011 15:51'! pluginsList ^ pluginsList! ! !NautilusPluginManager methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/11/2011 15:51'! pluginsList: anObject pluginsList := anObject! ! !NautilusPluginManager methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/11/2011 15:51'! pluginsSelected ^ pluginsSelected! ! !NautilusPluginManager methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/11/2011 15:51'! pluginsSelected: anObject pluginsSelected := anObject! ! !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: 'buttons behavior' stamp: 'BenjaminVanRyseghem 5/11/2011 15:47'! addButtonLabel ^ 'Add'! ! !NautilusPluginManager methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 5/11/2011 15:50'! addButtonState ^ self selectedPluginClasses isEmpty not! ! !NautilusPluginManager methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 1/19/2012 13:32'! removeButtonAction self selectedPlugins reverse do: [:item || index | 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:47'! removeButtonLabel ^ 'Remove'! ! !NautilusPluginManager methodsFor: 'buttons behavior' stamp: 'BenjaminVanRyseghem 5/11/2011 15:49'! removeButtonState ^ self selectedPlugins isEmpty not! ! !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 5/11/2011 15:49'! buildPluginsBox ^ GroupboxMorph new addContentMorph: self buildPluginsList; addContentMorph: self buildRemoveButton; label: 'Selected plugins:'; 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: 'display' stamp: 'BenjaminVanRyseghem 5/11/2011 15:57'! openInWorld super openInWorld. self width: 500. self height: 400. self centering! ! !NautilusPluginManager methodsFor: 'display' stamp: 'BenjaminVanRyseghem 5/11/2011 11:28'! title ^ 'Nautilus Plugins Manager'! ! !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: 'items creation' stamp: 'BenjaminVanRyseghem 5/11/2011 14:52'! buildButtonsColumn | column fill | 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 2/17/2012 16:32'! buildDescriptionTextArea ^ (PluggableTextMorph on: self text: #getText accept: nil) enabled: false; vResizing: #spaceFill; hResizing: #spaceFill; yourself! ! !NautilusPluginManager methodsFor: 'items creation' stamp: 'BenjaminVanRyseghem 5/11/2011 14:48'! buildDownButton ^ IconicButton new target: self; actionSelector: #down; labelGraphic: (self iconClass iconNamed: #down); color: Color transparent; extent: 24 @ 24; borderWidth: 0! ! !NautilusPluginManager methodsFor: 'items creation' stamp: 'BenjaminVanRyseghem 5/11/2011 14:48'! buildFullDownButton ^ IconicButton new target: self; actionSelector: #fullDown; labelGraphic: (self iconClass iconNamed: #downFull); color: Color transparent; extent: 24 @ 24; borderWidth: 0! ! !NautilusPluginManager methodsFor: 'items creation' stamp: 'BenjaminVanRyseghem 5/11/2011 14:12'! buildFullUpButton ^ IconicButton new target: self; actionSelector: #fullUp; labelGraphic: (self iconClass iconNamed: #upFull); color: Color transparent; extent: 24 @ 24; borderWidth: 0! ! !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: '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: '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: 'items creation' stamp: 'BenjaminVanRyseghem 5/11/2011 14:33'! buildUpButton ^ IconicButton new target: self; actionSelector: #up; labelGraphic: (self iconClass iconNamed: #up); color: Color transparent; extent: 24 @ 24; borderWidth: 0! ! !NautilusPluginManager methodsFor: 'lists behavior' stamp: 'BenjaminVanRyseghem 5/2/2012 13:18'! getPluginClassesList ^ AbstractNautilusPlugin allSubclasses sort: [:a :b | a pluginName <= b pluginName ]! ! !NautilusPluginManager methodsFor: 'lists behavior' stamp: 'BenjaminVanRyseghem 8/25/2011 12:48'! getPluginsList ^ pluginsList ifNil: [ pluginsList := Nautilus pluginClasses copy ].! ! !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: '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 5/11/2011 11:23'! pluginClassesSelectedIndex ^ pluginClassesSelectedIndex ifNil: [ pluginClassesSelectedIndex := 0 ]! ! !NautilusPluginManager methodsFor: 'lists behavior' stamp: 'BenjaminVanRyseghem 2/17/2012 16:32'! pluginClassesSelectedIndex: anInteger pluginClassesSelectedIndex := anInteger. self changed: #pluginClassesSelectedIndex. self changed: #getText.! ! !NautilusPluginManager methodsFor: 'lists behavior' stamp: 'BenjaminVanRyseghem 5/11/2011 13:25'! resetPluginClassesListSelection pluginClassesSelected removeAll! ! !NautilusPluginManager methodsFor: 'lists behavior' stamp: 'BenjaminVanRyseghem 5/11/2011 13:33'! resetPluginsListSelection pluginsSelected removeAll! ! !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: 'lists behavior' stamp: 'BenjaminVanRyseghem 8/25/2011 13:55'! selectedPlugins ^ tree selectedMorphList collect:[:each | each complexContents item ]! ! !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: 'tree' stamp: 'BenjaminVanRyseghem 8/25/2011 13:50'! pluginsSelectedIndex: anIndex! ! !NautilusPluginManager methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/11/2011 15:56'! applyChanges Nautilus pluginClasses: self pluginsList! ! !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: '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: '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: 'private' stamp: 'BenjaminVanRyseghem 8/25/2011 13:52'! fullUp | list selection maxSize | 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: 'private' stamp: 'BenjaminVanRyseghem 5/11/2011 14:13'! iconClass ^ NautilusIcons! ! !NautilusPluginManager methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/11/2011 13:39'! initialize super initialize. pluginClassesSelected := Dictionary new. pluginsSelected := Dictionary new.! ! !NautilusPluginManager methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/11/2011 13:45'! isResizeable ^true! ! !NautilusPluginManager methodsFor: 'private' stamp: 'BenjaminVanRyseghem 8/25/2011 11:11'! treeClass ^ NautilusPluginManagerTree! ! !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.! ! MorphTreeModel subclass: #NautilusPluginManagerTree instanceVariableNames: 'model' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Plugin-Manager'! !NautilusPluginManagerTree commentStamp: '' prior: 0! A NautilusPluginManagerTree is a tree which is used to render the plugins selection! !NautilusPluginManagerTree methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/25/2011 11:09'! model ^ model! ! !NautilusPluginManagerTree methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/25/2011 11:09'! model: anObject model := anObject! ! !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 methodsFor: 't - accessing' stamp: 'BenjaminVanRyseghem 8/25/2011 12:49'! rootItems ^ self model getPluginsList! ! !NautilusPluginManagerTree methodsFor: 't - accessing' stamp: 'BenjaminVanRyseghem 8/25/2011 10:44'! rootNodeClassFromItem: anItem ^ PluginTreeNode! ! !NautilusPluginManagerTree methodsFor: 't - accessing' stamp: 'BenjaminVanRyseghem 8/25/2011 11:22'! update self changed: #rootNodes! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NautilusPluginManagerTree class instanceVariableNames: ''! !NautilusPluginManagerTree class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 8/25/2011 11:10'! model: aModel ^ self new model: aModel! ! Announcement subclass: #NautilusProtocolSelected instanceVariableNames: 'category' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Announcements'! !NautilusProtocolSelected commentStamp: '' prior: 0! 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 instanceVariableNames: ''! !NautilusProtocolSelected class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 5/10/2011 17:17'! category: anObject ^ self new category: anObject! ! Object subclass: #NautilusRefactoring instanceVariableNames: 'environment model' classVariableNames: 'PromptOnRefactoring' poolDictionaries: '' category: 'NautilusRefactoring'! !NautilusRefactoring commentStamp: '' prior: 0! NautilusRefactoring is a facade for refactorings: - class - method - inst var - class var - source code! !NautilusRefactoring methodsFor: 'accessing'! model ^ model! ! !NautilusRefactoring methodsFor: 'accessing'! model: aNautilusUI model := aNautilusUI. environment := (RBNamespace onEnvironment: aNautilusUI browsedEnvironment) name: self printString; yourself.! ! !NautilusRefactoring methodsFor: 'class'! 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: 'class' stamp: 'BenjaminVanRyseghem 4/18/2012 17:11'! changeSuperclassOf: aClass "should be implemented if it really makes sense" self model sourceTextArea flash! ! !NautilusRefactoring methodsFor: 'class'! 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: '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: '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: '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: 'class'! 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'! 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'! splitClass: aClass | refactoring | aClass ifNil: [ ^ self ]. refactoring := self privateSplitClassFor: aClass. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'class var'! abstractClassVarFrom: aClass | refactoring | aClass ifNil: [ ^ self ]. refactoring := self privateAbstractClassVarFrom: aClass. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'class var'! accessorsClassVarFrom: aClass | refactoring | aClass ifNil: [ ^ self ]. refactoring := self privateAccessorsClassVarFrom: aClass. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'class var'! 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'! pullUpClassVarFrom: aClass | refactoring | aClass ifNil: [ ^ self ]. refactoring := self privatePullUpClassVarFrom: aClass. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'class var'! 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 var'! removeClassVarFrom: aClass | refactoring | aClass ifNil: [ ^ self ]. refactoring := self privateRemoveClassVarFrom: aClass. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'class var'! renameClassVarFrom: aClass | refactoring | aClass ifNil: [ ^ self ]. refactoring := self privateRenameClassVarFrom: aClass. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !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: 'display'! 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: 'display'! chooseMultipleFrom: anArray ^ self chooseMultipleFrom: anArray title: ''! ! !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: 'display'! 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: 'display'! 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: '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: '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: 'display'! handleMethodNameRequest: aMethodName ^ (MethodNameEditor openOn: aMethodName) methodName! ! !NautilusRefactoring methodsFor: 'display' stamp: 'CamilloBruni 10/7/2012 23:24'! handleWarning: anException self inform: anException messageText. anException resume.! ! !NautilusRefactoring methodsFor: 'display'! request: aString ^ UIManager default request: aString initialAnswer: ''! ! !NautilusRefactoring methodsFor: 'display'! request: aString initialAnswer: aTemplateString ^ UIManager default request: aString initialAnswer: aTemplateString ! ! !NautilusRefactoring methodsFor: 'display'! requestMethodNameFor: aMethodName ^ self handleMethodNameRequest: aMethodName! ! !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: 'inst var'! abstractInstVarFrom: aClass | refactoring | aClass ifNil: [ ^ self ]. refactoring := self privateAbstractInstVarFrom: aClass. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'inst var'! accessorsInstVarFrom: aClass | refactoring | aClass ifNil: [ ^ self ]. refactoring := self privateAccessorsInstVarFrom: aClass. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'inst var'! addInstVarFrom: aClass | refactoring | aClass ifNil: [ ^ self ]. refactoring := self privateAddInstVarFrom: aClass. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'inst var'! pullUpInstVarFrom: aClass | refactoring | aClass ifNil: [ ^ self ]. refactoring := self privatePullUpInstVarFrom: aClass. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'inst var'! pushDownInstVarFrom: aClass | refactoring | aClass ifNil: [ ^ self ]. refactoring := self privatePushDownInstVarFrom: aClass. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'inst var'! removeInstVarFrom: aClass | refactoring | aClass ifNil: [ ^ self ]. refactoring := self privateRemoveInstVarFrom: aClass. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'inst var'! 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: '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: 'method'! addAParameterFor: aMethod | refactoring | aMethod ifNil: [ ^ self ]. refactoring := self privateAddAParameterFor: aMethod. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'method'! inlineAllSendersFor: aMethod | refactoring | aMethod ifNil: [ ^ self ]. refactoring := self privateInlineAllSendersFor: aMethod. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'method'! inlineParameterFor: aMethod | refactoring | aMethod ifNil: [ ^ self ]. refactoring := self privateInlineParameterFor: aMethod. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'method'! moveMethodFor: aMethod | refactoring | aMethod ifNil: [ ^ self ]. refactoring := self privateMoveMethodFor: aMethod. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'method'! pullUpMethodsFor: aCollection | refactoring | aCollection ifEmpty: [ ^ self ]. refactoring := self privatePullUpMethodsFor: aCollection. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'method'! pushDownMethodsFor: aCollection | refactoring | aCollection ifEmpty: [ ^ self ]. refactoring := self privatePushDownMethodsFor: aCollection. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'method'! removeMethodsFor: aCollection | refactoring | aCollection ifEmpty: [ ^ self ]. refactoring := self privateRemoveMethodsFor: aCollection. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'method'! removeParameterFor: aMethod | refactoring | aMethod ifNil: [ ^ self ]. refactoring := self privateRemoveParameterMethodFor: aMethod. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'method'! renameMethodFor: aMethod | refactoring | aMethod ifNil: [ ^ self ]. refactoring := self privateRenameMethodFor: aMethod. refactoring ifNil: [ ^ self ]. refactoring model environment: self model browsedEnvironment. self performRefactoring: refactoring! ! !NautilusRefactoring methodsFor: 'method'! 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: 'option'! openEnvironment: anEnvironment for: aRefactoring anEnvironment isEmpty ifTrue: [ ^ self inform: 'Empty scope' ]. Smalltalk tools browser fullOnEnvironment: anEnvironment! ! !NautilusRefactoring methodsFor: 'option'! promptOnRefactoring ^ self class promptOnRefactoring! ! !NautilusRefactoring methodsFor: 'option'! 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: 'option'! requestSelfArgumentName ^ self request: 'Enter name for argument to refer to "self" in extracted method'! ! !NautilusRefactoring methodsFor: 'option'! 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: 'option'! selectVariableTypesFrom: aCollectionOfTypes selected: aSelectedCollection for: aRefactoring | stream result | stream := WriteStream on: String new. aCollectionOfTypes do: [ :each | stream nextPutAll: each name ] separatedBy: [ stream cr ]. result := UITheme current 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 isNil ifTrue: [ ^ nil ]. ^ (result asString findTokens: String crlf) collect: [ :each | aRefactoring model classFor: (Smalltalk classNamed: each trimBoth) ] ! ! !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: 'option'! 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: '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: 'performing'! 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: '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: 'rewrite code'! categoryRegex self model sourceCode: self categoryRegexText! ! !NautilusRefactoring methodsFor: 'rewrite code'! categoryRegexText ^ 'RBCategoryRegexRefactoring new replace: ''^Kernel-(.*)$'' with: ''System-$1'' ignoreCase: false; yourself'! ! !NautilusRefactoring methodsFor: 'rewrite code'! classRegex self model sourceCode: self classRegexText! ! !NautilusRefactoring methodsFor: 'rewrite code'! 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: 'rewrite code'! protocolRegex self model sourceCode: self protocolRegexText! ! !NautilusRefactoring methodsFor: 'rewrite code'! protocolRegexText ^ 'RBProtocolRegexRefactoring new replace: ''^\*system(.*)$'' with: ''*kernel$1'' ignoreCase: true; yourself'! ! !NautilusRefactoring methodsFor: 'rewrite code'! rewriteCode self model sourceCode: self rewriteCodeText! ! !NautilusRefactoring methodsFor: 'rewrite code'! 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: 'rewrite code'! searchCode self model sourceCode: self searchCodeText! ! !NautilusRefactoring methodsFor: 'rewrite code'! searchCodeText ^ 'RBParseTreeSearcher new matches: ''`@object'' do: [ :node :answer | node ]; matchesMethod: ''`@method: `@args | `@temps | `@.statements'' do: [ :node :answer | node ]; yourself'! ! !NautilusRefactoring methodsFor: 'rewrite code'! sourceRegex self model sourceCode: self sourceRegexText! ! !NautilusRefactoring methodsFor: 'rewrite code'! 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: 'rewrite code' stamp: 'DanielUber 10/26/2012 23:39'! typeClass self model sourceCode: (self typeClassTextFor: self model selectedClasses)! ! !NautilusRefactoring methodsFor: 'rewrite code'! typeClassTextFor: aCollectionOfClass ^ String streamContents: [:s | aCollectionOfClass do: [:class | s << (RBRefactoryTyper new runOn: class) printString. s cr; cr ]]! ! !NautilusRefactoring methodsFor: 'source'! 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: 'source'! 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: 'source'! 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: '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: '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: 'source'! 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: 'source' stamp: 'BenjaminVanRyseghem 9/14/2012 14:57'! formatSourceCode | textArea | self model ifNil: [ ^ self ]. textArea := self model sourceTextArea. textArea handleEdit: [ | source tree formatted | source := textArea textMorph text asString. tree := RBParser parseMethod: source onError: [ :msg :pos | ^ self ]. formatted := tree formattedCode. formatted = source ifTrue: [ ^ self ]. textArea editString: formatted; hasUnacceptedEdits: true ]! ! !NautilusRefactoring methodsFor: 'source'! 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: 'source'! 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'! 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: 'source'! 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: '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: '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: '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: '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: '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: 'source'! 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'! 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: 'undo-redo'! changeManager ^ RBRefactoryChangeManager instance! ! !NautilusRefactoring methodsFor: 'undo-redo'! redoEnabled ^ self changeManager hasRedoableOperations! ! !NautilusRefactoring methodsFor: 'undo-redo'! 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: 'undo-redo'! redoOperation self changeManager redoOperation! ! !NautilusRefactoring methodsFor: 'undo-redo'! undoEnabled ^ self changeManager hasUndoableOperations! ! !NautilusRefactoring methodsFor: 'undo-redo'! 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: 'undo-redo'! undoOperation self changeManager undoOperation! ! !NautilusRefactoring methodsFor: 'private-class'! classObjectFor: anObject (anObject isBehavior or: [anObject isTrait]) ifTrue: [ ^ environment classFor: anObject ]. anObject isSymbol ifTrue: [ ^ environment classNamed: anObject ]. ^ anObject! ! !NautilusRefactoring methodsFor: 'private-class'! privateGenerateAccessorsFor: class ^ class instVarNames collect: [:aVarName | RBCreateAccessorsForVariableRefactoring model: environment variable: aVarName class: class classVariable: false ]! ! !NautilusRefactoring methodsFor: 'private-class'! 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: 'private-class'! 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-class'! privateRealizeClassFor: aClass ^ RBRealizeClassRefactoring model: environment className: aClass theNonMetaClass name! ! !NautilusRefactoring methodsFor: 'private-class'! privateRemoveClassesFor: aCollection ^ RBRemoveClassRefactoring model: environment classNames: (aCollection collect: [:e | e theNonMetaClass name ])! ! !NautilusRefactoring methodsFor: 'private-class'! 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: 'private-class var'! privateAbstractClassVarFrom: aClass ^ self class: aClass andClassVariable: [ :class :variable | RBAbstractClassVariableRefactoring model: environment variable: variable class: class ]! ! !NautilusRefactoring methodsFor: 'private-class var'! privateAccessorsClassVarFrom: aClass ^ self class: aClass andClassVariable: [ :class :variable | RBCreateAccessorsForVariableRefactoring model: environment variable: variable class: class classVariable: true ]! ! !NautilusRefactoring methodsFor: 'private-class var'! privateAddClassVarFrom: aClass | name | name := (self request: 'Enter the new variable name:' initialAnswer: 'Var'). ^ RBAddClassVariableRefactoring model: environment variable: name class: aClass theNonMetaClass! ! !NautilusRefactoring methodsFor: 'private-class var'! privatePullUpClassVarFrom: aClass ^ self class: aClass andClassVariable: [ :class :variable | RBPullUpClassVariableRefactoring model: environment variable: variable class: class ]! ! !NautilusRefactoring methodsFor: 'private-class var'! privatePushDownClassVarFrom: aClass ^ self class: aClass andClassVariable: [ :class :variable | RBPushDownClassVariableRefactoring model: environment variable: variable class: class ]! ! !NautilusRefactoring methodsFor: 'private-class var'! privateRemoveClassVarFrom: aClass ^ self class: aClass andClassVariable: [ :class :variable | RBRemoveClassVariableRefactoring model: environment variable: variable class: class ]! ! !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: '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: 'private-inst var'! privateAbstractInstVarFrom: aClass ^ self class: aClass andInstVariable: [ :class :variable | RBAbstractInstanceVariableRefactoring model: environment variable: variable class: class ]! ! !NautilusRefactoring methodsFor: 'private-inst var'! privateAccessorsInstVarFrom: aClass ^ self class: aClass andInstVariable: [ :class :variable | RBCreateAccessorsForVariableRefactoring model: environment variable: variable class: class classVariable: false ]! ! !NautilusRefactoring methodsFor: 'private-inst var'! privateAddInstVarFrom: aClass | name | name := (self request: 'Enter the new variable name:' initialAnswer: 'inst'). ^ RBAddInstanceVariableRefactoring model: environment variable: name class: aClass theNonMetaClass! ! !NautilusRefactoring methodsFor: 'private-inst var'! privatePullUpInstVarFrom: aClass ^ self class: aClass andInstVariable: [ :class :variable | RBPullUpInstanceVariableRefactoring model: environment variable: variable class: class ]! ! !NautilusRefactoring methodsFor: 'private-inst var'! privatePushDownInstVarFrom: aClass ^ self class: aClass andInstVariable: [ :class :variable | RBPushDownInstanceVariableRefactoring model: environment variable: variable class: class ]! ! !NautilusRefactoring methodsFor: 'private-inst var'! privateRemoveInstVarFrom: aClass ^ self class: aClass andInstVariable: [ :class :variable | RBRemoveInstanceVariableRefactoring model: environment variable: variable class: class ]! ! !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: '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: 'private-method' stamp: 'BenjaminVanRyseghem 3/26/2012 17:46'! 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 methodClass newSelector: newSelector asSymbol initializer: initializer ! ! !NautilusRefactoring methodsFor: 'private-method'! privateInlineAllSendersFor: aMethod ^ RBInlineAllSendersRefactoring model: environment sendersOf: aMethod selector in: aMethod methodClass! ! !NautilusRefactoring methodsFor: 'private-method'! privateInlineParameterFor: aMethod | arguments parameter parser | parser := RBParser new. parser errorBlock: [ :error :position | ^ #() ]. parser initializeParserWith: aMethod sourceCode. arguments := parser parseMessagePattern argumentNames. arguments ifEmpty: [ ^ nil ]. parameter := (UIManager default chooseFrom: arguments). parameter ifNil: [ ^ nil ]. ^ RBInlineParameterRefactoring model: environment inlineParameter: (arguments at: parameter ifAbsent: [ ^ nil ]) in: aMethod methodClass selector: aMethod selector! ! !NautilusRefactoring methodsFor: 'private-method'! 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: 'private-method'! 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: 'private-method'! 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: 'private-method'! privateRemoveMethodsFor: aCollection | selectors class | selectors := aCollection collect: #selector. class := aCollection first methodClass. (aCollection allSatisfy: [:e | e methodClass == class ]) ifFalse: [ ^ nil ]. ^ RBRemoveMethodRefactoring model: environment removeMethods: selectors from: class! ! !NautilusRefactoring methodsFor: 'private-method' stamp: 'BenjaminVanRyseghem 3/26/2012 17:49'! privateRemoveParameterMethodFor: aMethod | arguments parameter parser | parser := RBParser new. parser errorBlock: [ :error :position | ^ #() ]. parser initializeParserWith: aMethod sourceCode. arguments := parser parseMessagePattern argumentNames. arguments ifEmpty: [ ^ nil ]. parameter := (UIManager default chooseFrom: arguments). parameter ifNil: [ ^ nil ]. ^ RBRemoveParameterRefactoring model: environment removeParameter: (arguments at: parameter ifAbsent: [ ^ nil ]) in: aMethod methodClass selector: aMethod selector! ! !NautilusRefactoring methodsFor: 'private-method'! privateRenameMethodFor: aMethod | class selector oldMethodName newMethodName oldArguments argumentPermutation | class := aMethod methodClass. selector := aMethod selector. oldArguments := (RBParser parseMethod: (class methodHeaderFor: selector)) 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-method'! privateSwapMethodFor: aCollection ^ aCollection collect: [:aMethod | RBSwapMethodRefactoring model: environment swapMethod: aMethod selector in: aMethod methodClass ]! ! !NautilusRefactoring methodsFor: 'private-source'! privateCreateCascadeBetween: aSelection from: aMethod ^ RBCreateCascadeRefactoring model: environment combine: aSelection from: aMethod selector in: aMethod methodClass! ! !NautilusRefactoring methodsFor: 'private-source'! privateExtractBetween: anInterval from: aMethod ^ RBExtractMethodRefactoring model: environment extract: anInterval from: aMethod selector in: aMethod methodClass! ! !NautilusRefactoring methodsFor: 'private-source'! privateExtractToComponentBetween: anInterval from: aMethod ^ RBExtractMethodToComponentRefactoring model: environment extract: anInterval from: aMethod selector in: aMethod methodClass! ! !NautilusRefactoring methodsFor: 'private-source'! 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-source'! privateInlineMethodBetween: anInterval from: aMethod ^ RBInlineMethodRefactoring model: environment inline: anInterval inMethod: aMethod selector forClass: aMethod methodClass! ! !NautilusRefactoring methodsFor: 'private-source'! privateInlineMethodFromComponentBetween: anInterval from: aMethod ^ RBInlineMethodFromComponentRefactoring model: environment inline: anInterval inMethod: aMethod selector forClass: aMethod methodClass! ! !NautilusRefactoring methodsFor: 'private-source'! privateInlineTemporaryBetween: anInterval from: aMethod ^ RBInlineTemporaryRefactoring model: environment inline: anInterval from: aMethod selector in: aMethod methodClass! ! !NautilusRefactoring methodsFor: 'private-source'! privateMoveVariableDefinitionBetween: anInterval from: aMethod ^ RBMoveVariableDefinitionRefactoring model: environment bindTight: anInterval in: aMethod methodClass selector: aMethod selector! ! !NautilusRefactoring methodsFor: 'private-source'! 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: 'private-source'! privateSplitCascadeBetween: anInterval from: aMethod ^ RBSplitCascadeRefactoring model: environment split: anInterval from: aMethod selector in: aMethod methodClass! ! !NautilusRefactoring methodsFor: 'private-source'! privateTemporaryToInstanceVariableNamed: name Between: anInterval from: aMethod ^ RBTemporaryToInstanceVariableRefactoring model: environment class: aMethod methodClass selector: aMethod selector variable: name! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NautilusRefactoring class instanceVariableNames: ''! !NautilusRefactoring class methodsFor: 'accessing'! promptOnRefactoring ^ PromptOnRefactoring ifNil: [ PromptOnRefactoring := true ]! ! !NautilusRefactoring class methodsFor: 'instance creation'! model: model ^ self new model: model; yourself! ! !NautilusRefactoring class methodsFor: 'menu' stamp: 'EstebanLorenzano 2/6/2013 16:36'! classRefactoringSubmenu: 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 renameClassWithRefactoringEngine: target selectedClass theNonMetaClass ]; parent: #'Class Refactoring'; order: 0. (aBuilder item: #'Remove...') action: [ target removeClassWithRefactoringEngine: target selectedClasses ]; icon: (target iconClass 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.! ! !NautilusRefactoring class methodsFor: 'menu' stamp: 'EstebanLorenzano 1/30/2013 15:53'! classVarRefactoringSubmenu: aBuilder | target selectedClass | target := aBuilder model. selectedClass := target selectedClass. selectedClass ifNil: [ ^ target ]. (aBuilder item: #'Add') action: [ target refactor addClassVarFrom: selectedClass ]; parent: #'Class Var Refactoring'; order: 0. (aBuilder item: #'Rename') action: [ target refactor renameClassVarFrom: selectedClass ]; parent: #'Class Var Refactoring'; order: 100. (aBuilder item: #'Remove') action: [ target refactor removeClassVarFrom: selectedClass ]; parent: #'Class Var Refactoring'; icon: (target iconClass iconNamed: #removeIcon); order: 200; withSeparatorAfter. (aBuilder item: #'Abstract') action: [ target refactor abstractClassVarFrom: selectedClass ]; parent: #'Class Var Refactoring'; order: 300. (aBuilder item: #'Accessors') action: [ target refactor accessorsClassVarFrom: selectedClass ]; parent: #'Class Var Refactoring'; order: 400. (aBuilder item: #'Pull up') action: [ target refactor pullUpClassVarFrom: selectedClass ]; parent: #'Class Var Refactoring'; order: 500. (aBuilder item: #'Push down') action: [ target refactor pushDownClassVarFrom: selectedClass ]; parent: #'Class Var Refactoring'; order: 600.! ! !NautilusRefactoring class methodsFor: 'menu' stamp: 'EstebanLorenzano 1/30/2013 15:53'! codeRewritingClassSubmenu: aBuilder | target | target := aBuilder model. target selectedClass ifNil: [^target]. (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.! ! !NautilusRefactoring class methodsFor: 'menu' stamp: 'EstebanLorenzano 1/30/2013 15:55'! groupRefactoringMenu: 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: 'menu' stamp: 'EstebanLorenzano 1/30/2013 15:53'! instVarRefactoringSubmenu: aBuilder | target selectedClass | target := aBuilder model. selectedClass := target selectedClass. selectedClass ifNil: [^target]. (aBuilder item: #'Add') action: [ target refactor addInstVarFrom: selectedClass ]; parent: #'Inst Var Refactoring'; order: 0. (aBuilder item: #'Rename') action: [ target refactor renameInstVarFrom: selectedClass ]; parent: #'Inst Var Refactoring'; order: 100. (aBuilder item: #'Remove') action: [ target refactor removeInstVarFrom: selectedClass ]; parent: #'Inst Var Refactoring'; icon: (target iconClass iconNamed: #removeIcon); order: 200; withSeparatorAfter. (aBuilder item: #'Abstract') action: [ target refactor abstractInstVarFrom: selectedClass ]; parent: #'Inst Var Refactoring'; order: 300. (aBuilder item: #'Accessors') action: [ target refactor accessorsInstVarFrom: selectedClass ]; parent: #'Inst Var Refactoring'; order: 400. (aBuilder item: #'Pull up') action: [ target refactor pullUpInstVarFrom: selectedClass ]; parent: #'Inst Var Refactoring'; order: 500. (aBuilder item: #'Push down') action: [ target refactor pushDownInstVarFrom: selectedClass ]; parent: #'Inst Var Refactoring'; order: 600.! ! !NautilusRefactoring class methodsFor: 'menu' stamp: 'SeanDeNigris 2/20/2013 11:17'! methodRefactoringSubMenu: 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.! ! !NautilusRefactoring class methodsFor: 'menu' stamp: 'EstebanLorenzano 1/30/2013 15:52'! 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: 'menu' stamp: 'EstebanLorenzano 1/30/2013 15:53'! refactoringClassMenu: aBuilder | target | target := aBuilder model. target selectedClass ifNil: [^target]. (aBuilder item: #'Refactoring') order: -100. (aBuilder item: #'Rename inst var') action: [ target refactor renameInstVarFrom: target selectedClass ]; order: -98. (aBuilder item: #'Rename class var') action: [ target refactor renameClassVarFrom: target selectedClass ]; 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.! ! !NautilusRefactoring class methodsFor: 'menu' stamp: 'SeanDeNigris 2/20/2013 11:18'! refactoringMethodMenu: aBuilder | target | target := aBuilder model. target selectedMethod ifNil:[ ^ target ]. (aBuilder item: #'Refactoring') order: -100. (self renameMethodAllItem: aBuilder) order: -90; withSeparatorAfter! ! !NautilusRefactoring class methodsFor: 'menu' stamp: 'EstebanLorenzano 1/30/2013 15:56'! sourceCodeRefactoringMenu: 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.! ! !NautilusRefactoring class methodsFor: 'menu' stamp: 'EstebanLorenzano 1/31/2013 11:36'! sourceCodeRefactoringMenuHolder: aBuilder | target | target := aBuilder model. (aBuilder item: #'Format') order: 1100; action: [ target refactor formatSourceCode ]. (aBuilder item: #'Source code refactoring') order: 1101; arguments: {}; withSeparatorAfter.! ! !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 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: '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: 'private' stamp: 'EstebanLorenzano 2/22/2013 17:53'! 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. target methodWidget vScrollValue: scroll ].! ! NautilusBooleanAnnouncement subclass: #NautilusShowCategoriesChanged instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Announcements'! !NautilusShowCategoriesChanged commentStamp: '' prior: 0! A NautilusShowCategoriesChanged is raised the value showCategories changed! NautilusBooleanAnnouncement subclass: #NautilusShowCommentChanged instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Announcements'! !NautilusShowCommentChanged commentStamp: '' prior: 0! A NautilusShowCommentChanged is raised when showComment is switched! NautilusBooleanAnnouncement subclass: #NautilusShowGroupsChanged instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Announcements'! !NautilusShowGroupsChanged commentStamp: '' prior: 0! A NautilusShowGroupsChanged is raised when the value showGroups is switched! NautilusBooleanAnnouncement subclass: #NautilusShowHierarchyChanged instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Announcements'! !NautilusShowHierarchyChanged commentStamp: '' prior: 0! A NautilusShowHierarchyChanged is raised when the value of howHierarchy is switched! NautilusBooleanAnnouncement subclass: #NautilusShowInstanceChanged instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Announcements'! !NautilusShowInstanceChanged commentStamp: '' prior: 0! A NautilusShowInstanceChanged is raised when the value of showInstances is changed! NautilusBooleanAnnouncement subclass: #NautilusShowPackagesChanged instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Announcements'! !NautilusShowPackagesChanged commentStamp: '' prior: 0! A NautilusShowPackagesChanged is raised when the value of showPackages changed! TestCase subclass: #NautilusTest instanceVariableNames: 'nautilus' classVariableNames: '' poolDictionaries: '' category: 'Nautilus-Tests'! !NautilusTest commentStamp: '' prior: 0! A NautilusTest is a test class for testing the behavior of Nautilus! !NautilusTest methodsFor: 'running'! setUp nautilus := Nautilus new.! ! !NautilusTest methodsFor: 'running'! 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'! 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 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: '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:))! ! Announcement subclass: #NautilusTextDisplayerChanged instanceVariableNames: 'displayerSymbol' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Announcements'! !NautilusTextDisplayerChanged commentStamp: '' prior: 0! 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 instanceVariableNames: ''! !NautilusTextDisplayerChanged class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 6/13/2012 21:19'! displayerSymbol: anObject ^ self new displayerSymbol: anObject; yourself! ! AbstractNautilusUI subclass: #NautilusUI instanceVariableNames: 'categories categoryWidget methodWidget methods' classVariableNames: '' poolDictionaries: '' category: 'Nautilus'! !NautilusUI commentStamp: '' prior: 0! A UI for an instance of Nautilus! !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: '*NautilusRefactoring'! refactor ^ NautilusRefactoring model: self! ! !NautilusUI methodsFor: '*NautilusRefactoring'! removeClassWithRefactoringEngine: aCollection ^ self refactor removeClasses: aCollection ! ! !NautilusUI methodsFor: '*NautilusRefactoring'! renameClassWithRefactoringEngine: aClass self refactor renameClass: aClass ! ! !NautilusUI methodsFor: 'accessing'! categoryWidget ^ categoryWidget! ! !NautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/17/2012 15:05'! methodWidget ^ methodWidget! ! !NautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/3/2012 18:07'! selectedCategoryInternally: anObject self okToChange ifTrue: [ self resetMethodsListSelection. anObject ifNotNil: [ self giveFocusTo: categoryWidget ]. self changed: #sourceCodeFrom:. ^ true]. ^ false! ! !NautilusUI methodsFor: 'accessing' stamp: 'EstebanLorenzano 1/25/2013 18:16'! selectedClassWithoutChangingSelection: aClass categoryWidget resetCategoryCache. commentTextArea ifNotNil: [ aClass ifNil: [ commentTextArea disable ] ifNotNil: [ commentTextArea enable ]]. self okToChangeBoth ifTrue: [| package packageChanged cl | package := self selectedPackage. (self showPackages not or: [self showGroups ]) ifTrue: [ aClass ifNotNil: [ package := aClass package ]]. aClass ifNil: [ classesSelection removeAll ]. packageChanged := (package ~= self selectedPackage). self model package: package class: aClass category: nil method: nil. cl := aClass. cl ifNotNil: [ cl := cl theNonMetaClass ]. classesSelection at: cl put: true. self changed: #toggleButtonEnabled. 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: #instanceButtonLabel. self changed: #sourceCodeFrom:]! ! !NautilusUI methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/3/2012 18:07'! selectedClassWithoutChangingSelectionInternally: aClass self okToChange ifTrue: [| 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 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: '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: 'category-method methods'! forceSelectedMethod: aMethod self model package: self selectedPackage class: self selectedClass category: self selectedCategory method: aMethod.! ! !NautilusUI methodsFor: 'category-method methods' stamp: 'BenjaminVanRyseghem 8/3/2012 18:07'! selectedCategory: anObject self okToChange ifTrue: [ methodWidget resetMethodCache. self model package: self selectedPackage class: self selectedClass category: anObject method: nil. self resetMethodsListSelection. anObject ifNotNil: [ self giveFocusTo: categoryWidget ]. categoryWidget changed: #selectedCategoryIndex. self changed: #sourceCodeFrom:. ^ true]. ^ false! ! !NautilusUI methodsFor: 'category-method methods' stamp: 'BenjaminVanRyseghem 8/6/2012 19:41'! selectedMethod: aMethod self okToChange ifTrue: [ self forceSelectedMethod: aMethod. self setWindowTitle. self highlightCategory: aMethod. aMethod ifNotNil: [ self giveFocusTo: methodWidget ]. self changed: #sourceCodeFrom:. multipleMethodsEditor giveFocusToDefault. ^ true]. ^false ! ! !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: 'displaying' stamp: 'EstebanLorenzano 1/30/2013 14:49'! addAll: aWindow | column navigationRow 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: 'displaying' stamp: 'StephaneDucasse 12/19/2012 16:12'! buildColumns: aWindow height: height | delta | delta := StandardFonts defaultFont height + 10. 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: 'displaying'! buildFourthColumn: aWindow ^ self buildMethodWidget! ! !NautilusUI methodsFor: 'displaying'! buildThirdColumn: aWindow ^ self buildCategoryWidget! ! !NautilusUI methodsFor: 'displaying' stamp: 'CamilloBruni 9/14/2012 00:56'! open | focus | super open. window takeKeyboardFocus. focus := list. self selectedClass ifNotNil: [ focus := list2 ]. self selectedCategory ifNotNil: [:cat | categoryWidget selectProtocol: cat. methodWidget resetMethodCache. methodWidget update: #getMethodItem:. focus := categoryWidget ]. self selectedMethod ifNotNil: [:meth | methodWidget selectMethod: meth. focus := methodWidget ]. self giveFocusTo: focus. ! ! !NautilusUI methodsFor: 'drag and drop'! 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: 'drag and drop'! 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: false. self selectedMethod: item ] ! ! !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: '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: '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: 'focus' stamp: 'BenjaminVanRyseghem 6/22/2012 17:58'! giveFocusToClass self giveFocusTo: list2! ! !NautilusUI methodsFor: 'focus' stamp: 'BenjaminVanRyseghem 6/22/2012 18:00'! giveFocusToMethod self giveFocusTo: methodWidget! ! !NautilusUI methodsFor: 'focus' stamp: 'BenjaminVanRyseghem 6/22/2012 17:59'! giveFocusToProtocol self giveFocusTo: categoryWidget! ! !NautilusUI methodsFor: 'group' stamp: 'BenjaminVanRyseghem 4/14/2012 12:17'! addMethodsInGroup self selectedMethods ifNotNil: [:mthds | self addMethodsInGroup: mthds ]! ! !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: 'group'! addProtocolsInGroup self selectedCategories ifNotNil: [:ctgrs | self addProtocolsInGroup: ctgrs ].! ! !NautilusUI methodsFor: 'group'! 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: 'history behavior' stamp: 'CamilloBruni 10/4/2012 10:49'! 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: 'history behavior'! getHistoryList ^ self model historyEntries reversed! ! !NautilusUI methodsFor: 'history behavior' stamp: 'CamilloBruni 10/4/2012 10:49'! historyChanged self setWindowTitle. self changed: #getHistoryList. self changed: #currentHistoryIndex! ! !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: '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: 'history behavior' stamp: 'CamilloBruni 10/4/2012 10:49'! setHistory: anIndex | entry | entry := self getHistoryList at: anIndex ifAbsent: [ nil ]. entry ifNil: [ ^ self ]. self model adopt: entry. self changed: #currentHistoryIndex.! ! !NautilusUI methodsFor: 'history behavior' stamp: 'CamilloBruni 10/4/2012 10:43'! wrapHistory: anEntry | wrapper label separator | separator := ' >>#'. wrapper := anEntry key. wrapper showGroups ifTrue: [ label := Text streamContents: [:s | wrapper 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). wrapper selectedClass ifNotNil: [:c | s << separator << c name. wrapper selectedMethod ifNotNil: [:m | s << separator << m asString ]]]]] ifFalse: [ label := String streamContents: [:s | wrapper selectedPackage ifNotNil: [:p | wrapper selectedClass ifNotNil: [:c | s << c name. wrapper selectedMethod ifNotNil: [:m | s << separator << m asString ]]]]]. ^ GoBackStringMorph contents: label! ! !NautilusUI methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 5/14/2012 12:44'! initialize "Initialization code for NautilusUI" super initialize. categoryWidget := CategoryWidget model: self. methodWidget := MethodWidget model: self.! ! !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: '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: 'menus behavior'! 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: 'menus behavior'! fileOutCategories self fileOutCategories: self selectedCategories from: self selectedClass! ! !NautilusUI methodsFor: 'menus behavior'! fileOutMethods self fileOutMethods: self selectedMethods! ! !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: 'menus behavior' stamp: 'BenjaminVanRyseghem 8/3/2012 18:07'! 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: class package class: class category: foundMethod protocol method: foundMethod. self updateBothView. self update. self changed: #sourceCodeFrom:! ! !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: 'menus behavior'! 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: 'menus behavior'! 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: focus methodClass package. self selectedClass: focus methodClass. self selectedCategory: 'tests'. methodWidget selectMethod: focus. self selectedMethod: focus. self updateBothView ]! ! !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: 'menus behavior' stamp: 'MarcusDenker 9/17/2012 15:34'! implementSelector: aSelector | behavior method category head source | category := ClassOrganizer default. 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: 'menus behavior'! 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: 'menus behavior'! 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 methodsFor: 'menus behavior'! 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. " self okToChange ifFalse: [^ false]. ^ super removeMethod: aMethod inClass: aClass! ! !NautilusUI methodsFor: 'menus behavior' stamp: 'BenjaminVanRyseghem 5/14/2012 12:18'! removeMethods self selectedClass ifNotNil: [:class | self selectedMethods ifNotEmpty: [:items || scroll needToUpdate selectedMethodStillExists | scroll := methodWidget vScrollValue. needToUpdate := self removeMethods: items inClass: class. needToUpdate ifTrue: [ self resetMethodsListSelection. methodWidget updateList ]. (class methodDict values includes: self selectedMethod) ifFalse: [ self selectedMethod: nil ]. self resetMethodsListSelection. methodWidget updateList; vScrollValue: scroll. ]]! ! !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: 'menus behavior'! 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: 'menus behavior' stamp: 'BenjaminVanRyseghem 5/5/2012 23:53'! runTestForAMethod: aMethod notifying: aBoolean self runTestForAMethod: aMethod notifying: aBoolean priority: Processor userBackgroundPriority! ! !NautilusUI methodsFor: 'menus behavior' stamp: 'BenjaminVanRyseghem 7/21/2012 16:00'! 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: []. WorldState addDeferredUIMessage: [ 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: 'menus behavior' stamp: 'BenjaminVanRyseghem 5/6/2012 00:00'! runTestForAMethodWithAnHalt: aMethod | testMethod blockToEvaluate 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: []. WorldState addDeferredUIMessage: [ 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: 'BenjaminVanRyseghem 1/24/2013 11:41'! toggleBreakPoint self selectedMethod ifNotNil: [:meth | self toggleBreakOnEntryIn: meth. self update ]. ! ! !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: '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: 'plugins display'! 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: '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: 'remove me'! incrementMethodsListIndex | index | methodWidget resetMethodsListSelection. index := (methodWidget selectedMethodIndex + 1). index > methodWidget getMethods size ifTrue: [ index := 1 ]. methodWidget selectedMethodIndex: index. sourceTextArea takeKeyboardFocus ! ! !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: 'shortcuts from text morph' stamp: 'CamilloBruni 9/22/2012 19:48'! compileSource: aText notifying: aController | source category method | source := aText asString. category := self selectedCategory. method := self selectedMethod. category ifNil: [ method ifNotNil: [ category := method protocol ]]. (category isNil and: [ method isNil ]) ifTrue: [ source first isUppercase ifTrue: [ ^ self compileAClassFrom: source notifying: aController ]. category := Categorizer default ] ifFalse: [ ((category = self allLabel) and: [ self selectedMethod notNil ]) ifTrue: [ category := self selectedMethod protocol ]]. self compileAMethodFromCategory: category withSource: source notifying: aController! ! !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: 'EstebanLorenzano 1/25/2013 18:18'! methodAdded: anAnnouncement | method | window ifNil: [ ^ self ]. window isDisplayed ifFalse: [ ^ self ]. method := anAnnouncement method. (method methodClass = self selectedClass) ifTrue: [ self resetMethodsListSelection. self removeAllFromMethodsIconsCache: method. self update. (method methodClass isMeta and: [ method methodClass methodDict size = 1 ]) ifTrue: [ self changed: #instanceButtonLabel ] ]! ! !NautilusUI methodsFor: 'source code area' stamp: 'BenjaminVanRyseghem 2/16/2013 15:21'! methodModified: anAnnouncement | collection | window isNil ifTrue: [ ^ self ]. window isDisplayed ifFalse: [ ^ self ]. collection := self getList2. (collection includes: anAnnouncement methodClass) 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: 'source code area' stamp: 'GuillermoPolito 8/3/2012 13:23'! methodRecategorized: anAnnouncement window ifNil: [ ^ self ]. window isDisplayed ifFalse: [ ^ self ]. (anAnnouncement methodClass = self selectedClass) ifTrue: [ self update ]! ! !NautilusUI methodsFor: 'source code area' stamp: 'BenjaminVanRyseghem 2/16/2013 15:21'! methodRemoved: anAnnouncement | method | window ifNil: [ ^ self ]. window isDisplayed ifFalse: [ ^ self ]. method := anAnnouncement methodRemoved. (method methodClass = 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 methodDict isEmpty ]) ifTrue: [ self changed: #instanceButtonLabel ] ]! ! !NautilusUI methodsFor: 'system announcements' stamp: 'BenjaminVanRyseghem 5/2/2012 10:33'! buildTestSuiteFor: aMethod ^ TestSuite new addTest: (aMethod methodClass selector: aMethod selector); yourself! ! !NautilusUI methodsFor: 'system announcements' stamp: 'BenjaminVanRyseghem 5/2/2012 10:48'! debugTest | method | method := self selectedMethod. method correspondingTestMethod ifNotNil: [:test | self debugTest: test ]! ! !NautilusUI methodsFor: 'system announcements' 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: 'tests' stamp: 'EstebanLorenzano 2/6/2013 17:01'! buildCategoryWidget | categoriesList | categoriesList := categoryWidget buildCategoriesList. self setShortcuts: #NautilusProtocolShortcuts to: categoriesList. ^categoriesList! ! !NautilusUI methodsFor: 'tests'! categoriesLabel ^ categoryWidget categoriesLabel! ! !NautilusUI methodsFor: 'tests'! categoriesMenu: aMenu shifted: b ^ aMenu becomeForward: (self categoryMenuBuilder menu)! ! !NautilusUI methodsFor: 'tests'! categoriesSelection ^ categoryWidget categoriesSelection! ! !NautilusUI methodsFor: 'tests' stamp: 'BenjaminVanRyseghem 5/14/2012 12:17'! categorySelectionChanged methodWidget resetMethodCache; updateList.! ! !NautilusUI methodsFor: 'tests'! enableCategorySingleSelection ^ self selectedCategories size <= 1! ! !NautilusUI methodsFor: 'tests'! getCategories ^ categoryWidget getCategories! ! !NautilusUI methodsFor: 'tests'! loadCategories ^ self model selectedClass ifNil: [ {} ] ifNotNil: [:class | class protocols asOrderedCollection sort addFirst: self allLabel; yourself ]! ! !NautilusUI methodsFor: 'tests'! resetCategoriesListSelection categoryWidget resetCategoriesListSelection! ! !NautilusUI methodsFor: 'tests'! selectedCategories ^ categoryWidget selectedCategories! ! !NautilusUI methodsFor: 'tests' stamp: 'BenjaminVanRyseghem 4/17/2012 14:59'! selectedCategory ^ (self model ifNil: [ ^ nil ]) selectedCategory! ! !NautilusUI methodsFor: 'widget - category' stamp: 'EstebanLorenzano 2/6/2013 17:12'! buildMethodWidget | methodsList | methodsList := methodWidget buildMethodsList. self setShortcuts: #NautilusMethodShortcuts to: methodsList. ^methodsList ! ! !NautilusUI methodsFor: 'widget - category'! elementsMenu: aMenu shifted: b ^ aMenu becomeForward: (self methodMenuBuilder menu)! ! !NautilusUI methodsFor: 'widget - category'! enableMethodSingleSelection ^ self selectedMethods size <= 1! ! !NautilusUI methodsFor: 'widget - category'! getMethods ^ methodWidget getMethods! ! !NautilusUI methodsFor: 'widget - category'! keyPressedOnElement: anEvent ^ self methodWidget keyPressedOnElement: anEvent! ! !NautilusUI methodsFor: 'widget - category' stamp: 'BenjaminVanRyseghem 4/17/2012 13:40'! methodsIconsCache ^ self methodWidget methodsIconsCache! ! !NautilusUI methodsFor: 'widget - category'! methodsLabel ^ methodWidget methodsLabel! ! !NautilusUI methodsFor: 'widget - category'! methodsSelection ^ methodWidget methodsSelection! ! !NautilusUI methodsFor: 'widget - category'! removeAllFromMethodsIconsCache: aMethod methodWidget removeAllFromMethodsIconsCache: aMethod! ! !NautilusUI methodsFor: 'widget - category' stamp: 'BenjaminVanRyseghem 4/17/2012 15:05'! resetMethodsListSelection methodWidget resetMethodsListSelection! ! !NautilusUI methodsFor: 'widget - category'! selectedMethod ^ self model selectedMethod ! ! !NautilusUI methodsFor: 'widget - category'! selectedMethods ^ methodWidget selectedMethods! ! !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: 'widget - method'! allLabel ^ '--- all ---'! ! !NautilusUI methodsFor: 'widget - method'! 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: 'widget - method'! forceSelection: aNode ! ! !NautilusUI methodsFor: 'widget - method'! generateSourceCodeForTestFrom: aMethod ^ self buildTestSelectorFor: aMethod.! ! !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: 'widget - method'! hasFocus ^ window hasKeyboardFocus or: [ list hasKeyboardFocus or: [ list2 hasKeyboardFocus or: [ categoryWidget hasFocus or: [ methodWidget hasFocus or: [ sourceTextArea hasKeyboardFocus ]]]]]! ! !NautilusUI methodsFor: 'widget - method'! highlightCategory: aMethod. methodWidget resetMethodCache. aMethod ifNil: [ categoryWidget searchedElement: categoryWidget selectedCategoryIndex ] ifNotNil: [ | category index | category := aMethod protocol. index := self getCategories indexOf: ( category ). categoryWidget searchedElement: index ]! ! !NautilusUI methodsFor: 'widget - method'! methodsForCategories: aCollection ^ aCollection gather: [:e | self methodsForCategory: e ]! ! !NautilusUI methodsFor: 'widget - method'! methodsForCategoriesInGroup: aCollection | mthds | mthds := aCollection gather: [:e | self methodsForCategoryInGroup: e ]. ^ mthds sort: [:a :b | a selector < b selector ]! ! !NautilusUI methodsFor: 'widget - method'! 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: 'widget - method'! 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: '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: 'widget - method'! methodsInSystemEnvironmentForCategory: aCategory in: class aCategory = self allLabel ifTrue: [ ^ class methods asOrderedCollection ]. ^ (class methodsInProtocol: aCategory) asOrderedCollection! ! !NautilusUI methodsFor: 'widget - method'! notifyTitle: title contents: contents GrowlMorph openWithLabel: title contents: contents! ! !NautilusUI methodsFor: 'widget - method' stamp: 'BenjaminVanRyseghem 4/19/2012 23:39'! notifyTitle: title contents: contents color: aColor GrowlMorph openWithLabel: title contents: contents color: aColor! ! !NautilusUI methodsFor: 'widget - method'! resetSelections self resetListSelection. self resetListSelection2. self resetCategoriesListSelection. self resetMethodsListSelection.! ! !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: 'BenjaminVanRyseghem 5/14/2012 12:18'! update categoryWidget resetCategoryCache. methodWidget resetMethodCache; updateList. self changed: #getCategoryItem:.! ! !NautilusUI methodsFor: 'private'! nextButtonState ^ true! ! !NautilusUI methodsFor: 'private'! previousButtonState ^ true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NautilusUI class instanceVariableNames: ''! !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 ]! ! !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'. ! ! TestCase subclass: #NautilusUITest instanceVariableNames: 'nautilusUI' classVariableNames: '' poolDictionaries: '' category: 'Nautilus-Tests'! !NautilusUITest commentStamp: '' prior: 0! 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'! setUp "Setting up code for NautilusUITest" nautilusUI := NautilusUI on: Nautilus new.! ! !NautilusUITest methodsFor: 'initialization'! tearDown "Tearing down code for NautilusUITest" nautilusUI := nil.! ! StandardWindow subclass: #NautilusWindow instanceVariableNames: 'container' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon'! !NautilusWindow commentStamp: '' prior: 0! 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: 'about' stamp: 'BenjaminVanRyseghem 2/20/2012 16:59'! aboutTitle ^'About Nautilus'! ! !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: 'open/close' stamp: 'BenjaminVanRyseghem 12/20/2012 12:47'! initialExtent ^ 850@600! ! Object subclass: #NautilusWrapper instanceVariableNames: 'selectedPackage selectedCategory selectedMethod selectedClass selectedGroup showPackages showGroups showHierarchy showComment showInstance showCategories' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon'! !NautilusWrapper commentStamp: '' prior: 0! A NautilusWrapper is a wrapper which hold a single step of the Nautilus browsing history! !NautilusWrapper methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/13/2011 16:34'! selectedCategory ^ selectedCategory! ! !NautilusWrapper methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/13/2011 16:34'! selectedCategory: anObject selectedCategory := anObject! ! !NautilusWrapper methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/13/2011 16:34'! selectedClass ^ selectedClass! ! !NautilusWrapper methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/13/2011 16:34'! selectedClass: anObject selectedClass := anObject! ! !NautilusWrapper methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/13/2011 16:34'! selectedGroup ^ selectedGroup! ! !NautilusWrapper methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/13/2011 16:34'! selectedGroup: anObject selectedGroup := anObject! ! !NautilusWrapper methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 10/19/2011 17:31'! selectedMethod ^ selectedMethod! ! !NautilusWrapper methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/13/2011 16:34'! selectedMethod: anObject selectedMethod := anObject! ! !NautilusWrapper methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/13/2011 16:34'! selectedPackage ^ selectedPackage! ! !NautilusWrapper methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/13/2011 16:34'! selectedPackage: anObject selectedPackage := anObject! ! !NautilusWrapper methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/13/2011 16:34'! showCategories ^ showCategories! ! !NautilusWrapper methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/13/2011 16:34'! showCategories: anObject showCategories := anObject! ! !NautilusWrapper methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/13/2011 16:34'! showComment ^ showComment! ! !NautilusWrapper methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/13/2011 16:34'! showComment: anObject showComment := anObject! ! !NautilusWrapper methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/13/2011 16:34'! showGroups ^ showGroups! ! !NautilusWrapper methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/13/2011 16:34'! showGroups: anObject showGroups := anObject! ! !NautilusWrapper methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/13/2011 16:34'! showHierarchy ^ showHierarchy! ! !NautilusWrapper methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/13/2011 16:34'! showHierarchy: anObject showHierarchy := anObject! ! !NautilusWrapper methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/13/2011 16:34'! showInstance ^ showInstance! ! !NautilusWrapper methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/13/2011 16:34'! showInstance: anObject showInstance := anObject! ! !NautilusWrapper methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/13/2011 16:34'! showPackages ^ showPackages! ! !NautilusWrapper methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/23/2011 20:15'! showPackages: anObject showPackages := anObject! ! !NautilusWrapper methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 3/13/2012 04:47'! = 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 ]]]]]]]]]]! ! !NautilusWrapper methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/12/2011 13:13'! 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.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NautilusWrapper class instanceVariableNames: ''! !NautilusWrapper class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 4/13/2011 16:35'! with: aNautilus ^ self new with: aNautilus! ! Object subclass: #NavigationHistory instanceVariableNames: 'storage index maxSize paused' classVariableNames: '' poolDictionaries: '' category: 'Nautilus-History'! !NavigationHistory commentStamp: '' prior: 0! I act as a web browser history! !NavigationHistory methodsFor: 'collection compatibility' stamp: 'BenjaminVanRyseghem 3/13/2012 16:13'! add: anEntry self addEntry: anEntry! ! !NavigationHistory methodsFor: 'initialize-release' stamp: 'CamilloBruni 10/4/2012 11:29'! initialize storage := OrderedCollection new. index := 0. paused := false.! ! !NavigationHistory methodsFor: 'protocol' stamp: 'CamilloBruni 10/4/2012 11:29'! addEntry: anEntry self isPaused ifTrue: [ ^ self ]. ( 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 -> TimeStamp now)] ifFalse: [ storage := storage copyFrom: 1 to: index. storage at: index put: (anEntry -> TimeStamp now)]! ! !NavigationHistory methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/11/2011 15:09'! back index := ((index - 1) max: 0)! ! !NavigationHistory methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/11/2011 16:11'! current ^ storage at: index ifAbsent: [ nil -> nil ]! ! !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: 'protocol' stamp: 'BenjaminVanRyseghem 4/19/2011 11:05'! maxSize ^ maxSize ifNil: [ maxSize := self class defaultMaxSize ].! ! !NavigationHistory methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/14/2011 22:53'! maxSize: anInteger maxSize := anInteger! ! !NavigationHistory methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/12/2011 12:25'! next index := ((index + 1) min: storage size). ^ storage at: index! ! !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 5/12/2011 12:25'! previous index := index-1 max: 1. ^ storage at: index! ! !NavigationHistory methodsFor: 'testing' stamp: 'CamilloBruni 10/4/2012 11:17'! hasNext ^ index < storage size! ! !NavigationHistory methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 5/12/2011 13:01'! hasPrevious ^ index > 1! ! !NavigationHistory methodsFor: 'testing' stamp: 'CamilloBruni 10/4/2012 11:30'! isPaused ^ paused! ! !NavigationHistory methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/24/2011 13:42'! checkSize [ storage size >= self maxSize ] whileTrue: [ storage removeFirst. index := index -1].! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NavigationHistory class instanceVariableNames: ''! !NavigationHistory class methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/13/2012 16:37'! defaultMaxSize ^ 15! ! Object subclass: #NetNameResolver instanceVariableNames: '' classVariableNames: 'DefaultHostName HaveNetwork ResolverBusy ResolverError ResolverMutex ResolverReady ResolverSemaphore ResolverUninitialized' poolDictionaries: '' category: 'Network-Kernel'! !NetNameResolver commentStamp: '' prior: 0! 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 instanceVariableNames: ''! !NetNameResolver class methodsFor: 'address string utils' stamp: 'marcus.denker 9/14/2008 21:16'! 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 isNil ifTrue: [ ^ nil ]. newAddr at: i put: byte. i < 4 ifTrue: [ delimiter := s next. (delimiter = $. or: [ delimiter = $, or: [ delimiter = $ ] ]) ifFalse: [ ^ nil ] ] ]. ^ newAddr! ! !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: '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: 'lookups' stamp: 'ls 9/5/1998 01:14'! addressForName: aString ^self addressForName: aString timeout: 60! ! !NetNameResolver class methodsFor: 'lookups' stamp: 'SvenVanCaekenberghe 1/14/2013 20:19'! 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 isNil ifFalse: [ ^ 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: '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: '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: '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: 'lookups' stamp: 'NouryBouraqadi 10/1/2010 16:08'! loopBackAddress ^self addressForName: self loopBackName! ! !NetNameResolver class methodsFor: 'lookups' stamp: 'NouryBouraqadi 10/1/2010 16:08'! loopBackName ^'localhost'! ! !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: '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: 'lookups' stamp: 'AdrianLienhard 3/13/2010 10:36'! 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 | defaultName isEmpty ifTrue: [default := DefaultHostName] ifFalse: [default := 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: 'lookups' stamp: 'JMM 5/3/2000 11:25'! resolverError ^self primNameResolverError ! ! !NetNameResolver class methodsFor: 'lookups' stamp: 'JMM 5/3/2000 11:25'! resolverStatus ^self primNameResolverStatus ! ! !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: '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: '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: '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: 'janniklaval 2/10/2011 11:32'! primGetAddressInfoFamily 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:32'! primGetAddressInfoNext self primitiveFailed! ! !NetNameResolver class methodsFor: 'primitives' stamp: 'janniklaval 2/10/2011 11:32'! primGetAddressInfoProtocol self primitiveFailed! ! !NetNameResolver class methodsFor: 'primitives' stamp: 'janniklaval 2/10/2011 11:32'! primGetAddressInfoResult: socketAddress self primitiveFailed! ! !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:33'! primGetNameInfoHostResult: aString self primitiveFailed! ! !NetNameResolver class methodsFor: 'primitives' stamp: 'janniklaval 2/10/2011 11:33'! primGetNameInfoHostSize self primitiveFailed! ! !NetNameResolver class methodsFor: 'primitives' stamp: 'janniklaval 2/10/2011 11:33'! primGetNameInfoServiceResult: aString self primitiveFailed! ! !NetNameResolver class methodsFor: 'primitives' stamp: 'janniklaval 2/10/2011 11:33'! primGetNameInfoServiceSize self primitiveFailed! ! !NetNameResolver class methodsFor: 'primitives' stamp: 'janniklaval 2/10/2011 11:33'! primHostNameResult: aString self primitiveFailed! ! !NetNameResolver class methodsFor: 'primitives' stamp: 'janniklaval 2/10/2011 11:34'! primHostNameSize self primitiveFailed! ! !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'! 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'! primNameResolverError "Return an integer reflecting the error status of the last network name resolver request. Zero means no error." 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: '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: '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: '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: '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: '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: '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: '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: '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 ! ! TestCase subclass: #NetNameResolverTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NetworkTests-Kernel'! !NetNameResolverTest methodsFor: 'testing' stamp: 'NouryBouraqadi 10/1/2010 16:27'! localHostAddressIsLoopBackAddress ^NetNameResolver localHostAddress = NetNameResolver loopBackAddress! ! !NetNameResolverTest methodsFor: 'testing' 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]! ! Error subclass: #NetworkError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Network-Kernel'! !NetworkError commentStamp: 'mir 5/12/2003 18:12' prior: 0! Abstract super class for all network related exceptions.! Object subclass: #NetworkSystemSettings instanceVariableNames: '' classVariableNames: 'BlabEmail HTTPProxyExceptions HTTPProxyPort HTTPProxyServer LastHTTPProxyExceptions LastHTTPProxyPort LastHTTPProxyServer ProxyPassword ProxyUser UseHTTPProxy UseNetworkAuthentification' poolDictionaries: '' category: 'Settings-Network'! !NetworkSystemSettings commentStamp: '' prior: 0! I am NetworkSystemSettings, a class side API to manage various system network settings, mostly related to HTTP proxying.! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NetworkSystemSettings class instanceVariableNames: ''! !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: 'SvenVanCaekenberghe 9/6/2012 13:45'! blabEmail ^ BlabEmail ifNil: [ BlabEmail := '' ]! ! !NetworkSystemSettings class methodsFor: 'settings' stamp: 'SvenVanCaekenberghe 9/6/2012 13:45'! blabEmail: aBlabEmailString BlabEmail := aBlabEmailString! ! !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 14:20'! httpProxyPort "Return the HTTP proxy port to use, an Integer" ^ HTTPProxyPort ifNil: [ HTTPProxyPort := 80 ]! ! !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 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: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: 'SantiagoBragagnolo 11/2/2012 15:35'! isAnExceptionFor: anUrl ^ HTTPProxyExceptions contains: [ :domain | anUrl host = domain.].! ! !NetworkSystemSettings class methodsFor: 'settings' stamp: 'SvenVanCaekenberghe 9/6/2012 15:30'! isHttpProxyException: serverName "Return true when serverName matches any of our HTTP proxy exceptions, else return false" self httpProxyExceptions detect: [ :domainName | domainName match: serverName ] ifNone: [ ^ false ]. ^ true! ! !NetworkSystemSettings class methodsFor: 'settings' stamp: 'SantiagoBragagnolo 9/16/2012 23:51'! manageHttpProxyExceptions ^ LastHTTPProxyExceptions ifNil:[ LastHTTPProxyExceptions := '']. ! ! !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: '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:04'! proxyPassword "Return the HTTP proxy password to use, if any. Can be empty." ^ ProxyPassword ifNil: [ '' ] ifNotNil: [ ProxyPassword base64Decoded ]! ! !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: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: 'SantiagoBragagnolo 9/16/2012 23:51'! removeAllHttpProxyExceptions HTTPProxyExceptions removeAll.! ! !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: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 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: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 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: 'private' stamp: 'SvenVanCaekenberghe 9/6/2012 14:23'! lastHTTPProxyPort ^ LastHTTPProxyPort ifNil: [ LastHTTPProxyPort := HTTPProxyPort ] ! ! !NetworkSystemSettings class methodsFor: 'private' stamp: 'SvenVanCaekenberghe 9/6/2012 14:23'! lastHTTPProxyServer ^ LastHTTPProxyServer ifNil: [ LastHTTPProxyServer := HTTPProxyServer ] ! ! ParseNode subclass: #NewArrayNode instanceVariableNames: 'numElements' classVariableNames: '' poolDictionaries: '' category: 'Compiler-ParseNodes'! !NewArrayNode commentStamp: '' prior: 0! I represent a node for the genPushNewArray: opcode.! !NewArrayNode methodsFor: 'accessing' stamp: 'eem 5/25/2008 14:58'! numElements ^numElements! ! !NewArrayNode methodsFor: 'accessing' stamp: 'eem 5/25/2008 14:59'! numElements: n numElements := n! ! !NewArrayNode methodsFor: 'code generation' stamp: 'eem 5/25/2008 14:58'! emitCodeForValue: stack encoder: encoder encoder genPushNewArray: numElements. stack push: 1! ! !NewArrayNode methodsFor: 'code generation' stamp: 'eem 5/25/2008 14:58'! sizeCodeForValue: encoder ^encoder sizePushNewArray: numElements! ! !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: 'visiting' stamp: 'eem 9/6/2009 12:35'! accept: aVisitor ^aVisitor visitNewArrayNode: self! ! HandleMorph subclass: #NewHandleMorph instanceVariableNames: 'hand waitingForClickInside' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Widgets'! !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: '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: '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: 'initialization' stamp: 'marcus.denker 11/19/2008 13:47'! initialize "initialize the state of the receiver" super initialize. waitingForClickInside := true. ! ! !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: 'submorphs-add/remove' stamp: 'ar 8/16/2001 15:38'! delete hand ifNotNil:[ hand showTemporaryCursor: nil. ]. super delete.! ! !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"! ! ScrollPane subclass: #NewList instanceVariableNames: 'listCache model listSize isInitialized isMultipleSelection selectedIndex selectedIndexes renderer headerHeight headerTitle clickOnHeader lastKeystrokeTime lastKeystrokes secondSelection displayListCache deSelectOnReclick runningProcesses selectionWithKeys drawColor selectedItem selectedItems unselectOnChange iconCache iconMaxSize enabled' classVariableNames: '' poolDictionaries: '' category: 'NewList'! !NewList commentStamp: '' prior: 0! 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 11/26/2012 18:30'! deSelectOnReclick ^ deSelectOnReclick contents! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:31'! deSelectOnReclick: anObject deSelectOnReclick contents: anObject! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2012 19:41'! drawColor ^ drawColor contents! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2012 19:41'! drawColor: anObject drawColor contents: anObject! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/13/2012 11:23'! enabled: aBoolean "Set the value of enabled" enabled contents = aBoolean ifTrue: [^self]. enabled contents: aBoolean. self changed: #enabled. self adoptPaneColor: self paneColor; changed! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:30'! headerHeight ^ headerHeight contents! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:31'! headerHeight: anObject headerHeight contents: anObject! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:30'! headerTitle ^ headerTitle contents! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:31'! headerTitle: anObject headerTitle contents: anObject! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:30'! isInitialized ^ isInitialized contents! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:31'! isInitialized: anObject isInitialized contents: anObject! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:30'! isMultipleSelection ^ isMultipleSelection contents! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:31'! isMultipleSelection: anObject isMultipleSelection contents: anObject! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:31'! listSize: anObject listSize contents: anObject! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:50'! model ^ model contents! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:50'! model: anObject model contents ifNotNil: [:m | m removeDependent: self ]. anObject ifNotNil: [anObject addDependent: self ]. model contents: anObject! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/13/2012 13:37'! private_selectedIndexes ^ selectedIndexes! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:30'! renderer ^ renderer contents! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:31'! renderer: anObject renderer contents: anObject! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/27/2012 01:03'! runningProcesses ^ runningProcesses! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/27/2012 01:04'! runningProcesses: aCollection runningProcesses contents: aCollection! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:30'! secondSelection ^ secondSelection contents! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:31'! secondSelection: anObject secondSelection contents: anObject! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/13/2012 12:07'! selectedIndex ^ selectedIndex contents! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2012 19:55'! selectedIndexes ^ (selectedIndexes select: [:ass | ass value ]) keys sort! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2012 17:00'! selectionWithKeys ^ selectionWithKeys contents! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2012 17:00'! selectionWithKeys: anObject selectionWithKeys contents: anObject! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2012 20:06'! unselectOnChange ^ unselectOnChange contents! ! !NewList methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2012 20:05'! unselectOnChange: anObject unselectOnChange contents: anObject! ! !NewList methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/27/2012 00:39'! acceptDroppingMorph: aMorph atIndex: index event: evt ^ self model acceptDroppingMorph: aMorph atIndex: index event: evt! ! !NewList methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/26/2012 18:54'! adapter ^ self model! ! !NewList methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/26/2012 21:10'! handlesDoubleClick ^ self model handlesDoubleClick! ! !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:12'! keyStrokeAction: anEvent ^ self model keyStrokeAction: anEvent! ! !NewList methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/23/2012 14:57'! listSize ^ listSize contents ifNil: [ self retrieveListSize ]! ! !NewList methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/27/2012 01:13'! rawItemAtIndex: index ^ self model getRawItemAt: index! ! !NewList methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/26/2012 21:02'! retrieveHeaderTitle ^ self model getHeaderTitle! ! !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 12/16/2012 17:18'! retrieveItems ^ self model getItems ifNil: [ selectedItems contents ]! ! !NewList methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 12/16/2012 17:19'! retrieveListSize ^ self model getListSize ifNil: [ listCache size ]! ! !NewList methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/27/2012 00:34'! wantsDroppedMorph: aMorph event: anEvent self dropEnabled ifFalse: [ ^ false ]. ^ self model wantsDroppedMorph: aMorph event: anEvent! ! !NewList methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 12/13/2012 11:36'! drawOn: aCanvas aCanvas fillRectangle: self fullBounds color: self drawColor.! ! !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: 'BenjaminVanRyseghem 11/29/2012 20:02'! basicKeyPressed: aChar | nextSelection milliSeconds slowKeyStroke nextSelectionText 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: 'events - keyboard' stamp: 'BenjaminVanRyseghem 11/25/2012 00:31'! handlesKeyStroke: anEvet ^ true! ! !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 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: '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: 'events - mouse' stamp: 'BenjaminVanRyseghem 11/24/2012 19:08'! mouseDownOnHeader: anEvent "Just to rise an announcement" clickOnHeader contents: anEvent! ! !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: 'events - mouse' stamp: 'BenjaminVanRyseghem 12/16/2012 17:07'! mouseUp: event | newEvent | newEvent := event translatedBy: self topLeft negated . self renderer mouseUp: newEvent.! ! !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: '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: '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: 'icons' stamp: 'BenjaminVanRyseghem 1/26/2013 01:50'! iconMaxSize ^ iconMaxSize contents ifNil: [ iconMaxSize contents: self retrieveIconMaxSize ]! ! !NewList methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 12/16/2012 17:53'! endOfInitialization isInitialized contents: true. self updateItems. self updateDisplayListCache. self updateListSize. self updateHeaderTitle. self updateHeaderHeight. self updateRenderer. selectedItem contents: self retrieveSelectedItem. selectedItems contents: self retrieveSelectedItems. listCache whenChangedDo: [:e | listSize contents: 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 contents: self retrieveSelectedItem. self renderer updateRectFor: oldIndex. ]. selectedIndexes whenChangedDo: [:newIndex :oldIndex | selectedItems contents: self retrieveSelectedItems ]. headerTitle whenChangedDo: [:t | self renderer invalidHeader ].! ! !NewList methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 12/16/2012 18:44'! initialize "Initialization code for NewList" 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.! ! !NewList methodsFor: 'layout' stamp: 'BenjaminVanRyseghem 12/17/2012 14:10'! privateFullBounds ^ self bounds! ! !NewList methodsFor: 'looks & colors' stamp: 'BenjaminVanRyseghem 11/29/2012 19:42'! backgroundColor: aColor self drawColor: aColor! ! !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: 'looks & colors' stamp: 'BenjaminVanRyseghem 11/23/2012 15:03'! defaultItemColor ^ Color black! ! !NewList methodsFor: 'looks & colors' stamp: 'BenjaminVanRyseghem 11/23/2012 16:05'! font ^ self theme listFont! ! !NewList methodsFor: 'looks & colors' stamp: 'BenjaminVanRyseghem 11/23/2012 14:48'! secondSelectionColor ^ self theme settings secondarySelectionColor! ! !NewList methodsFor: 'looks & colors' stamp: 'BenjaminVanRyseghem 11/23/2012 18:07'! selectedBackgroundColor ^ self theme settings selectionColor! ! !NewList methodsFor: 'menu' stamp: 'BenjaminVanRyseghem 11/27/2012 01:02'! getMenu: shiftKeyState ^ self model getMenu: shiftKeyState.! ! !NewList methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/29/2012 17:50'! addAtIndexes: anIndex selectedIndexes at: anIndex put: true! ! !NewList methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/16/2012 19:15'! adoptIndexes: aDictionary selectedIndexes contents: aDictionary! ! !NewList methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/29/2012 19:51'! cacheAt: index ^ listCache contents at: index ifAbsent: [ ^ nil ]! ! !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: 'protocol' stamp: 'BenjaminVanRyseghem 11/29/2012 20:07'! deselectAll self isMultipleSelection ifFalse: [ ^ self ]. selectedIndexes removeAll. self secondSelection: 0. selectedIndex contents: 0. self changed.! ! !NewList methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/29/2012 17:51'! inverseSelection self isMultipleSelection ifFalse: [ ^ self ]. 1 to: self listSize do: [: i | self toggleAtIndexes: i ]. self secondSelection: 0. selectedIndex contents: self selectedIndexes first. self changed.! ! !NewList methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 12/16/2012 17:49'! resetListSelectionSilently selectedIndexes removeAll! ! !NewList methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/29/2012 20:11'! selectAll self isMultipleSelection ifFalse: [ ^ self ]. 1 to: self listSize do: [: i | selectedIndexes contents at: i put: true ]. selectedIndexes contentsChanged. self secondSelection: 0. selectedIndex contents: self listSize. self changed.! ! !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 12/16/2012 17:31'! setIndex: index | oldIndex newIndex | oldIndex := selectedIndex contents. newIndex := index. self secondSelection: 0. self setViewToIndex: index. selectedIndex contents: newIndex. (self deSelectOnReclick and: [ oldIndex == newIndex ]) ifTrue: [ self toggleAtIndexes: newIndex ] ifFalse: [ self addAtIndexes: newIndex ]! ! !NewList methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/25/2012 01:31'! setViewToIndex: index index isZero ifTrue: [ ^ self ]. self scrollToShow: (self renderer drawBoundsForIndex: index)! ! !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: 'protocol - events' stamp: 'BenjaminVanRyseghem 11/24/2012 19:07'! whenHeaderIsClickedDo: aBlock clickOnHeader whenChangedDo: aBlock! ! !NewList methodsFor: 'protocol - events' stamp: 'BenjaminVanRyseghem 11/24/2012 01:12'! whenItemsChangedDo: aBlock listCache whenChangedDo: aBlock! ! !NewList methodsFor: 'protocol - events' stamp: 'BenjaminVanRyseghem 11/26/2012 18:47'! whenSelectedIndexChangedDo: aBlock selectedIndex whenChangedDo: aBlock! ! !NewList methodsFor: 'protocol - events' stamp: 'BenjaminVanRyseghem 11/29/2012 19:34'! whenSelectedIndexesChangedDo: aBlock selectedIndexes whenChangedDo: aBlock! ! !NewList methodsFor: 'protocol - events' stamp: 'BenjaminVanRyseghem 11/29/2012 19:46'! whenSelectedItemChangedDo: aBlock selectedItem whenChangedDo: aBlock! ! !NewList methodsFor: 'protocol - events' stamp: 'BenjaminVanRyseghem 11/29/2012 19:46'! whenSelectedItemsChangedDo: aBlock selectedItems whenChangedDo: aBlock! ! !NewList methodsFor: 'testing' stamp: 'BenjaminVanRyseghem 11/25/2012 01:47'! isSecondSelectedIndex: anIndex ^ self secondSelection == anIndex! ! !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: 'updating' stamp: 'BenjaminVanRyseghem 12/17/2012 14:57'! invalidateIconCache iconCache removeAll! ! !NewList methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 12/13/2012 11:09'! invalidateIconCacheFor: anItem iconCache removeKey: anItem! ! !NewList methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 12/17/2012 14:58'! update: aSymbol aSymbol == #getItems ifTrue: [ ^ self updateItems ]. aSymbol == #getListSize ifTrue: [ ^ self updateListSize ]. aSymbol == #getHeaderTitle ifTrue: [ ^ self updateHeaderTitle ]. aSymbol == #iconMaxSize ifTrue: [ ^ self updateIconMaxSize ]. aSymbol == #iconForItem:at: ifTrue: [ ^ self updateIconCache ]. aSymbol == #resetSelectedIndexes ifTrue: [ ^ self deselectAll ]. aSymbol == #invalidateIcons ifTrue: [ ^ self invalidateIconCache ]! ! !NewList methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 11/24/2012 13:45'! updateHeaderTitle self isInitialized ifFalse: [ ^ self ]. headerTitle contents: self retrieveHeaderTitle.! ! !NewList methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 12/17/2012 14:57'! updateIconCache self invalidateIconCache! ! !NewList methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 12/13/2012 09:45'! updateIconMaxSize iconMaxSize contents: self retrieveIconMaxSize! ! !NewList methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 11/23/2012 16:05'! updateItems self isInitialized ifFalse: [ ^ self ]. listCache contents: self retrieveItems! ! !NewList methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 11/23/2012 16:03'! updateListSize self isInitialized ifFalse: [ ^ self ]. listSize contents: self retrieveListSize! ! !NewList methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 12/17/2012 14:44'! updateScrollbars self setScrollDeltas. self scrollBar changed. hScrollBar changed.! ! !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: 'updating - private' stamp: 'BenjaminVanRyseghem 11/29/2012 19:51'! retrieveSelectedItem ^ self rawItemAtIndex: self selectedIndex! ! !NewList methodsFor: 'updating - private' stamp: 'BenjaminVanRyseghem 11/29/2012 19:51'! retrieveSelectedItems ^ self selectedIndexes collect: [:e | self rawItemAtIndex: e ]! ! !NewList methodsFor: 'updating - private' stamp: 'BenjaminVanRyseghem 11/27/2012 01:28'! updateDisplayListCache "self runningProcesses do: [:e | e ifNotNil: [:process | process terminate ]]." displayListCache contents: (Array new: self listSize). self runningProcesses: (Array new: self listSize).! ! !NewList methodsFor: 'updating - private' stamp: 'BenjaminVanRyseghem 11/26/2012 21:04'! updateHeaderHeight | selector | self isInitialized ifFalse: [ ^ self ]. headerHeight contents: self model getHeaderHeight.! ! !NewList methodsFor: 'updating - private' stamp: 'EstebanLorenzano 1/28/2013 15:34'! 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 contents: morph.! ! !NewList methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/26/2012 21:07'! hasHeader ^ headerHeight contents ~~ 0! ! !NewList methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/26/2012 18:48'! hasHeader: aBoolean self renderer hasHeader: aBoolean ! ! !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 11/25/2012 00:11'! itemHalfOffSet ^ 1! ! !NewList methodsFor: 'private' stamp: 'BenjaminVanRyseghem 12/13/2012 09:46'! itemHeight ^ (self font height max: self iconMaxSize y) + (2*self itemHalfOffSet)! ! !NewList methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/25/2012 00:46'! numberOfDisplayedItems ^ (self innerBounds height // self itemHeight) min: self listSize! ! !NewList methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/29/2012 16:29'! resetSelectionIndexes selectedIndexes removeAll! ! !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: 'private' stamp: 'BenjaminVanRyseghem 11/25/2012 02:32'! takesKeyboardFocus "Answer whether the receiver can normally take keyboard focus." ^true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NewList class instanceVariableNames: ''! !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 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! ! !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! ! Model subclass: #NewListAdapter instanceVariableNames: 'list doubleClickSelector dragItemSelector dropItemSelector getDisplaySelector getHeaderTitleSelector getIndexSelector getItemAtIndexSelector getItemsSelector getListSizeSelector keyStrokeSelector lastKeystrokeTime lastKeystrokes model setIndexSelector wantsDropSelector getMenuSelector getMenuTitleSelector getIconSelector getIconMaxSizeSelector getIndexesSelector' classVariableNames: '' poolDictionaries: '' category: 'NewList'! !NewListAdapter commentStamp: '' prior: 0! 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: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:21'! doubleClickSelector ^ doubleClickSelector contents! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:21'! doubleClickSelector: anObject doubleClickSelector contents: anObject! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:21'! dragItemSelector ^ dragItemSelector contents! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/13/2012 08:32'! dragItemSelector: anObject dragItemSelector contents: anObject! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:21'! dropItemSelector ^ dropItemSelector contents! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:21'! dropItemSelector: anObject dropItemSelector contents: anObject! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:49'! endOfInitialization getItemsSelector whenChangedDo: [:e | self list updateItems ]. setIndexSelector contents 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 11/26/2012 18:21'! getDisplaySelector ^ getDisplaySelector contents! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:21'! getDisplaySelector: anObject getDisplaySelector contents: anObject! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:21'! getHeaderTitleSelector ^ getHeaderTitleSelector contents! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:21'! getHeaderTitleSelector: anObject getHeaderTitleSelector contents: anObject! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/13/2012 09:16'! getIconMaxSizeSelector ^ getIconMaxSizeSelector contents! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/13/2012 09:16'! getIconMaxSizeSelector: anObject getIconMaxSizeSelector contents: anObject! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/13/2012 08:46'! getIconSelector ^ getIconSelector contents! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/13/2012 08:46'! getIconSelector: anObject getIconSelector contents: anObject! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:21'! getIndexSelector ^ getIndexSelector contents! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:21'! getIndexSelector: anObject getIndexSelector contents: anObject! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/16/2012 18:19'! getIndexesSelector ^ getIndexesSelector contents! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/16/2012 18:19'! getIndexesSelector: aSelector getIndexesSelector contents: aSelector! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:21'! getItemAtIndexSelector ^ getItemAtIndexSelector contents! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:21'! getItemAtIndexSelector: aSelector getItemAtIndexSelector contents: aSelector! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:21'! getItemsSelector ^ getItemsSelector contents! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:21'! getItemsSelector: anObject getItemsSelector contents: anObject! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:21'! getListSizeSelector ^ getListSizeSelector contents! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:21'! getListSizeSelector: aSelector getListSizeSelector contents: aSelector! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:21'! getMenuSelector ^ getMenuSelector contents! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:57'! getMenuSelector: aSelector getMenuSelector contents: aSelector! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/28/2012 00:30'! getMenuTitleSelector ^ getMenuTitleSelector contents! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/28/2012 00:30'! getMenuTitleSelector: anObject getMenuTitleSelector contents: anObject! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 21:12'! keyStrokeSelector ^ keyStrokeSelector contents! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:21'! keyStrokeSelector: anObject keyStrokeSelector contents: anObject! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:51'! list ^ list contents! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:51'! list: anObject list contents: anObject! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:21'! model ^ model contents! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:21'! model: anObject model contents ifNotNil: [:m | m removeDependent: self ]. anObject ifNotNil: [anObject addDependent: self ]. model contents: anObject! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:21'! setIndexSelector ^ setIndexSelector contents! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:21'! setIndexSelector: anObject setIndexSelector contents: anObject! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:21'! wantsDropSelector ^ wantsDropSelector contents! ! !NewListAdapter methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/26/2012 18:21'! wantsDropSelector: anObject wantsDropSelector contents: anObject! ! !NewListAdapter methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 12/16/2012 18:19'! 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.! ! !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: '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 11/27/2012 00:45'! acceptDroppingMorph: aMorph atIndex: index event: evt 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: self ]! ! !NewListAdapter methodsFor: 'list protocol' stamp: 'BenjaminVanRyseghem 11/29/2012 19:41'! color: aColor self list color: aColor! ! !NewListAdapter methodsFor: 'list protocol' stamp: 'BenjaminVanRyseghem 11/26/2012 20:28'! deSelectOnReclick: aBoolean self list deSelectOnReclick: aBoolean! ! !NewListAdapter methodsFor: 'list protocol' stamp: 'BenjaminVanRyseghem 11/26/2012 20:27'! dragEnabled: aBoolean self list dragEnabled: aBoolean! ! !NewListAdapter methodsFor: 'list protocol' stamp: 'BenjaminVanRyseghem 12/16/2012 18:39'! dragPassengersFor: antem inMorph: aMorph ^ self model dragPassengersFor: antem inMorph: aMorph! ! !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: 'list protocol' stamp: 'BenjaminVanRyseghem 11/26/2012 20:28'! dropEnabled: aBoolean self list dropEnabled: aBoolean! ! !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: '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: '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 12/16/2012 17:17'! getItems ^ self getItemsSelector ifNil: [ nil ] ifNotNil: [:s | self model perform: s ]! ! !NewListAdapter methodsFor: 'list protocol' stamp: 'BenjaminVanRyseghem 12/16/2012 17:17'! getListSize ^ self getListSizeSelector ifNil: [ nil ] ifNotNil: [:s | self model perform: s ]! ! !NewListAdapter methodsFor: 'list protocol' stamp: 'BenjaminVanRyseghem 11/28/2012 00:29'! 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 == nil 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: '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: 'list protocol' stamp: 'BenjaminVanRyseghem 11/26/2012 21:10'! handlesDoubleClick ^ self doubleClickSelector notNil! ! !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: '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 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: 'list protocol' stamp: 'BenjaminVanRyseghem 11/29/2012 20:06'! unselectOnChange: aBoolean self list unselectOnChange: aBoolean! ! !NewListAdapter methodsFor: 'list protocol' stamp: 'BenjaminVanRyseghem 11/27/2012 00:34'! wantsDroppedMorph: aMorph event: anEvent ^ 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: self ]! ! !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: '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: '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 class instanceVariableNames: ''! !NewListAdapter class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 11/26/2012 18:50'! on: aModel ^ self new model: aModel; yourself! ! Model subclass: #NewListModel instanceVariableNames: 'listMorph index toggleTitle rawList pluggable textMorph' classVariableNames: '' poolDictionaries: '' category: 'NewList-Example'! !NewListModel commentStamp: '' prior: 0! NewListModel is a model used as an example for NewList behavior! !NewListModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/23/2012 15:47'! listMorph ^ listMorph! ! !NewListModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/23/2012 15:47'! listMorph: anObject listMorph := anObject! ! !NewListModel methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 12/16/2012 17:28'! buildMorph | list | list := NewList on: self getItemsSelector: #getItems setIndexSelector: #setIndex: getDisplaySelector: #displayItem:. list adapter getHeaderTitleSelector: #title; getMenuSelector: #menu:shifted:; dragEnabled: true; dropEnabled: true; isMultipleSelection: true; deSelectOnReclick: true; 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! ! !NewListModel methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 11/26/2012 17:16'! buildMorphWithOld | list | pluggable := true. ^ list := PluggableListMorph on: self list: #getItems selected: #getIndex changeSelected: #setIndex: menu: #menu:shifted:! ! !NewListModel methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 11/29/2012 19:36'! buildTextMorph ^ PluggableTextMorph new! ! !NewListModel methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 12/13/2012 14:56'! initialize "Initialization code for NewListModel" super initialize. pluggable := false. index := 0. toggleTitle := true. rawList := (1 to: 10) asOrderedCollection. textMorph := self buildTextMorph! ! !NewListModel methodsFor: 'initialize' stamp: 'IgorStasenko 12/20/2012 14:59'! 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); yourself. panel openInWindow! ! !NewListModel methodsFor: 'initialize' stamp: 'IgorStasenko 12/20/2012 15: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); yourself. panel openInWorld! ! !NewListModel methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 11/26/2012 17:14'! withNewList listMorph := self buildMorph.! ! !NewListModel methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 11/26/2012 17:15'! withOldList listMorph := self buildMorphWithOld.! ! !NewListModel methodsFor: 'morphic' stamp: 'BenjaminVanRyseghem 12/13/2012 08:25'! displayItem: anItem ^ anItem asStringMorph color: Color red; yourself" ^ TextInputFieldModel new ghostText: anItem asString."! ! !NewListModel methodsFor: 'morphic' stamp: 'BenjaminVanRyseghem 11/25/2012 22:22'! drop: anItem at: anIndex rawList remove: anItem. rawList add: anItem beforeIndex: anIndex. self changed: #getItems! ! !NewListModel methodsFor: 'morphic' stamp: 'BenjaminVanRyseghem 11/23/2012 17:47'! getIndex ^ index! ! !NewListModel methodsFor: 'morphic' stamp: 'BenjaminVanRyseghem 11/25/2012 22:21'! getItems ^ toggleTitle ifTrue: [ rawList ] ifFalse: [ rawList reversed ]! ! !NewListModel methodsFor: 'morphic' stamp: 'BenjaminVanRyseghem 12/13/2012 09:50'! iconFor: item at: anIndex | icon | icon := NautilusIcons iconNamed: #testGreen. "^ icon" ^ IconicButton new target: self; actionSelector: #halt; labelGraphic: icon ; color: Color transparent; extent: 12 @ 12; helpText: 'Run the tests'; borderWidth: 0.! ! !NewListModel methodsFor: 'morphic' stamp: 'BenjaminVanRyseghem 12/13/2012 09:19'! iconMaxSize ^ 16@16! ! !NewListModel methodsFor: 'morphic' stamp: 'BenjaminVanRyseghem 11/25/2012 03:04'! menu: aMenu shifted: aBoolean aMenu add: 'Foo' target: self selector: #halt. ^ aMenu! ! !NewListModel methodsFor: 'morphic' stamp: 'BenjaminVanRyseghem 11/26/2012 17:16'! setIndex: idx pluggable ifTrue: [ idx = index ifTrue: [ index := 0 ] ifFalse: [ index := idx ]. self changed: #getIndex ].! ! !NewListModel methodsFor: 'morphic' stamp: 'BenjaminVanRyseghem 11/25/2012 22:21'! title ^ toggleTitle ifTrue: [ 'Title' ] ifFalse: [ 'Title (reversed)' ]! ! !NewListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 11/24/2012 19:36'! toggleTitle toggleTitle := toggleTitle not. self changed: #title. self changed: #getItems.! ! ScrollPane subclass: #NewListRenderer instanceVariableNames: 'itemHeight listSource maxWidth hasHeader potentialDropIndex steppingTime mouseDownIndex wantsSteps' classVariableNames: '' poolDictionaries: '' category: 'NewList'! !NewListRenderer commentStamp: '' prior: 0! NewListRenderer is the morph contained by a NewList used to render all the items and manage mouse events.! !NewListRenderer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/24/2012 13:51'! hasHeader ^ hasHeader contents! ! !NewListRenderer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/24/2012 13:51'! hasHeader: anInteger hasHeader contents: anInteger! ! !NewListRenderer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 12/13/2012 09:46'! itemHeight ^ itemHeight contents! ! !NewListRenderer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/24/2012 00:39'! itemHeight: anInteger itemHeight contents: anInteger! ! !NewListRenderer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/24/2012 01:14'! maxWidth ^ maxWidth contents! ! !NewListRenderer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/24/2012 01:14'! maxWidth: anInteger maxWidth contents: anInteger! ! !NewListRenderer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2012 19:19'! mouseDownIndex ^ mouseDownIndex contents! ! !NewListRenderer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/29/2012 19:19'! mouseDownIndex: anInteger mouseDownIndex contents: anInteger! ! !NewListRenderer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/25/2012 19:29'! potentialDropIndex ^ potentialDropIndex contents! ! !NewListRenderer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 11/25/2012 19:28'! potentialDropIndex: anInteger potentialDropIndex contents: anInteger! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/24/2012 14:47'! colorForItem: item at: index ^ self listSource colorForItem: item at: index ! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/29/2012 18:35'! deSelectOnReclick ^ self listSource deSelectOnReclick! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 1/28/2013 17:45'! doubleClickSelector ^ self listSource doubleClickSelector! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/25/2012 15:51'! dragEnabled ^ self listSource dragEnabled! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/25/2012 16:02'! dragItemSelector ^ self listSource dragItemSelector! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 12/16/2012 17:09'! drawColor ^ self listSource drawColor! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/25/2012 19:41'! dropEnabled ^ self listSource dropEnabled! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/25/2012 19:21'! dropItemSelector ^ self listSource dropItemSelector! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/24/2012 00:36'! font ^ self listSource font! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/25/2012 02:43'! getMenuSelector ^ self listSource getMenuSelector! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/29/2012 19:17'! hasMultipledSelected ^ self listSource hasMultipledSelected! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/24/2012 13:33'! headerHeight ^ self listSource headerHeight! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/24/2012 13:48'! headerTitle ^ self listSource headerTitle! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 12/13/2012 09:44'! iconMaxSize ^ self listSource iconMaxSize! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/25/2012 02:34'! isMultipleSelection ^ self listSource isMultipleSelection! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/24/2012 00:36'! isSecondSelectedIndex: index ^ self listSource isSecondSelectedIndex: index! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/24/2012 00:35'! isSelectedIndex: index ^ self listSource isSelectedIndex: index! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/24/2012 00:34'! itemAtIndex: index ^ self listSource itemAtIndex: index! ! !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:33'! listSize "could be cached" ^ self listSource listSize! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/24/2012 00:37'! listSource ^ listSource contents! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/24/2012 00:37'! listSource: anObject listSource contents: anObject. ! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/25/2012 22:17'! rawItemAtIndex: index ^ self listSource rawItemAtIndex: index! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/29/2012 16:29'! resetSelectionIndexes self listSource resetSelectionIndexes! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/25/2012 01:48'! secondSelectionColor ^ self listSource secondSelectionColor! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/24/2012 00:51'! selectedBackgroundColor ^ self listSource selectedBackgroundColor! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/25/2012 00:53'! selectedIndex ^ self listSource selectedIndex! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 12/16/2012 17:25'! selectedIndexes ^ self listSource selectedIndexes! ! !NewListRenderer methodsFor: 'communication with model' stamp: 'BenjaminVanRyseghem 11/29/2012 16:59'! selectionWithKeys ^ self listSource selectionWithKeys! ! !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 19:13'! wantsDropSelector ^ self listSource wantsDropSelector! ! !NewListRenderer methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 11/27/2012 00:40'! 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 ] ensure: [ self resetPotentialDropIndex. evt hand releaseMouseFocus: self. Cursor normal show ] ! ! !NewListRenderer methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 11/29/2012 19:33'! dropAcceptedMorph: transferMorph from: sourceMorph self mouseDownIndex: 0.! ! !NewListRenderer methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 11/29/2012 19:33'! dropRejectedMorph: aTransferMorp self resetPotentialDropIndex. self mouseDownIndex: 0.! ! !NewListRenderer methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 12/16/2012 18:38'! 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 model dragPassengersFor: draggedItem inMorph: self listSource. passenger ifNil: [ ^ self ]. self releaseKeyboardFocus. transferMorph := TransferMorph 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: 'drag and drop' stamp: 'BenjaminVanRyseghem 11/27/2012 00:32'! wantsDroppedMorph: aMorph event: anEvent ^ self listSource wantsDroppedMorph: aMorph event: anEvent! ! !NewListRenderer methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 2/21/2013 23:16'! 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 backgroundColorForRow: 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: 'drawing' stamp: 'BenjaminVanRyseghem 1/28/2013 17:05'! drawOn: aCanvas | first last selectedIdx | 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 hasHeader ifTrue: [ self drawHeaderOn: aCanvas ].! ! !NewListRenderer methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 12/13/2012 10:07'! drawSubmorphsOn: aCanvas "Do nothing please"! ! !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 - background' stamp: 'BenjaminVanRyseghem 12/5/2012 14:45'! drawDefaultBackgroundForItem: item at: index on: aCanvas "Nothing to do"! ! !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: '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: '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: '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: '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 - item' stamp: 'BenjaminVanRyseghem 2/21/2013 23:23'! 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: 'drawing - private' stamp: 'BenjaminVanRyseghem 2/21/2013 23:22'! backgroundColorForIndex: anIndex ^ (self isSelectedIndex: anIndex) ifTrue: [ self selectedBackgroundColor ] ifFalse: [ Color white ]! ! !NewListRenderer methodsFor: 'drawing - private' stamp: 'EstebanLorenzano 1/28/2013 16:10'! basicRemoveAllMorphs submorphs := EmptyArray ! ! !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: '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: '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 - 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: '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: 'drawing - private' stamp: 'BenjaminVanRyseghem 12/13/2012 09:06'! gapBetweenIconAndItem ^ self listSource iconMaxSize ifNil: [ 0 ] ifNotNil: [ 4 ]! ! !NewListRenderer methodsFor: 'drawing - private' stamp: 'BenjaminVanRyseghem 12/13/2012 09:14'! iconColor ^ Color transparent! ! !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: '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: 'drawing - private' stamp: 'BenjaminVanRyseghem 11/25/2012 19:41'! isPotentialDrop: anIndex ^ anIndex == self potentialDropIndex! ! !NewListRenderer methodsFor: 'drawing - private' stamp: 'BenjaminVanRyseghem 11/25/2012 19:44'! potentialDropColor ^ Color blue! ! !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 - 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: '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: '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: '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: '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: 'events' stamp: 'BenjaminVanRyseghem 11/25/2012 19:55'! handlesMouseOverDragging: evt "Yes, for mouse down highlight." ^true! ! !NewListRenderer methodsFor: 'events' stamp: 'BenjaminVanRyseghem 12/16/2012 17:00'! mouseDown: event | selectors index | (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 listSource handlesDoubleClick ifTrue: [ #doubleClick: ]) with: nil with: (self dragEnabled ifTrue: [ #startDrag: ] ifFalse:[ nil ]). event hand waitForClicksOrDrag: self event: event selectors: selectors threshold: 10.! ! !NewListRenderer methodsFor: 'events' stamp: 'BenjaminVanRyseghem 11/24/2012 19:08'! mouseDownOnHeader: anEvent self listSource mouseDownOnHeader: anEvent! ! !NewListRenderer methodsFor: 'events' stamp: 'BenjaminVanRyseghem 11/25/2012 19:54'! mouseLeaveDragging: evt self resetPotentialDropIndex. super mouseLeaveDragging: evt! ! !NewListRenderer methodsFor: 'events' stamp: 'BenjaminVanRyseghem 1/28/2013 17:29'! 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 ) 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: 'events' stamp: 'BenjaminVanRyseghem 12/16/2012 17:00'! mouseUp: event | previousIndex index selectors | self listSource wantsKeyboardFocus ifTrue: [ self listSource takeKeyboardFocus ]. (event position y < (self topDifference + self headerHeight)) ifTrue: [ ^ self mouseDownOnHeader: event ]. 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: 'initialize' stamp: 'BenjaminVanRyseghem 1/28/2013 17:30'! initialize "Initialization code for NewListRenderer" 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 contents: e itemHeight. e whenItemsChangedDo: [ maxWidth contents: 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: 'layout' stamp: 'BenjaminVanRyseghem 12/17/2012 14:09'! privateFullBounds ^ self bounds! ! !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: '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: 'stepping and presenter' stamp: 'BenjaminVanRyseghem 11/25/2012 21:04'! stepTime ^ steppingTime! ! !NewListRenderer methodsFor: 'stepping and presenter' stamp: 'BenjaminVanRyseghem 1/28/2013 17:31'! wantsSteps ^ wantsSteps! ! !NewListRenderer methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/25/2012 21:16'! isScrolling ^ self isStepping! ! !NewListRenderer methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/25/2012 15:58'! releaseKeyboardFocus ActiveHand releaseKeyboardFocus. self listSource changed! ! !NewListRenderer methodsFor: 'private' stamp: 'BenjaminVanRyseghem 11/25/2012 19:31'! resetPotentialDropIndex self potentialDropIndex: 0! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NewListRenderer class instanceVariableNames: ''! !NewListRenderer class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 11/24/2012 00:30'! on: aNewList ^ self new listSource: aNewList; yourself! ! Object subclass: #NewValueHolder instanceVariableNames: 'announcer contents lock' classVariableNames: '' poolDictionaries: '' category: 'Spec-Core'! !NewValueHolder commentStamp: '' prior: 0! A NewValueHolder is a new implementation of ValueHolder based on Announcements! !NewValueHolder methodsFor: 'accessing'! contents ^ contents! ! !NewValueHolder methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/26/2013 01:47'! contents: anObject | oldValue | lock ifTrue: [ ^ self ]. lock := true. oldValue := contents. contents := anObject. [ self contentsChanged: oldValue ] ensure: [ lock := false ]. ^ contents! ! !NewValueHolder methodsFor: 'accessing'! contentsChanged announcer announce: (ValueChanged newContents: contents)! ! !NewValueHolder methodsFor: 'accessing'! contentsChanged: oldValue announcer announce: (ValueChanged oldContents: oldValue newContents: contents)! ! !NewValueHolder methodsFor: 'accessing'! contentsChanged: oldValue to: newValue announcer announce: (ValueChanged oldContents: oldValue newContents: newValue)! ! !NewValueHolder methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/20/2012 11:38'! initialize super initialize. announcer := Announcer new. lock := false.! ! !NewValueHolder methodsFor: 'announcements'! addDependent: aDependent self halt: 'Former API, should be changed'.! ! !NewValueHolder methodsFor: 'announcements' stamp: 'BenjaminVanRyseghem 7/13/2012 01:46'! whenChangedDo: aBlock | block | block := [:announcement :ann | aBlock cull: announcement newContents cull: announcement oldContents cull: announcement cull: ann ]. announcer weak on: ValueChanged do: block! ! !NewValueHolder methodsFor: 'announcements' stamp: 'ThierryGoubier 8/29/2012 16:00'! whenChangedSend: aSelector to: aReceiver announcer weak on: ValueChanged send: aSelector to: aReceiver! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NewValueHolder class instanceVariableNames: ''! !NewValueHolder class methodsFor: 'instance creation'! contents: contents ^ self new contents: contents; yourself! ! Object subclass: #NewVersionBrowser instanceVariableNames: 'list class selector browser' classVariableNames: '' poolDictionaries: '' category: 'Spec-Tools-VersionBrowser'! !NewVersionBrowser commentStamp: '' prior: 0! A NewVersionBrowser is a tool made for browsing the several versions of the provided method.! !NewVersionBrowser methodsFor: 'copy and paste' stamp: 'BenjaminVanRyseghem 6/14/2012 10:00'! scanVersionsOf: method class: class meta: meta category: cat selector: selector ^ ChangeSet scanVersionsOf: method class: class meta: meta category: cat selector: selector! ! !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 7/3/2012 13:55'! browserForList: aList browser:= MessageBrowser new. browser textConverter: DiffMethodReferenceConverter new; topologicSort: false; sortingBlock: [:a :b | a timeStamp > b timeStamp ]; displayBlock: [:changeRecord | { changeRecord stamp firstWord. changeRecord timeStamp asString. changeRecord class name. changeRecord methodSelector. '{',changeRecord category,'}'} ]. browser toolbarModel setDropListItems: { DropListItem named: 'Diff' do: [ browser textConverter: (DiffChangeRecordConverter methodReference: browser textConverter method referencesList: aList) ]. DropListItem named: 'Source' do: [ browser textConverter: (SourceMethodConverter method: browser textConverter method) ]}. browser toolbarModel versionModel label: 'Revert'; action: [ self revert: browser selectedItem ]. ^ browser.! ! !NewVersionBrowser methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 6/14/2012 11:40'! buildBrowser | changeList | changeList := self buildChangeList. self browserForList: changeList. ^ browser messages: changeList; title: 'Versions of ' , class name , '>>' , selector; openWithSpec! ! !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: 'instance creation' stamp: 'BenjaminVanRyseghem 6/14/2012 11:44'! revert: aChangeRecord aChangeRecord ifNil: [self inform: 'nothing selected, so nothing done'] ifNotNil: [ class ifNotNil: [ class compile: aChangeRecord string ]]. browser messages: self buildChangeList; setSelectedIndex: 1.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NewVersionBrowser class instanceVariableNames: ''! !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! ! NetworkError subclass: #NoNetworkError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Network-Kernel'! !NoNetworkError commentStamp: 'mir 5/12/2003 18:17' prior: 0! 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. ! Error subclass: #NonBooleanReceiver instanceVariableNames: 'object' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Exceptions'! !NonBooleanReceiver methodsFor: 'accessing' stamp: 'hmm 7/29/2001 21:30'! object ^object! ! !NonBooleanReceiver methodsFor: 'accessing' stamp: 'hmm 7/29/2001 21:30'! object: anObject object := anObject! ! !NonBooleanReceiver methodsFor: 'signaledexception' stamp: 'hmm 7/29/2001 21:37'! isResumable ^true! ! Object subclass: #NonInteractiveTranscript instanceVariableNames: 'stream fileName accessSemaphore' classVariableNames: '' poolDictionaries: '' category: 'NonInteractiveTranscript'! !NonInteractiveTranscript commentStamp: '' prior: 0! 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. ! !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: '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: 'initialize-release' stamp: 'SvenVanCaekenberghe 7/6/2012 10:38'! close self critical: [ stream ifNotNil: [ self isStdout ifTrue: [ stream flush ] ifFalse: [ stream close ]. stream := nil ] ]! ! !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: 'initialize-release' stamp: 'SvenVanCaekenberghe 9/28/2011 21:22'! initialize super initialize. accessSemaphore := Mutex new! ! !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: 'printing' stamp: 'SvenVanCaekenberghe 9/28/2011 19:26'! isSelfEvaluating self == Transcript ifTrue: [ ^ true ]. ^ super isSelfEvaluating! ! !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 19:30'! << anObject self show: anObject! ! !NonInteractiveTranscript methodsFor: 'streaming' stamp: 'SvenVanCaekenberghe 9/28/2011 19:29'! clear! ! !NonInteractiveTranscript methodsFor: 'streaming' stamp: 'SvenVanCaekenberghe 9/30/2011 10:18'! cr self critical: [ self stream cr ]! ! !NonInteractiveTranscript methodsFor: 'streaming' stamp: 'SvenVanCaekenberghe 9/28/2011 20:02'! crShow: anObject self critical: [ self cr; show: anObject ]! ! !NonInteractiveTranscript methodsFor: 'streaming' stamp: 'SvenVanCaekenberghe 9/28/2011 19:48'! endEntry self flush! ! !NonInteractiveTranscript methodsFor: 'streaming' stamp: 'SvenVanCaekenberghe 9/28/2011 19:30'! ensureCr! ! !NonInteractiveTranscript methodsFor: 'streaming' stamp: 'SvenVanCaekenberghe 9/30/2011 10:18'! flush self critical: [ self stream flush ]! ! !NonInteractiveTranscript methodsFor: 'streaming' stamp: 'SvenVanCaekenberghe 9/30/2011 10:18'! nextPut: aCharacter ^ self critical: [ self stream nextPut: aCharacter ]! ! !NonInteractiveTranscript methodsFor: 'streaming' stamp: 'SvenVanCaekenberghe 9/30/2011 10:19'! nextPutAll: aCollection ^ self critical: [ self stream nextPutAll: aCollection ]! ! !NonInteractiveTranscript methodsFor: 'streaming' stamp: 'SvenVanCaekenberghe 9/28/2011 21:23'! print: anObject self nextPutAll: anObject asString! ! !NonInteractiveTranscript methodsFor: 'streaming' stamp: 'SvenVanCaekenberghe 9/28/2011 19:29'! reset! ! !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:19'! space ^ self critical: [ self stream space ]! ! !NonInteractiveTranscript methodsFor: 'streaming' stamp: 'SvenVanCaekenberghe 9/30/2011 10:19'! tab ^ self critical: [ self stream tab ]! ! !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: 'private' stamp: 'SvenVanCaekenberghe 9/28/2011 19:55'! critical: block ^ accessSemaphore critical: block ! ! !NonInteractiveTranscript methodsFor: 'private' stamp: 'SvenVanCaekenberghe 12/4/2011 18:03'! 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: [ FileStream fileNamed: self fileName ]. stream wantsLineEndConversion: true. self isStdout ifTrue: [ stream converter "Force lazy initialization of converter" ] ifFalse: [ stream setToEnd ]. ^ stream ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NonInteractiveTranscript class instanceVariableNames: ''! !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: '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:34'! file "Create a new NonInteractiveTranscript that will output to the default file named by #defaultLogFileName." ^ self onFileNamed: self defaultLogFileName ! ! !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: '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! ! !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: 'testing' stamp: 'SvenVanCaekenberghe 7/6/2012 10:43'! isInstalled ^ Transcript class = self! ! CommandLineUIManager subclass: #NonInteractiveUIManager instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'UIManager'! !NonInteractiveUIManager commentStamp: 'IgorStasenko 1/24/2011 15:36' prior: 0! 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: '*Morphic' 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: 'IgorStasenko 1/24/2011 10:33'! fileDoesNotExistsDefaultAction: anException ^ self nonInteractive: anException ! ! !NonInteractiveUIManager methodsFor: 'default actions' stamp: 'IgorStasenko 1/24/2011 14:37'! fileExistsDefaultAction: anException ^ self nonInteractive: anException ! ! !NonInteractiveUIManager methodsFor: 'default actions' stamp: 'CamilloBruni 2/9/2012 00:25'! 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 halt. "what else we can do? "! ! !NonInteractiveUIManager methodsFor: 'errors' stamp: 'IgorStasenko 1/21/2011 16:25'! nonInteractive ^ ErrorNonInteractive signal! ! !NonInteractiveUIManager methodsFor: 'errors' stamp: 'IgorStasenko 1/24/2011 10:34'! nonInteractive: anException ^ ErrorNonInteractive signalForException: anException! ! !NonInteractiveUIManager methodsFor: 'errors' stamp: 'CamilloBruni 7/24/2012 16:11'! nonInteractiveRequest: aStringOrText ^ self nonInteractiveRequest: aStringOrText title: nil! ! !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: 'errors' stamp: 'CamilloBruni 7/24/2012 15:57'! nonInteractiveWarning: aWarnMessage ^ ErrorNonInteractive signal: aWarnMessage! ! !NonInteractiveUIManager methodsFor: 'events' stamp: 'CamilloBruni 7/24/2012 16:05'! onDebug: process context: context title: title full: bool ^ self nonInteractiveWarning: 'Opening Debugger'! ! !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: '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! ! !NonInteractiveUIManager methodsFor: 'settings' stamp: 'MarcusDenker 1/26/2011 14:12'! interactiveParserFor: requestor ^ (requestor respondsTo: #interactive) and: [ requestor interactive ]! ! !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: '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: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 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: '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: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 (ProvideAnswerNotification signal: queryString) ifNotNil: [:answer | ^ answer]. ^ self nonInteractiveWarning: 'Confirming: ', 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: aString orCancel: cancelBlock ^ self nonInteractiveRequest: aString! ! !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:12'! confirm: queryString trueChoice: trueChoice falseChoice: falseChoice cancelChoice: cancelChoice default: aSymbol ^ self nonInteractiveRequest: queryString! ! !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:06'! fontFromUser: priorFont ^self nonInteractiveWarning: 'Font Choose Request'! ! !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: queryString initialAnswer: defaultAnswer ^ self request: queryString initialAnswer: defaultAnswer title: nil entryCompletion: nil. ! ! !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:02'! request: aStringOrText initialAnswer: defaultAnswer title: aTitle ^ self request: aStringOrText initialAnswer: defaultAnswer title: aTitle entryCompletion: nil. ! ! !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 15:56'! requestPassword: queryString ^self nonInteractiveWarning: 'Requesting Password'.! ! !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! ! WeakMessageSend weakSubclass: #NonReentrantWeakMessageSend instanceVariableNames: 'executing' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-EventEnhancements'! !NonReentrantWeakMessageSend commentStamp: 'LaurentLaffont 4/15/2011 20:18' prior: 0! 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: 'accessing' stamp: 'gvc 10/25/2006 18:03'! executing "Answer the value of executing" ^ executing! ! !NonReentrantWeakMessageSend methodsFor: 'accessing' stamp: 'gvc 10/25/2006 18:03'! executing: anObject "Set the value of executing" executing := anObject! ! !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: '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: 'initialize-release' stamp: 'gvc 10/25/2006 18:04'! initialize "Initialize the receiver." super initialize. self executing: false! ! !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]! ! Error subclass: #NotFound instanceVariableNames: 'object' classVariableNames: '' poolDictionaries: '' category: 'Collections-Abstract'! !NotFound commentStamp: 'SvenVanCaekenberghe 4/18/2011 14:32' prior: 0! 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:27'! collection "Return the collection where something is not found in" ^ self signaler! ! !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: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 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: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 class instanceVariableNames: ''! !NotFound class methodsFor: 'instance creation' stamp: 'SvenVanCaekenberghe 4/18/2011 14:26'! signalFor: anObject "Create and signal a NotFond exception for anObject in the default receiver." ^ self new object: anObject; signal! ! !NotFound class methodsFor: 'instance creation' stamp: 'SvenVanCaekenberghe 4/18/2011 14:26'! signalFor: anObject in: aCollection "Create and signal a NotFond exception for anObject in aCollection." ^ self new object: anObject; collection: aCollection; signal! ! SelectorException subclass: #NotYetImplemented instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Exceptions'! !NotYetImplemented commentStamp: '' prior: 0! 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]! ! Exception subclass: #Notification instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Exceptions'! !Notification commentStamp: '' prior: 0! 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! ! PluggableCanvas subclass: #NullCanvas instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Support'! !NullCanvas commentStamp: '' prior: 0! A canvas which ignores all drawing commands.! !NullCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 21:11'! clipRect ^1@1 extent: 99@99! ! !NullCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 21:11'! extent ^100@100! ! !NullCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 21:12'! form ^Form extent: self extent! ! !NullCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 21:13'! origin ^0@0! ! !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! ! !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: '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! ! AbstractSpec subclass: #NullObjectSpec instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Spec-Core-Specs'! !NullObjectSpec commentStamp: '' prior: 0! A NullObjectSpec is a NullPattern object spec! !NullObjectSpec methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/6/2012 18:40'! addAsSubSpecTo: anotherSpec ! ! !NullObjectSpec methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 6/6/2012 18:37'! addSubSpec: anObject "absorb the message"! ! Object subclass: #NullSound instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Themes'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NullSound class instanceVariableNames: ''! !NullSound class methodsFor: 'playing' stamp: 'gvc 7/30/2009 17:55'! play "Do nothing for the null sound."! ! SoundTheme subclass: #NullSoundTheme instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Themes'! !NullSoundTheme methodsFor: 'initialize-release' stamp: 'gvc 7/30/2009 17:56'! defaultDefaultSound "Answer the default default sound!!" ^NullSound! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! NullSoundTheme class instanceVariableNames: ''! !NullSoundTheme class methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 17:57'! themeName "Answer the friendly name of the theme." ^'No Sounds'! ! Stream subclass: #NullStream instanceVariableNames: 'binary position' classVariableNames: '' poolDictionaries: '' category: 'Collections-Streams'! !NullStream commentStamp: '' prior: 0! 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: 'accessing' stamp: 'StephaneDucasse 3/13/2010 11:04'! ascii "Switches the stream to ascii mode" binary := false.! ! !NullStream methodsFor: 'accessing' stamp: 'StephaneDucasse 3/13/2010 11:05'! binary "Switches the stream to binary mode" binary := true! ! !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: 'accessing' stamp: 'StephaneDucasse 3/13/2010 11:05'! contents "Answer all of the contents of the receiver." self shouldNotImplement! ! !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: 'MilanMimica 11/4/2011 21:22'! printOn: aStream aStream nextPutAll: 'a '; nextPutAll: self class name.! ! !NullStream methodsFor: 'initialize-release' stamp: 'StephaneDucasse 3/13/2010 11:06'! initialize "Initialize the receiver" binary := false. position := 0.! ! !NullStream methodsFor: 'positioning' stamp: 'StephaneDucasse 3/13/2010 11:08'! position "Answer the current position of accessing the sequence of objects." ^position! ! !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: '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: '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: '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: 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: '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: '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: '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: '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: '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 methodsFor: 'testing' stamp: 'StephaneDucasse 3/13/2010 11:05'! atEnd "Answer whether the receiver can access any more objects." ^false! ! !NullStream methodsFor: 'testing' stamp: 'StephaneDucasse 3/13/2010 11:05'! isBinary "Return true if the receiver is a binary byte stream" ^binary! ! !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: '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: 'writing' stamp: 'StephaneDucasse 3/13/2010 11:07'! next: anInteger putAll: aCollection startingAt: startIndex "Store the next anInteger elements from the given collection." position := position + anInteger. ^aCollection! ! !NullStream methodsFor: 'writing' stamp: 'StephaneDucasse 3/13/2010 11:07'! nextPut: anObject "Insert the argument, anObject, as the next object accessible by the receiver. Answer anObject." position := position + 1. ^anObject! ! !NullStream methodsFor: 'writing' stamp: 'StephaneDucasse 3/13/2010 11:08'! nextPutAll: aCollection "Append the elements of aCollection to the sequence of objects accessible by the receiver. Answer aCollection." position := position + aCollection size. ^aCollection! ! !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 class instanceVariableNames: ''! !NullStream class methodsFor: 'instance creation' stamp: 'StephaneDucasse 3/13/2010 11:09'! new "Creates a new instance" ^self basicNew initialize! ! Object subclass: #NullTextStyler instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Text Support'! !NullTextStyler commentStamp: 'BenjaminVanRyseghem 8/1/2010 22:53' prior: 0! This class is a styler NullObject! !NullTextStyler methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/2/2010 16:17'! classOrMetaClass: aBehavior! ! !NullTextStyler methodsFor: 'accessing' stamp: 'AlainPlantec 8/27/2011 14:15'! environment: anObject ! ! !NullTextStyler methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/2/2010 16:17'! font: aFont! ! !NullTextStyler methodsFor: 'accessing' stamp: 'AlainPlantec 5/11/2011 11:02'! view: aViewOrMorph ! ! !NullTextStyler methodsFor: 'accessing' stamp: 'AlainPlantec 5/11/2011 11:03'! workspace: aWorkspace ! ! !NullTextStyler methodsFor: 'formatting' stamp: 'BenjaminVanRyseghem 8/1/2010 14:26'! format: aText ^aText! ! !NullTextStyler methodsFor: 'styling' stamp: 'BenjaminVanRyseghem 8/1/2010 14:27'! style: aText! ! !NullTextStyler methodsFor: 'styling' stamp: 'AlainPlantec 5/11/2011 10:36'! styleInBackgroundProcess: aText ! ! !NullTextStyler methodsFor: 'styling' stamp: 'StephaneDucasse 8/10/2010 12:35'! unstyledTextFrom: aText ^aText! ! !NullTextStyler methodsFor: 'private' stamp: 'AlainPlantec 9/19/2011 19:32'! stylingEnabled ^ false! ! !NullTextStyler methodsFor: 'private' stamp: 'AlainPlantec 9/19/2011 19:32'! stylingEnabled: aBoolean ! ! Magnitude subclass: #Number instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Numbers'! !Number commentStamp: 'StephaneDucasse 11/1/2010 07:50' prior: 0! 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 Squeak. 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 fonction 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: '*Kernel-Chronology' stamp: 'brp 5/13/2003 10:13'! asDuration ^ Duration nanoSeconds: self asInteger ! ! !Number methodsFor: '*Kernel-Chronology' stamp: 'CamilloBruni 6/22/2012 21:48'! asSeconds ^ Duration milliSeconds: self * 1000! ! !Number methodsFor: '*Kernel-Chronology' stamp: 'tbn 10/29/2012 15:51'! day ^ self days! ! !Number methodsFor: '*Kernel-Chronology' stamp: 'brp 5/16/2003 07:56'! days ^ Duration days: self! ! !Number methodsFor: '*Kernel-Chronology' stamp: 'tbn 10/24/2012 15:32'! hour ^ self hours! ! !Number methodsFor: '*Kernel-Chronology' stamp: 'brp 5/16/2003 07:56'! hours ^ Duration hours: self! ! !Number methodsFor: '*Kernel-Chronology' stamp: 'tbn 10/29/2012 16:00'! milliSecond ^ self milliSeconds ! ! !Number methodsFor: '*Kernel-Chronology' stamp: 'brp 9/25/2003 13:16'! milliSeconds ^ Duration milliSeconds: self ! ! !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'! minutes ^ Duration minutes: self! ! !Number methodsFor: '*Kernel-Chronology' stamp: 'tbn 10/29/2012 16:23'! nanoSecond ^ self nanoSeconds ! ! !Number methodsFor: '*Kernel-Chronology' stamp: 'brp 5/16/2003 08:52'! nanoSeconds ^ Duration nanoSeconds: self.! ! !Number methodsFor: '*Kernel-Chronology' stamp: 'tbn 10/29/2012 15:12'! second ^ self seconds ! ! !Number methodsFor: '*Kernel-Chronology' stamp: 'brp 5/16/2003 07:57'! seconds ^ Duration seconds: self! ! !Number methodsFor: '*Kernel-Chronology' stamp: 'tbn 10/29/2012 15:15'! week ^ self weeks ! ! !Number methodsFor: '*Kernel-Chronology' stamp: 'brp 5/16/2003 07:57'! weeks ^ Duration weeks: self! ! !Number methodsFor: '*Kernel-Chronology' stamp: 'tbn 10/29/2012 16:23'! year ^self years! ! !Number methodsFor: '*Kernel-Chronology' stamp: 'CamilloBruni 9/22/2012 10:48'! years ^ Duration years: self! ! !Number methodsFor: '*Tools-Inspector'! defaultLabelForInspector "Answer the default label to be used for an Inspector window on the receiver." ^ super defaultLabelForInspector, ': ', self printString! ! !Number methodsFor: 'arithmetic'! * aNumber "Answer the result of multiplying the receiver by aNumber." self subclassResponsibility! ! !Number methodsFor: 'arithmetic'! + aNumber "Answer the sum of the receiver and aNumber." self subclassResponsibility! ! !Number methodsFor: 'arithmetic'! - aNumber "Answer the difference between the receiver and aNumber." self subclassResponsibility! ! !Number methodsFor: 'arithmetic'! / aNumber "Answer the result of dividing the receiver by aNumber." self subclassResponsibility! ! !Number methodsFor: 'arithmetic'! // 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: 'arithmetic'! \\ 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: 'arithmetic'! abs "Answer a Number that is the absolute value (positive magnitude) of the receiver." self < 0 ifTrue: [^self negated] ifFalse: [^self]! ! !Number methodsFor: 'arithmetic' stamp: 'mk 10/27/2003 21:00'! arg "Answer the argument of the receiver (see Complex | arg)." self isZero ifTrue: [self error: 'Zero (0 + 0 i) does not have an argument.']. 0 < self ifTrue: [^ 0] ifFalse: [^ Float pi]! ! !Number methodsFor: 'arithmetic'! negated "Answer a Number that is the negation of the receiver." ^0 - 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: '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: 'arithmetic'! 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: '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: 'converting'! @ 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: '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: '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: '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: '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: '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: '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: '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: 'ar 5/20/2001 01:40'! asB3DVector3 ^self@self@self! ! !Number methodsFor: 'converting' stamp: 'SvenVanCaekenberghe 3/8/2012 08:20'! asFloat "Answer a floating-point number approximating the receiver." self subclassResponsibility! ! !Number methodsFor: 'converting'! asInteger "Answer an Integer nearest the receiver toward zero." ^self truncated! ! !Number methodsFor: 'converting' stamp: 'sw 2/16/1999 18:15'! asNumber ^ self! ! !Number methodsFor: 'converting'! 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: 'dtl 9/25/2004 11:47'! asScaledDecimal "Answer a scaled decimal number approximating the receiver." #Numeric. ^ self asScaledDecimal: 8 ! ! !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: '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: 'converting' stamp: 'nice 10/5/2009 21:28'! asSmallPositiveDegrees "Return the receiver normalized to lie within the range (0, 360)" ^self \\ 360! ! !Number methodsFor: 'converting'! degreesToRadians "The receiver is assumed to represent degrees. Answer the conversion to radians." ^self asFloat degreesToRadians! ! !Number methodsFor: 'converting'! radiansToDegrees "The receiver is assumed to represent radians. Answer the conversion to degrees." ^self asFloat radiansToDegrees! ! !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: 'intervals'! 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: 'intervals'! 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: '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: 'intervals'! 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: '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: 'mathematical functions' stamp: 'CamilloBruni 7/10/2012 22:24'! ** exponent " A shortcut methog for raisedTo: " ^ self raisedTo: exponent! ! !Number methodsFor: 'mathematical functions'! arcCos "The receiver is the cosine of an angle. Answer the angle measured in radians." ^self asFloat arcCos! ! !Number methodsFor: 'mathematical functions'! arcSin "The receiver is the sine of an angle. Answer the angle measured in radians." ^self asFloat arcSin! ! !Number methodsFor: 'mathematical functions'! arcTan "The receiver is the tangent of an angle. Answer the angle measured in radians." ^self asFloat arcTan! ! !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: '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: 'mathematical functions'! cos "The receiver represents an angle measured in radians. Answer its cosine." ^self asFloat cos! ! !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: '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'! exp "Answer the exponential of the receiver as a floating point number." ^self asFloat exp! ! !Number methodsFor: 'mathematical functions' stamp: 'jm 3/27/98 06:16'! floorLog: radix "Answer the floor of the log base radix of the receiver." ^ self asFloat floorLog: radix ! ! !Number methodsFor: 'mathematical functions' stamp: 'ar 8/31/2000 20:05'! interpolateTo: aNumber at: param ^self + (aNumber - self * param)! ! !Number methodsFor: 'mathematical functions'! ln "Answer the natural log of the receiver." ^self asFloat ln! ! !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: 'mathematical functions'! log: aNumber "Answer the log base aNumber of the receiver." ^self ln / aNumber ln! ! !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: '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: '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: 'mathematical functions'! 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: '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: 'mathematical functions'! sin "The receiver represents an angle measured in radians. Answer its sine." ^self asFloat sin! ! !Number methodsFor: 'mathematical functions' stamp: 'jmv 10/11/2011 08:34'! sqrt "Answer the square root of the receiver." self subclassResponsibility! ! !Number methodsFor: 'mathematical functions'! squared "Answer the receiver multipled by itself." ^self * self! ! !Number methodsFor: 'mathematical functions'! tan "The receiver represents an angle measured in radians. Answer its tangent." ^self asFloat tan! ! !Number methodsFor: 'printing' stamp: 'sw 6/29/1999 21:10'! isOrAreStringWith: aNoun | result | result := self = 1 ifTrue: [' is one '] ifFalse: [self = 0 ifTrue: [' are no '] ifFalse: [' are ', self printString, ' ']]. result := result, aNoun. self = 1 ifFalse: [result := result, 's']. ^ result "#(0 1 2 98.6) do: [:num | Transcript cr; show: 'There', (num isOrAreStringWith: 'way'), ' to skin a cat']"! ! !Number methodsFor: 'printing' stamp: 'laza 3/29/2004 12:53'! printOn: aStream self printOn: aStream base: 10! ! !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: '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: '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: 'printing' stamp: 'laza 3/30/2004 10:50'! printString ^self printStringBase: 10! ! !Number methodsFor: 'printing'! printStringBase: base ^ String streamContents: [:strm | self printOn: strm base: base]! ! !Number methodsFor: 'printing' stamp: 'laza 3/29/2004 12:50'! storeOn: aStream self printOn: aStream! ! !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'! storeStringBase: base ^ String streamContents: [:strm | self storeOn: strm base: base]! ! !Number methodsFor: 'printing' stamp: 'sw 7/1/1998 12:33'! stringForReadout ^ self rounded printString! ! !Number methodsFor: 'testing'! even "Answer whether the receiver is an even number." ^self \\ 2 = 0! ! !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: 'testing' stamp: 'tao 4/19/98 23:33'! isInfinite ^ false! ! !Number methodsFor: 'testing' stamp: 'tao 10/10/97 16:36'! isNaN ^ false! ! !Number methodsFor: 'testing'! isNumber ^ true! ! !Number methodsFor: 'testing'! isZero ^self = 0! ! !Number methodsFor: 'testing' stamp: 'di 4/23/1998 11:18'! negative "Answer whether the receiver is mathematically negative." ^ self < 0! ! !Number methodsFor: 'testing'! odd "Answer whether the receiver is an odd number." ^self even == false! ! !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: 'testing' stamp: 'di 4/23/1998 11:02'! strictlyPositive "Answer whether the receiver is mathematically positive." ^ self > 0! ! !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: '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: 'truncation and round off'! 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: 'truncation and round off' stamp: 'StephaneDucasse 5/8/2010 17:14'! fractionPart "Added for ANSI compatibility" ^self - self integerPart! ! !Number methodsFor: 'truncation and round off' stamp: 'GabrielOmarCotelli 5/26/2009 21:57'! integerPart "Added for ANSI compatibility" ^self truncated! ! !Number methodsFor: 'truncation and round off'! reduce "If self is close to an integer, return that integer" ^ self! ! !Number methodsFor: 'truncation and round off' stamp: 'GuillermoPolito 6/22/2012 14:49'! round: numberOfWishedDecimal self subclassResponsibility! ! !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: '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: '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: 'truncation and round off'! rounded "Answer the integer nearest the receiver." ^(self + (self sign / 2)) truncated! ! !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: 'truncation and round off'! truncated "Answer an integer nearest the receiver toward zero." ^self quo: 1! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Number class instanceVariableNames: ''! !Number class methodsFor: '*System-Settings-Browser' stamp: 'alain.plantec 3/18/2009 15:09'! settingInputWidgetForNode: aSettingNode ^ aSettingNode inputWidgetForNumber! ! !Number class methodsFor: 'constants' stamp: 'GabrielOmarCotelli 5/23/2009 20:46'! one ^1! ! !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: 'deprecated' stamp: 'nice 5/16/2009 22:11'! 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 isNil ifTrue: ["s" fractionDigits = 0 ifTrue: ["s" scale := 0] ifFalse: [".s" scale := fractionDigits]]. fractionPart isNil ifTrue: [^integerPart * sign asScaledDecimal: scale] ifFalse: [decimalMultiplier := base raisedTo: fractionDigits. decimalFraction := integerPart * decimalMultiplier + fractionPart * sign / decimalMultiplier. ^decimalFraction asScaledDecimal: scale]! ! !Number class methodsFor: 'instance creation' stamp: 'nice 2/22/2010 21:43'! 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." ^(ExtendedNumberParser on: stringOrStream) nextNumber! ! !Number class methodsFor: 'instance creation' stamp: 'GuillermoPolito 8/24/2010 18:50'! 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." ^(SqNumberParser on: stringOrStream) nextNumberBase: base! ! !Number class methodsFor: 'instance creation' stamp: 'nice 2/22/2010 22:40'! 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" ^(ExtendedNumberParser on: stringOrStream) failBlock: aBlock; nextNumber! ! !Number class methodsFor: 'instance creation' stamp: 'nice 4/28/2012 16:11'! readSmalltalkSyntaxFrom: 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." ^(SqNumberParser on: stringOrStream) nextNumber! ! !Number class methodsFor: 'instance creation' stamp: 'NikoSchwarz 10/23/2009 13:18'! 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." ^ SqNumberParser squeezeNumberOutOfString: stringOrStream! ! !Number class methodsFor: 'instance creation' stamp: 'NikoSchwarz 10/23/2009 13:19'! 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." ^ SqNumberParser squeezeNumberOutOfString: stringOrStream onError: aBlock! ! Object subclass: #NumberParser instanceVariableNames: 'sourceStream base neg integerPart fractionPart exponent scale nDigits lastNonZero requestor failBlock' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Numbers'! !NumberParser commentStamp: 'nice 2/13/2010 00:31' prior: 0! 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: 'nice 2/12/2010 23:56'! allowPlusSign "return a boolean indicating if plus sign is allowed or not" ^self subclassResponsibility! ! !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: 'nice 2/12/2010 23:55'! exponentLetters "answer the list of possible exponents for Numbers." ^self subclassResponsibility! ! !NumberParser methodsFor: 'accessing' stamp: 'nice 5/1/2006 01:58'! failBlock: aBlockOrNil failBlock := aBlockOrNil! ! !NumberParser methodsFor: 'accessing' stamp: 'nice 5/1/2006 01:59'! requestor: anObjectOrNil requestor := anObjectOrNil! ! !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: 'error' stamp: 'NikoSchwarz 10/17/2009 10:45'! fail failBlock ifNotNil: [^failBlock value]. self error: 'Reading a number failed'! ! !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: '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-large int' stamp: 'nice 7/26/2009 00:24'! 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 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. low := self nextLargeIntegerBase: aRadix nPackets: halfPackets. nDigitsLow := nDigits. nDigits := nDigitsHigh + nDigitsLow. lastNonZero = 0 ifFalse: [lastNonZero := lastNonZero + nDigitsHigh]. ^high * (aRadix raisedToInteger: nDigitsLow) + low! ! !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-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: '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 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: '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 10/30/2011 16:13'! nextInteger "Read and answer next integer from sourceStream contents. Default behaviour is to read an integer in base 10. Subclasses might implement alternatives." ^self nextIntegerBase: 10! ! !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: '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 2/12/2010 23:59'! nextNumber "read next number from sourceStream contents" ^self subclassResponsibility! ! !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-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-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 class instanceVariableNames: ''! !NumberParser class methodsFor: 'instance creation' stamp: 'nice 5/1/2006 00:45'! on: aStringOrStream ^self new on: aStringOrStream! ! !NumberParser class methodsFor: 'instance creation' stamp: 'nice 5/1/2006 02:02'! parse: aStringOrStream ^(self new) on: aStringOrStream; nextNumber! ! !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: '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: 'BenjaminVanRyseghem 7/1/2012 14:17'! 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 ]) ifNotNilDo: [ :result| ^ result ]. string := string allButFirst ]. ^ errorBlock value! ! TestCase subclass: #NumberParsingTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Numbers'! !NumberParsingTest commentStamp: 'dtl 11/24/2004 15:35' prior: 0! Tests to verify parsing of numbers from streams and strings. Note: ScaledDecimalTest contains related tests for parsing ScaledDecimal.! !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 - Float' stamp: 'nice 4/28/2012 17:32'! 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. "Plus sign is not parseable in Smalltalk syntax" aFloat := Number readSmalltalkSyntaxFrom: rs. self assert: 1.0 = aFloat. self assert: rs upToEnd = 'e+14e'. rs := '1.0e+14e' readStream. "Plus sign is parseable in extended syntax" aFloat := Number readFrom: rs. self assert: 1.0e14 = aFloat. self assert: rs upToEnd = 'e'. rs := '1.0e' readStream. aFloat := Number readFrom: rs. self assert: 1.0 = aFloat. self assert: rs upToEnd = 'e'.! ! !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 - Float' stamp: 'nice 4/28/2012 17:30'! 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. aFloat := '1.0e+14e' asSmalltalkNumber. "Plus sign is not parseable in Smalltalk syntax" self assert: 1.0 = aFloat. aFloat := '1.0e+14e' asNumber. "Plus sign is parseable in extended syntax" self assert: 1.0e14 = aFloat. ! ! !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: '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: 'nice 4/28/2012 17:31'! testNumberReadOnlyDigit "This covers parsing in Number>>readFrom:" | rs num | rs := '1e' readStream. num := Number readSmalltalkSyntaxFrom: rs. self assert: 1 = num. self assert: rs upToEnd = 'e'. rs := '1s' readStream. num := Number readSmalltalkSyntaxFrom: rs. self assert: 1 = num. self assert: rs upToEnd = 's'. rs := '1.' readStream. num := Number readSmalltalkSyntaxFrom: rs. self assert: 1 = num. self assert: num isInteger. self assert: rs upToEnd = '.'.! ! !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 - Integer' stamp: 'nice 4/28/2012 17:30'! 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 - 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 - 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).! ! ClassTestCase subclass: #NumberTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Numbers'! !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/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/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 3/24/2008 16:50'! 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" self shouldnt: [1.0e306 printShowingDecimalPlaces: 3] raise: Error.! ! !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: '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/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! ! !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: '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: '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! ! Object subclass: #OSPlatform instanceVariableNames: '' classVariableNames: 'Current' poolDictionaries: '' category: 'System-Platforms'! !OSPlatform commentStamp: 'michael.rueger 2/25/2009 18:29' prior: 0! 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: 'michael.rueger 2/25/2009 18:18'! platformFamily "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: 'accessing' stamp: 'michael.rueger 2/25/2009 22:19'! virtualKey: virtualKeyCode ^self class virtualKey: virtualKeyCode! ! !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: '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 class instanceVariableNames: ''! !OSPlatform class methodsFor: '*compatibility' stamp: 'MarcusDenker 1/23/2013 15:04'! osVersion "We keep this for compatibility with 1.4 for a while " ^Smalltalk os version! ! !OSPlatform class methodsFor: '*compatibility' stamp: 'MarcusDenker 1/23/2013 14:57'! vmVersion "Return the version number string of the Virtual machine built" ^Smalltalk vm version! ! !OSPlatform class methodsFor: 'accessing' stamp: 'ar 12/11/2004 23:04'! current "Answer the current platform" ^Current! ! !OSPlatform class methodsFor: 'accessing' stamp: 'michael.rueger 2/27/2009 17:25'! virtualKey: virtualKeyCode "Subclass responsibility to override if necessary" ^nil! ! !OSPlatform class methodsFor: 'class initialization' stamp: 'michael.rueger 3/2/2009 11:16'! initialize "Initialize the receiver" "OSPlatform initialize" Smalltalk removeFromStartUpList: self. Smalltalk addToStartUpList: self after: Delay. Smalltalk removeFromShutDownList: self. Smalltalk addToShutDownList: self after: DisplayScreen. self startUp: true.! ! !OSPlatform class methodsFor: 'class initialization' stamp: 'ar 12/11/2004 22:49'! shutDown: quitting "The system is going down" Current ifNotNil:[Current shutDown: quitting]. ! ! !OSPlatform class methodsFor: 'class initialization' stamp: 'michael.rueger 2/25/2009 18:20'! startUp: resuming "Determine the current platform. Use the most specific (in terms of subclasses) platform available." | platformClass | "Look for the matching platform class" platformClass := self determineActivePlatformStartingAt: self. platformClass ifNil: [^self]. Current := platformClass new. Current startUp: resuming! ! !OSPlatform class methodsFor: 'system attributes'! platformName "Return the name of the platform we're running on" ^ Smalltalk vm getSystemAttribute: 1001! ! !OSPlatform class methodsFor: 'system attributes'! platformSubtype "Return the subType of the platform we're running on" ^ self subtype! ! !OSPlatform class methodsFor: 'system attributes'! subtype "Return the subType of the platform we're running on" "Smalltalk platformSubtype" ^ (Smalltalk vm getSystemAttribute: 1003)! ! !OSPlatform class methodsFor: 'system attributes' stamp: 'CamilloBruni 5/13/2012 19:37'! version "Return the version number string of the platform we're running on" "OSPlatform osVersion" ^(Smalltalk vm getSystemAttribute: 1002) asString! ! !OSPlatform class methodsFor: 'system attributes' stamp: 'StephaneDucasse 8/18/2011 11:34'! windowSystemName "Return the name of the window system currently being used for display." "OSPlatform windowSystemName" ^ Smalltalk vm getSystemAttribute: 1005! ! !OSPlatform class methodsFor: 'testing' stamp: 'dfsdfsd 6/11/2010 15:44'! isMacOS ^ self platformName = 'Mac OS'! ! !OSPlatform class methodsFor: 'testing' stamp: 'MarcusDenker 7/13/2012 14:30'! isMacOSX ^ self isMacOS and: ['10*' match: self version]! ! !OSPlatform class methodsFor: 'testing' stamp: 'dfsdfsd 6/11/2010 15:45'! isUnix ^ self platformName = 'unix'! ! !OSPlatform class methodsFor: 'testing' stamp: 'dfsdfsd 6/11/2010 15:45'! isWin32 ^ self platformName = 'Win32' ! ! !OSPlatform class methodsFor: 'testing' stamp: 'dfsdfsd 6/11/2010 15:46'! isX11 ^ self isUnix and: [self windowSystemName = 'X11']! ! !OSPlatform class methodsFor: 'private' stamp: 'michael.rueger 2/25/2009 18:20'! determineActivePlatformStartingAt: parentClass "Determine the current platform starting at parentClass. This is a potentially recursive process as we want to determine the most specific (in terms of subclasses) platform available." "OSPlatform determineActivePlatformStartingAt: OSPlatform" | platformClass | parentClass subclasses isEmpty ifTrue: [^parentClass]. "Look for the matching platform class" platformClass := parentClass allSubclasses detect:[:any| any isActivePlatform] ifNone:[nil]. "Check if there is a more specific subclass" ^self determineActivePlatformStartingAt: platformClass! ! !OSPlatform class methodsFor: 'private' stamp: 'ar 12/11/2004 22:22'! isActivePlatform "Answer whether the receiver is the active platform" ^false! ! TestCase subclass: #OSPlatformTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-System'! !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) ]! ! ProtoObject subclass: #Object instanceVariableNames: '' classVariableNames: 'DependentsFields' poolDictionaries: '' category: 'Kernel-Objects'! !Object commentStamp: 'StephaneDucasse 1/3/2010 20:41' prior: 0! 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. EventsFields an IdentityDictionary that maps each object to its dependents. Registers a message send (consisting of a selector and a receiver object) which should be performed when anEventSymbol is triggered by the receiver. Part of a new event notification framework which could eventually replace the existing changed/update mechanism. It is intended to be compatible with Dolphin Smalltalk and VSE as much as possible. 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. 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: '*Collections-Abstract-splitjoin' stamp: 'onierstrasz 4/12/2009 19:58'! appendTo: aCollection "double dispatch for join:" ^ aCollection addLast: self! ! !Object methodsFor: '*Collections-Abstract-splitjoin' stamp: 'onierstrasz 4/10/2009 22:50'! join: aSequenceableCollection ^ (Array with: self) join: aSequenceableCollection! ! !Object methodsFor: '*Collections-Abstract-splitjoin' stamp: 'onierstrasz 4/12/2009 19:58'! joinTo: stream "double dispatch for join:" ^ stream nextPut: self! ! !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: '*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: '*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: '*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: '*Fuel' stamp: 'MartinDias 8/27/2011 19:03'! fuelAfterMaterialization "Materialization process will send this message after materializing instances of my class"! ! !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: '*Kernel-Exceptions-debugging' stamp: 'MarcusDenker 2/29/2012 08:25'! halt "This is the typical message to use for inserting breakpoints during debugging." Halt now.! ! !Object methodsFor: '*Kernel-Exceptions-debugging' stamp: 'MarcusDenker 2/29/2012 08:24'! halt: aString Halt now: aString! ! !Object methodsFor: '*Kernel-Exceptions-debugging' stamp: 'SeanDeNigris 8/29/2011 10:51'! haltIf: condition Halt if: condition.! ! !Object methodsFor: '*Kernel-Exceptions-debugging' stamp: 'SeanDeNigris 8/29/2011 12:16'! haltIfShiftPressed Halt ifShiftPressed.! ! !Object methodsFor: '*Kernel-Exceptions-debugging' stamp: 'SeanDeNigris 8/29/2011 15:16'! haltOnCount: anInteger Halt onCount: anInteger.! ! !Object methodsFor: '*Kernel-Exceptions-debugging' stamp: 'SeanDeNigris 8/29/2011 15:02'! haltOnce Halt once.! ! !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: '*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: '*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: '*Morphic' 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: '*Morphic' stamp: 'CamilloBruni 10/21/2012 23:38'! asDraggableMorph ^ self asStringMorph ! ! !Object methodsFor: '*Morphic' 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: '*Morphic' stamp: 'MarcusDenker 7/20/2012 14:57'! asStringMorph "Open a StringMorph, as best one can, on the receiver" ^ self asString asStringMorph ! ! !Object methodsFor: '*Morphic' 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: '*Morphic' 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: '*Morphic' 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: '*Morphic' stamp: 'JuanVuletich 11/1/2010 15:18'! currentWorld "Answer a morphic world that is the current UI focus." ^UIManager default currentWorld! ! !Object methodsFor: '*Morphic' stamp: 'BenjaminVanRyseghem 10/7/2011 21:36'! dragPassengersFor: item inMorph: dragSource ^ { item }! ! !Object methodsFor: '*Morphic' 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: '*Morphic' stamp: 'AlainPlantec 12/19/2009 23:13'! hasModelYellowButtonMenuItems ^Morph cmdGesturesEnabled! ! !Object methodsFor: '*Morphic' stamp: 'dgd 9/25/2004 23:17'! iconOrThumbnailOfSize: aNumberOrPoint "Answer an appropiate form to represent the receiver" ^ nil! ! !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: '*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: '*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: '*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: '*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: '*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: '*NativeBoost-core' stamp: 'JavierPimas 11/17/2011 11:12'! nbCallingConvention ^#cdecl ! ! !Object methodsFor: '*NativeBoost-core' stamp: 'IgorStasenko 11/22/2012 14:25'! nbCallout ^ NBFFICalloutAPI inContext: thisContext sender! ! !Object methodsFor: '*NativeBoost-core' stamp: 'IgorStasenko 11/22/2012 14:25'! nbCalloutIn: aContext ^ NBFFICalloutAPI inContext: aContext! ! !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: '*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: '*Nautilus' stamp: 'BenjaminVanRyseghem 1/2/2013 12:00'! nautilusIcon ^ self nautilusIconClass iconNamed: #blank! ! !Object methodsFor: '*Nautilus' stamp: 'BenjaminVanRyseghem 1/2/2013 11:57'! nautilusIconClass ^ NautilusIcons! ! !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: '*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: '*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: '*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: '*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: '*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: '*Polymorph-TaskbarIcons'! taskbarIcon "Answer the icon for the receiver in a task bar or nil for the default." ^self class taskbarIcon! ! !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: '*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: '*Ring-Core-Kernel' stamp: 'StephaneDucasse 7/16/2011 22:53'! isRingObject ^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: '*Spec-Core'! asValueHolder ^ NewValueHolder contents: self! ! !Object methodsFor: '*Spec-Core' stamp: 'BenjaminVanRyseghem 6/18/2012 05:26'! isSpecLayout ^ false! ! !Object methodsFor: '*Spec-Tools' stamp: 'BenjaminVanRyseghem 10/3/2012 13:57'! displaySubObjectAt: index ^ self class allInstVarNames at: index! ! !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: '*System-Settings-Browser' stamp: 'alain.plantec 3/24/2009 23:21'! settingFixedDomainValueNodeFrom: aSettingNode ^ aSettingNode fixedDomainValueNodeForObject: self! ! !Object methodsFor: '*System-Settings-Browser' stamp: 'alain.plantec 3/19/2009 09:50'! settingStoreOn: aStream ^ self storeOn: aStream! ! !Object methodsFor: '*System-Support' stamp: 'MarcusDenker 7/12/2012 17:58'! systemNavigation ^ SystemNavigation new! ! !Object methodsFor: '*Tools-Base' stamp: 'MarianoMartinezPeck 4/15/2011 17:12'! 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" ^ UITheme current windowColorFor: self! ! !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: '*Tools-Base' stamp: 'sw 10/19/1999 14:39'! updateListsAndCodeIn: aWindow self canDiscardEdits ifFalse: [^ self]. aWindow updatablePanes do: [:aPane | aPane verifyContents]! ! !Object methodsFor: '*Tools-Browser' stamp: 'BenjaminVanRyseghem 2/8/2012 17:10'! browse ^ self systemNavigation browseClass: self class! ! !Object methodsFor: '*Tools-Browser' stamp: 'BenjaminVanRyseghem 1/7/2012 18:04'! browseHierarchy self systemNavigation browseHierarchy: self class! ! !Object methodsFor: '*Tools-Explorer' stamp: 'sma 11/12/2000 11:43'! asExplorerString ^ self printString! ! !Object methodsFor: '*Tools-Explorer' stamp: 'yo 8/27/2008 23:16'! customizeExplorerContents ^ false. ! ! !Object methodsFor: '*Tools-Explorer' stamp: 'IgorStasenko 1/22/2012 14:38'! explore ^Smalltalk tools objectExplorer openOn: self! ! !Object methodsFor: '*Tools-Explorer' stamp: 'md 8/13/2008 21:39'! hasContentsInExplorer ^self basicSize > 0 or: [self class allInstVarNames notEmpty] ! ! !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: '*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: '*Tools-Inspector' stamp: 'IgorStasenko 1/22/2012 14:35'! basicInspect "Create and schedule an Inspector in which the user can examine the receiver's variables. This method should not be overriden." ^Smalltalk tools basicInspector openOn: self! ! !Object methodsFor: '*Tools-Inspector'! defaultLabelForInspector "Answer the default label to be used for an Inspector window on the receiver." ^ self class name! ! !Object methodsFor: '*Tools-Inspector' stamp: 'SeanDeNigris 1/23/2013 22:36'! doExpiredInspectCount Halt disableHaltOnce. "self removeHaltCount." self inspect! ! !Object methodsFor: '*Tools-Inspector' stamp: 'CamilloBruni 9/21/2012 13:53'! inspect "Create and schedule an Inspector in which the user can examine the receiver's variables." ^ Smalltalk tools inspect: self! ! !Object methodsFor: '*Tools-Inspector' stamp: 'SeanDeNigris 1/23/2013 22:45'! inspectOnCount: int Halt isHaltOnceEnabled ifTrue: [ Halt isCounting ifTrue: [ Halt callsUntilHaltOnCount: Halt callsUntilHaltOnCount - 1. Halt callsUntilHaltOnCount = 0 ifTrue: [self doExpiredInspectCount]] ifFalse: [ int = 1 ifTrue: [self doExpiredInspectCount] ifFalse: [Halt callsUntilHaltOnCount: int - 1]]]! ! !Object methodsFor: '*Tools-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: '*Tools-Inspector' stamp: 'SeanDeNigris 1/23/2013 22:37'! inspectUntilCount: int ^ Halt isHaltOnceEnabled ifTrue: [ Halt isCounting ifTrue: [ Halt callsUntilHaltOnCount: Halt callsUntilHaltOnCount - 1. Halt callsUntilHaltOnCount > 0 ifTrue: [self inspect] ifFalse: [ Halt disableHaltOnce ] ] ifFalse: [ int = 1 ifTrue: [self doExpiredInspectCount] ifFalse: [ Halt callsUntilHaltOnCount: int - 1. self inspect]]]! ! !Object methodsFor: '*Tools-Inspector' stamp: 'IgorStasenko 4/15/2011 17:30'! inspectWithLabel: aLabel "Create and schedule an Inspector in which the user can examine the receiver's variables." ^Smalltalk tools inspect: self label: aLabel! ! !Object methodsFor: '*Tools-Inspector' stamp: 'IgorStasenko 4/26/2011 16:58'! 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 inspector! ! !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: '*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: '*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: '*deprecated20' stamp: 'MarcusDenker 5/12/2012 01:11'! flash self deprecated: 'only makes sense on Morph' on: '12 May 2012' in: 'Pharo 2.0' "Do nothing." ! ! !Object methodsFor: '*metacello-core' stamp: 'dkh 8/13/2009 10:37'! metacelloIntegerLessThanSelf: anInteger ^self error: 'Invalid Metacello verson component - should be String or Integer.'! ! !Object methodsFor: '*metacello-core' stamp: 'dkh 8/13/2009 11:22'! metacelloStringLessThanSelf: anInteger ^self error: 'Invalid Metacello verson component - should be String or Integer.'! ! !Object methodsFor: '*metacello-core' stamp: 'dkh 8/13/2009 10:20'! metacelloVersionComponentLessThan: aMetacelloVersonComponent ^self error: 'Invalid Metacello verson component - should be String or Integer.'! ! !Object methodsFor: '*necompletion-extensions' stamp: 'EstebanLorenzano 4/11/2012 15:47'! isCodeCompletionAllowed ^false! ! !Object methodsFor: '*tools-debugger' 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: '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: 'accessing'! at: index modify: aBlock "Replace the element of the collection with itself transformed by the block" ^ self at: index put: (aBlock value: (self at: index))! ! !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: 'accessing'! 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: 'accessing'! 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: 'accessing'! 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: 'accessing' 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: 'accessing' stamp: 'md 10/7/2004 15:43'! ifNil: nilBlock ifNotNilDo: aBlock "Evaluate aBlock with the receiver as its argument." ^ aBlock value: self ! ! !Object methodsFor: 'accessing' stamp: 'di 11/8/2000 21:04'! ifNotNilDo: aBlock "Evaluate the given block with the receiver as its argument." ^ aBlock value: self ! ! !Object methodsFor: 'accessing' stamp: 'md 10/7/2004 15:43'! ifNotNilDo: aBlock ifNil: nilBlock "Evaluate aBlock with the receiver as its argument." ^ aBlock value: self ! ! !Object methodsFor: 'accessing' stamp: 'ajh 1/21/2003 12:59'! in: aBlock "Evaluate the given block with the receiver as its argument." ^ aBlock value: self ! ! !Object methodsFor: 'accessing' stamp: 'damiencassou 5/30/2008 10:56'! readFromString: aString "Create an object based on the contents of aString." ^ self readFrom: aString readStream! ! !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: 'accessing' stamp: 'md 5/16/2006 12:34'! yourself "Answer self." ^self! ! !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: 'binding'! bindingOf: aString ^nil! ! !Object methodsFor: 'casing'! caseOf: aBlockAssociationCollection "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: 'casing'! caseOf: aBlockAssociationCollection otherwise: aBlock "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: 'class membership'! class "Primitive. Answer the object which is the receiver's class. Essential. See Object documentation whatIsAPrimitive." self primitiveFailed! ! !Object methodsFor: 'class membership' stamp: 'EstebanLorenzano 7/20/2012 18:16'! isComposedBy: aTrait "Answers if this object includes trait aTrait into its composition" ^self class isComposedBy: aTrait! ! !Object methodsFor: 'class membership'! 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: 'class membership'! isMemberOf: aClass "Answer whether the receiver is an instance of the class, aClass." ^self class == aClass! ! !Object methodsFor: 'class membership'! respondsTo: aSymbol "Answer whether the method dictionary of the receiver's class contains aSymbol as a message selector." ^self class canUnderstand: aSymbol! ! !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: 'comparing' stamp: 'ajh 2/2/2002 15:02'! literalEqual: other ^ self class == other class and: [self = other]! ! !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: 'comparing'! ~= anObject "Answer whether the receiver and the argument do not represent the same object." ^self = anObject == false! ! !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: '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: '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: '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: '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: '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: 'converting' stamp: 'rw 4/27/2002 07:48'! asActionSequence ^WeakActionSequence 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: '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: '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: 'converting' stamp: 'MarianoMartinezPeck 8/24/2012 15:58'! asString "Answer a string that represents the receiver." ^ self printString ! ! !Object methodsFor: 'converting' stamp: 'MarcusDenker 7/20/2012 14:59'! asStringOrText "Answer a string that represents the receiver." ^ self asString ! ! !Object methodsFor: 'converting'! as: aSimilarClass "Create an object of class aSimilarClass that has similar contents to the receiver." ^ aSimilarClass newFrom: self! ! !Object methodsFor: 'converting' stamp: 'RAA 8/2/1999 12:41'! complexContents ^self! ! !Object methodsFor: 'converting' 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: 'converting' stamp: 'ajh 7/6/2003 20:40'! mustBeBooleanIn: context "context is the where the non-boolean error occurred. Rewind context to before jump then raise error." | proceedValue | context skipBackBeforeJump. proceedValue := NonBooleanReceiver new object: self; signal: 'proceed for truth.'. ^ proceedValue ~~ false! ! !Object methodsFor: 'converting' stamp: 'RAA 3/31/1999 12:13'! withoutListWrapper ^self! ! !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: '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: '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: '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: '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: '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: '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: 'copying' stamp: 'MarianoMartinezPeck 6/5/2012 22:41'! 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 index sub subAss new sup has mine | deepCopier references at: self ifPresent: [:newer | ^ newer]. "already did him" class := self class. class isMeta ifTrue: [^ self]. "a class" new := self shallowCopy. deepCopier references at: self put: new. "remember" (class isVariable and: [class isPointers]) ifTrue: [index := self basicSize. [index > 0] whileTrue: [sub := self basicAt: index. (subAss := deepCopier references associationAt: sub ifAbsent: [nil]) ifNil: [new basicAt: index put: (sub veryDeepCopyWith: deepCopier)] ifNotNil: [new basicAt: index put: subAss value]. index := index - 1]]. "Ask each superclass if it wants to share (weak copy) any inst vars" new veryDeepInner: deepCopier. "does super a lot" "other superclasses want all inst vars deep copied" sup := class. index := class instSize. [has := sup compiledMethodAt: #veryDeepInner: ifAbsent: [nil]. has := has ifNil: [ false ] ifNotNil: [ true ]. mine := sup instVarNames. has ifTrue: [index := index - mine size] "skip inst vars" ifFalse: [1 to: mine size do: [:xx | sub := self instVarAt: index. (subAss := deepCopier references associationAt: sub ifAbsent: [nil]) "use association, not value, so nil is an exceptional value" ifNil: [new instVarAt: index put: (sub veryDeepCopyWith: deepCopier)] ifNotNil: [new instVarAt: index put: subAss value]. index := index - 1]]. (sup := sup superclass) == nil] whileFalse. (new isKindOf: HashedCollection) ifTrue: [ new rehash]. "force Sets and Dictionaries to rehash" ^ new ! ! !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: '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: 'dependents access' 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: 'dependents access' stamp: 'sma 2/29/2000 19:53'! breakDependents "Remove all of the receiver's dependents." self myDependents: nil! ! !Object methodsFor: 'dependents access' 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: 'dependents access' 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: 'dependents access' stamp: 'sma 2/29/2000 19:55'! myDependents "Private. Answer a list of all the receiver's dependents." ^ DependentsFields at: self ifAbsent: []! ! !Object methodsFor: 'dependents access' 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: 'dependents access'! 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: 'dependents access' 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: 'drag and drop'! acceptDroppingMorph: transferMorph event: evt inMorph: dstListMorph ^false.! ! !Object methodsFor: 'drag and drop'! dragPassengerFor: item inMorph: dragSource ^item! ! !Object methodsFor: 'drag and drop' stamp: 'panda 4/28/2000 16:11'! dragTransferType ^nil! ! !Object methodsFor: 'drag and drop'! dragTransferTypeForMorph: dragSource ^nil! ! !Object methodsFor: 'drag and drop'! wantsDroppedMorph: aMorph event: anEvent inMorph: destinationLM ^false ! ! !Object methodsFor: 'error handling' 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: 'error handling' 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: 'error handling' stamp: 'jannik.laval 5/2/2010 16:58'! assert: aBlock description: aString "Throw an assertion error if aBlock does not evaluates to true." aBlock value ifFalse: [AssertionFailure signal: aString ]! ! !Object methodsFor: 'error handling' stamp: 'jcg 8/10/2008 21:58'! caseError "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: '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: 'error handling' stamp: 'MarcusDenker 3/3/2012 23:55'! deprecated: anExplanationString "this is not itself deprecated, but a compatibility method for old-style deprecation" ^ self deprecated: anExplanationString on: 'unknown' in: 'unkown'! ! !Object methodsFor: 'error handling' 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: 'error handling' 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: 'error handling' stamp: 'TRee 11/4/2003 16:47'! dpsTrace: reportObject Transcript myDependents isNil ifTrue: [^self]. self dpsTrace: reportObject levels: 1 withContext: thisContext " nil dpsTrace: 'sludder'. "! ! !Object methodsFor: 'error handling' stamp: 'TRee 11/4/2003 16:49'! dpsTrace: reportObject levels: anInt self dpsTrace: reportObject levels: anInt withContext: thisContext "(1 to: 3) do: [:int | nil dpsTrace: int levels: 5.]"! ! !Object methodsFor: 'error handling' stamp: 'lr 3/14/2010 21:13'! dpsTrace: reportObject levels: anInt withContext: currentContext | reportString context displayCount | reportString := (reportObject respondsTo: #asString) ifTrue: [ reportObject asString ] ifFalse: [ reportObject printString ]. (Smalltalk globals at: #Decompiler ifAbsent: [ nil ]) ifNil: [ Transcript cr; show: reportString ] ifNotNil: [ context := currentContext. displayCount := anInt > 1. 1 to: anInt do: [ :count | Transcript cr. displayCount ifTrue: [ Transcript show: count printString , ': ' ]. reportString notNil ifTrue: [ Transcript show: context home class name , '/' , context sender selector , ' (' , reportString , ')'. context := context sender. reportString := nil ] ifFalse: [ (context notNil and: [ (context := context sender) notNil ]) ifTrue: [ Transcript show: context receiver class name , '/' , context selector ] ] ] "Transcript cr" ]! ! !Object methodsFor: 'error handling' stamp: 'md 8/2/2005 22:17'! error "Throw a generic Error exception." ^self error: 'Error!!'.! ! !Object methodsFor: 'error handling' stamp: 'tfei 4/12/1999 12:55'! error: aString "Throw a generic Error exception." ^Error new signal: aString! ! !Object methodsFor: 'error handling' stamp: 'al 9/16/2005 14:12'! explicitRequirement self error: 'Explicitly required method'! ! !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: '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: '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: 'error handling'! 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: 'error handling' 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: 'error handling' 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: 'error handling' 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: 'error handling' stamp: 'al 9/16/2005 14:12'! requirement self error: 'Implicitly required method'! ! !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: '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: '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: '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: 'evaluating' stamp: 'MarianoMartinezPeck 8/24/2012 15:58'! value ^self! ! !Object methodsFor: 'evaluating' stamp: 'reThink 2/18/2001 15:23'! valueWithArguments: aSequenceOfArguments ^self! ! !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: '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-accessing' stamp: 'reThink 2/18/2001 14:43'! actionMap ^EventManager actionMapFor: self! ! !Object methodsFor: 'events-accessing' stamp: 'rw 4/27/2002 08:35'! actionSequenceForEvent: anEventSelector ^(self actionMap at: anEventSelector asSymbol ifAbsent: [^WeakActionSequence new]) asActionSequence! ! !Object methodsFor: 'events-accessing' stamp: 'SqR 6/28/2001 13:19'! actionsDo: aBlock self actionMap do: aBlock! ! !Object methodsFor: 'events-accessing' stamp: 'rw 2/10/2002 13:05'! createActionMap ^IdentityDictionary new! ! !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: '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: 'events-accessing' stamp: 'reThink 2/18/2001 15:29'! setActionSequence: actionSequence forEvent: anEventSelector | action | action := actionSequence asMinimalRepresentation. action == nil ifTrue: [self removeActionsForEvent: anEventSelector] ifFalse: [self updateableActionMap at: anEventSelector asSymbol put: action]! ! !Object methodsFor: 'events-accessing' stamp: 'reThink 2/25/2001 08:50'! updateableActionMap ^EventManager updateableActionMapFor: 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: '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: '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: '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: 'events-removing' stamp: 'reThink 2/18/2001 15:33'! releaseActionMap EventManager releaseActionMapFor: self! ! !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: 'events-removing' stamp: 'nk 8/25/2003 21:46'! removeActionsSatisfying: aBlock self actionMap keys do: [:eachEventSelector | self removeActionsSatisfying: aBlock forEvent: eachEventSelector ]! ! !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: '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: 'events-removing' stamp: 'reThink 2/18/2001 15:36'! removeActionsWithReceiver: anObject forEvent: anEventSelector self removeActionsSatisfying: [:anAction | anAction receiver == anObject] forEvent: anEventSelector! ! !Object methodsFor: 'events-removing' stamp: 'reThink 2/18/2001 15:31'! removeAction: anAction forEvent: anEventSelector self removeActionsSatisfying: [:action | action = anAction] forEvent: anEventSelector! ! !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: 'events-triggering' stamp: 'reThink 2/18/2001 17:09'! triggerEvent: anEventSelector ifNotHandled: anExceptionBlock "Evaluate all actions registered for . Return the value of the last registered action." ^(self actionForEvent: anEventSelector ifAbsent: [^anExceptionBlock value]) value ! ! !Object methodsFor: 'events-triggering' stamp: 'reThink 2/18/2001 15:21'! triggerEvent: anEventSelector withArguments: anArgumentList ^(self actionForEvent: anEventSelector) valueWithArguments: anArgumentList! ! !Object methodsFor: 'events-triggering' stamp: 'reThink 2/18/2001 15:21'! triggerEvent: anEventSelector withArguments: anArgumentList ifNotHandled: anExceptionBlock ^(self actionForEvent: anEventSelector ifAbsent: [^anExceptionBlock value]) valueWithArguments: anArgumentList! ! !Object methodsFor: 'events-triggering' stamp: 'reThink 2/18/2001 14:59'! triggerEvent: anEventSelector with: anObject ^self triggerEvent: anEventSelector withArguments: (Array with: anObject)! ! !Object methodsFor: 'events-triggering' stamp: 'reThink 2/18/2001 14:59'! triggerEvent: anEventSelector with: anObject ifNotHandled: anExceptionBlock ^self triggerEvent: anEventSelector withArguments: (Array with: anObject) ifNotHandled: anExceptionBlock! ! !Object methodsFor: 'filter streaming' stamp: 'MPW 1/1/1901 00:49'! putOn:aStream ^aStream nextPut:self. ! ! !Object methodsFor: 'finalization' stamp: 'ar 3/21/98 16:26'! actAsExecutor "Prepare the receiver to act as executor for any resources associated with it" self breakDependents! ! !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: 'finalization' stamp: 'ar 5/19/2003 20:10'! finalizationRegistry "Answer the finalization registry associated with the receiver." ^WeakRegistry default! ! !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: 'finalization' stamp: 'Igor.Stasenko 5/25/2010 04:59'! hasMultipleExecutors "All objects, except ObjectFinalizerCollection instances should answer false to this message" ^ false! ! !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: '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: 'flagging' stamp: 'sw 8/4/97 16:49'! isThisEverCalled ^ self isThisEverCalled: thisContext sender printString! ! !Object methodsFor: 'flagging' stamp: 'CamilloBruni 8/1/2012 16:10'! isThisEverCalled: msg "Send this message, with some useful printable argument, from methods or branches of methods which you believe are never reached." Halt halt: 'This is indeed called: ', msg printString! ! !Object methodsFor: 'flagging' stamp: 'jm 3/18/98 17:23'! logEntry Transcript show: 'Entered ', thisContext sender printString; cr. ! ! !Object methodsFor: 'flagging' stamp: 'jm 3/18/98 17:23'! logExecution Transcript show: 'Executing ', thisContext sender printString; cr. ! ! !Object methodsFor: 'flagging' stamp: 'jm 3/18/98 17:22'! logExit Transcript show: 'Exited ', thisContext sender printString; cr. ! ! !Object methodsFor: 'logging-Deprecated' stamp: 'StephaneDucasse 11/7/2011 22:43'! crLog self crTrace: self printString! ! !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: '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: 'logging-Deprecated' stamp: 'StephaneDucasse 11/5/2011 10:49'! logCr self logCr: self printString! ! !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: '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: 'macpal' stamp: 'sw 1/28/1999 17:31'! contentsChanged self changed: #contents! ! !Object methodsFor: 'macpal' stamp: 'sw 5/22/2001 18:31'! refusesToAcceptCode "Answer whether the receiver is a code-bearing instrument which at the moment refuses to allow its contents to be submitted" ^ false ! ! !Object methodsFor: 'memory usage' stamp: 'MarianoMartinezPeck 1/9/2012 22:29'! 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) ]. contentBytes > 255 ifTrue: [ contentBytes := contentBytes + (2 * Smalltalk wordSize) ] ifFalse: [ self class isCompact ifFalse: [ contentBytes := contentBytes + Smalltalk wordSize] ]. ^contentBytes! ! !Object methodsFor: 'message handling' stamp: 'di 3/26/1999 07:52'! 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: 'message handling' 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: 'message handling' stamp: 'di 3/26/1999 07:55'! 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: 'message handling' stamp: 'ar 4/25/2005 13:35'! 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: 'message handling' 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: 'message handling' stamp: 'di 3/26/1999 07:52'! 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: 'message handling' stamp: 'di 3/26/1999 07:52'! 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: 'message handling' stamp: 'di 3/26/1999 07:51'! 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: '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: 'printing'! isLiteral "Answer whether the receiver has a literal text form recognized by the compiler." ^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: '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: '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: '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: 'printing' 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: '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: '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: '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: 'printing' stamp: 'eem 6/2/2008 11:47'! printWithClosureAnalysisOn: 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: 'printing'! 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: '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: 'self evaluating' stamp: 'sd 7/31/2005 21:47'! isSelfEvaluating ^ self isLiteral! ! !Object methodsFor: 'system primitives' 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: 'system primitives' stamp: 'zz 3/3/2004 23:53'! 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: 'system primitives' 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: 'system primitives'! 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: 'system primitives'! 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: 'system primitives' 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: 'system primitives' 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: 'system primitives' 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: 'system primitives'! someObject "Primitive. Answer the first object in the enumeration of all objects." self primitiveFailed.! ! !Object methodsFor: 'testing' stamp: 'sw 1/12/98 18:09'! haltIfNil! ! !Object methodsFor: 'testing' stamp: 'md 1/20/2006 17:09'! hasLiteralSuchThat: testBlock "This is the end of the imbedded structure path so return false." ^ false! ! !Object methodsFor: 'testing' stamp: 'MarianoMartinezPeck 8/24/2012 15:29'! is: aSymbol "A means for cleanly replacing all isXXX like methods. Please use judiciously!! Suggested by Igor Stasenko at http://lists.squeakfoundation.org/pipermail/squeak-dev/2009-June/136793.html. all isXXX should be converted following the pattern ColorForm>>isColorForm ^ true Object>>isColorForm ^ false is: aSymbol ^ aSymbol = #ColorForm or: [ super is: aSymbol ]" ^false ! ! !Object methodsFor: 'testing' stamp: 'eem 5/8/2008 11:13'! isArray ^false! ! !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: 'testing' stamp: 'ajh 1/21/2003 13:15'! isBlock ^ false! ! !Object methodsFor: 'testing' stamp: 'yo 8/28/2002 13:41'! isCharacter ^ false. ! ! !Object methodsFor: 'testing' stamp: 'eem 5/23/2008 13:47'! isClosure ^false! ! !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: 'testing'! isColor "Answer true if receiver is a Color. False by default." ^ false ! ! !Object methodsFor: 'testing' stamp: 'nk 4/17/2004 19:43'! isColorForm ^false! ! !Object methodsFor: 'testing' stamp: 'md 11/21/2003 12:14'! isCompiledMethod ^ false! ! !Object methodsFor: 'testing' stamp: 'mk 10/27/2003 17:33'! isComplex "Answer true if receiver is a Complex number. False by default." ^ false ! ! !Object methodsFor: 'testing' stamp: 'eem 11/26/2008 20:22'! isContext ^false! ! !Object methodsFor: 'testing' stamp: 'md 8/11/2005 16:45'! isDictionary ^false! ! !Object methodsFor: 'testing' stamp: 'di 11/9/1998 09:38'! isFloat "Overridden to return true in Float, natch" ^ false! ! !Object methodsFor: 'testing' stamp: 'ar 10/30/2000 23:22'! isForm ^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: 'rhi 8/14/2003 08:51'! isHeap ^ false! ! !Object methodsFor: 'testing'! isInteger "Overridden to return true in Integer." ^ false! ! !Object methodsFor: 'testing' stamp: 'rhi 8/12/2003 09:52'! isInterval ^ false! ! !Object methodsFor: 'testing' stamp: 'nk 4/25/2002 08:04'! isMessageSend ^false ! ! !Object methodsFor: 'testing' stamp: 'md 2/19/2006 11:24'! isMethodProperties ^false! ! !Object methodsFor: 'testing'! isMorph ^ false! ! !Object methodsFor: 'testing' stamp: 'ar 9/13/2000 15:37'! isMorphicEvent ^false! ! !Object methodsFor: 'testing' stamp: 'gm 2/22/2003 12:56'! isMorphicModel "Return true if the receiver is a morphic model" ^false ! ! !Object methodsFor: 'testing'! isNumber "Overridden to return true in Number, natch" ^ false! ! !Object methodsFor: 'testing' stamp: 'di 11/6/1998 08:04'! isPoint "Overridden to return true in Point." ^ false! ! !Object methodsFor: 'testing' stamp: 'md 10/2/2005 21:52'! isRectangle ^false! ! !Object methodsFor: 'testing' stamp: 'ar 12/23/1999 15:43'! isStream "Return true if the receiver responds to the stream protocol" ^false ! ! !Object methodsFor: 'testing' stamp: 'sma 6/15/2000 15:48'! isString "Overridden to return true in String, natch" ^ false! ! !Object methodsFor: 'testing' stamp: 'md 4/30/2003 15:30'! isSymbol ^ false ! ! !Object methodsFor: 'testing' stamp: 'jam 3/9/2003 15:10'! isSystemWindow "answer whatever the receiver is a SystemWindow" ^ false! ! !Object methodsFor: 'testing'! isText ^ false! ! !Object methodsFor: 'testing' stamp: 'adrian-lienhard 6/21/2009 23:52'! isTrait ^false! ! !Object methodsFor: 'testing' stamp: 'ar 8/14/2001 23:19'! isVariableBinding "Return true if I represent a literal variable binding" ^false ! ! !Object methodsFor: 'testing' 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: 'testing'! notNil "Coerces nil to false and everything else to true." ^true! ! !Object methodsFor: 'testing' 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: 'testing' 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: 'testing' stamp: 'ul 11/23/2010 13:28'! shouldBePrintedAsLiteral ^self isLiteral! ! !Object methodsFor: 'testing' stamp: 'sw 10/20/1999 14:52'! stepAt: millisecondClockValue in: aWindow ^ self stepIn: aWindow! ! !Object methodsFor: 'testing' stamp: 'sw 10/19/1999 08:16'! stepIn: aWindow ^ self step! ! !Object methodsFor: 'testing' stamp: 'sw 10/19/1999 08:21'! stepTime ^ 1000 "milliseconds -- default backstop for objects serving as models of system windows"! ! !Object methodsFor: 'testing' stamp: 'sw 10/19/1999 08:22'! stepTimeIn: aSystemWindow ^ 1000 "milliseconds -- default backstop for objects serving as models of system windows"! ! !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: '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: 'testing' stamp: 'sw 10/19/1999 08:26'! wantsStepsIn: aSystemWindow ^ self wantsSteps! ! !Object methodsFor: 'tracing' stamp: 'StephaneDucasse 11/6/2011 23:56'! crTrace self crTrace: self printString! ! !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: 'tracing' stamp: 'StephaneDucasse 11/6/2011 23:58'! trace self trace: self printString! ! !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: 'tracing' stamp: 'StephaneDucasse 11/6/2011 23:56'! traceCr self traceCr: self printString! ! !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: 'updating'! changed "Receiver changed in a general way; inform all the dependents by sending each dependent an update: message." self changed: self! ! !Object methodsFor: 'updating'! 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: '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: 'updating' stamp: 'sw 10/31/1999 00:15'! noteSelectionIndex: anInteger for: aSymbol "backstop"! ! !Object methodsFor: 'updating'! okToChange "Allows a controller to ask this of any model" ^ true! ! !Object methodsFor: 'updating'! 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: '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: '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: '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: '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: 'user interface'! modelSleep "A window with me as model is being exited or collapsed or closed. Default response is no-op" ! ! !Object methodsFor: 'user interface'! modelWakeUp "A window with me as model is being entered or expanded. Default response is no-op" ! ! !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: 'private'! errorImproperStore "Create an error notification that an improper store was attempted." self error: 'Improper store into indexable object'! ! !Object methodsFor: 'private'! 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: '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: '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: '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: 'private'! 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 class instanceVariableNames: ''! !Object class methodsFor: '*Compiler-Kernel' stamp: 'jb 7/1/2011 10:52'! readFrom: textStringOrStream "Create an object based on the contents of textStringOrStream." | object | (self class evaluatorClass couldEvaluate: textStringOrStream) ifFalse: [^ self error: 'expected String, Stream, or Text']. object := self class evaluatorClass evaluate: textStringOrStream. (object isKindOf: self) ifFalse: [self error: self name, ' expected']. ^object! ! !Object class methodsFor: '*Polymorph-TaskbarIcons'! taskbarIcon "Answer the icon for an instance of the receiver in a task bar or nil for the default." ^nil ! ! !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: '*System-FileRegistry' stamp: 'CamilloBruni 2/3/2013 17:27'! fileReaderServicesForDirectory: aFileDirectory "Backstop" ^#()! ! !Object class methodsFor: '*System-FileRegistry' stamp: 'CamilloBruni 2/3/2013 17:21'! fileReaderServicesForFile: fullName suffix: suffix "Backstop" ^#()! ! !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: '*Tools-FileList' stamp: 'md 2/15/2006 17:20'! services "Backstop" ^#()! ! !Object class methodsFor: '*metacello-mc' stamp: 'dkh 11/03/2009 11:05'! 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 11/3/2009 10:12'! 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: 'class initialization' stamp: 'ar 2/11/2001 02:00'! flushDependents DependentsFields keysAndValuesDo:[:key :dep| key ifNotNil:[key removeDependent: nil]. ]. DependentsFields finalizeValues.! ! !Object class methodsFor: 'class initialization' stamp: 'rw 2/10/2002 13:09'! flushEvents "Object flushEvents" EventManager flushEvents. ! ! !Object class methodsFor: 'class initialization' stamp: 'MarianoMartinezPeck 8/24/2012 15:31'! initialize "Object initialize" DependentsFields ifNil:[self initializeDependentsFields].! ! !Object class methodsFor: 'class initialization' stamp: 'ar 2/11/2001 01:41'! initializeDependentsFields "Object initialize" DependentsFields := WeakIdentityKeyDictionary new. ! ! !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: 'documentation'! 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'! 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: '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! ! Model subclass: #ObjectExplorer instanceVariableNames: 'rootObject inspector monitorList currentSelection' classVariableNames: 'ShowIcons' poolDictionaries: '' category: 'Tools-Explorer'! !ObjectExplorer commentStamp: '' prior: 0! ObjectExplorer provides a hierarchical alternative to #inspect. Simply evaluate an expression like: World explore and enjoy.! !ObjectExplorer methodsFor: '*Polymorph-TaskbarIcons' stamp: 'FernandoOlivero 4/12/2011 10:11'! taskbarIcon ^ self theme smallInspectItIcon ! ! !ObjectExplorer methodsFor: '*Shout-Parsing' stamp: 'SeanDeNigris 6/22/2012 18:35'! shoutParser: anSHParserST80 anSHParserST80 isMethod: false.! ! !ObjectExplorer methodsFor: '*Shout-Styling' stamp: 'SeanDeNigris 6/22/2012 19:07'! shoutAboutToStyle: aPluggableShoutMorphOrView aPluggableShoutMorphOrView classOrMetaClass: self object class. ^ true! ! !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: '*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: '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: '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: '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:52'! explorerFor: anObject ^UIManager default explorer: self for: anObject withLabel: (anObject printStringLimitedTo: 32)! ! !ObjectExplorer methodsFor: 'accessing' stamp: 'nk 7/24/2003 09:16'! getList ^Array with: (ObjectExplorerWrapper with: rootObject name: 'root' model: self parent: nil) ! ! !ObjectExplorer methodsFor: 'accessing' stamp: 'marcus.denker 11/10/2008 10:04'! object ^currentSelection ifNotNil: [ :cs | cs withoutListWrapper ]! ! !ObjectExplorer methodsFor: 'accessing' stamp: 'nk 7/24/2003 10:02'! parentObject currentSelection ifNil: [ ^nil ]. currentSelection parent ifNil: [ ^rootObject ]. ^currentSelection parent withoutListWrapper! ! !ObjectExplorer methodsFor: 'accessing' stamp: 'JuanVuletich 10/26/2010 14:27'! rootObject: anObject rootObject := anObject! ! !ObjectExplorer methodsFor: 'accessing' stamp: 'marcus.denker 11/10/2008 10:04'! selector ^currentSelection ifNotNil: [ :cs | cs selector ]! ! !ObjectExplorer methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 9/2/2012 17:05'! exploreStrongPointers "Open a StrongPointerExplorer on the current selection" Smalltalk tools strongPointerExplorer openOn: self object! ! !ObjectExplorer methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 3/26/2011 21:57'! getCurrentSelection ^currentSelection! ! !ObjectExplorer methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 3/26/2011 21:57'! noteNewSelection: x currentSelection := x. self changed: #getCurrentSelection. currentSelection ifNil: [^self]. currentSelection sendSettingMessageTo: self. ! ! !ObjectExplorer methodsFor: 'error handling' stamp: 'nk 7/24/2003 09:29'! doesNotUnderstand: aMessage inspector ifNotNil: [ (inspector respondsTo: aMessage selector) ifTrue: [ ^inspector perform: aMessage selector withArguments: aMessage arguments ]]. ^super doesNotUnderstand: aMessage! ! !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: '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: 'menus' stamp: 'IgorStasenko 1/22/2012 14:42'! explorePointers "Open a PointerExplorer on the current selection" Smalltalk tools pointerExplorer openOn: self object! ! !ObjectExplorer methodsFor: 'menus' stamp: 'MarcusDenker 5/7/2012 15:13'! explorerKey: aChar from: view "Similar to #genericMenu:..." | insideObject parentObject | currentSelection ifNotNil: [ insideObject := self object. parentObject := self parentObject. inspector ifNil: [inspector := Smalltalk tools inspector new]. inspector inspect: parentObject; object: insideObject. aChar == $i ifTrue: [^ self inspectSelection]. aChar == $I ifTrue: [^ self exploreSelection]. aChar == $b ifTrue: [^ inspector browseMethodFull]. aChar == $h ifTrue: [^ inspector classHierarchy]. aChar == $c ifTrue: [^ inspector copyName]. aChar == $N ifTrue: [^ inspector browseClassRefs]]. ^ self arrowKey: aChar from: view! ! !ObjectExplorer methodsFor: 'menus' stamp: 'nk 7/24/2003 10:26'! exploreSelection "Open an ObjectExplorer on the current selection" self object explore! ! !ObjectExplorer methodsFor: 'menus' stamp: 'IgorStasenko 9/2/2012 17:06'! genericMenu: aMenu "Borrow a menu from my inspector" | insideObject menu parentObject | currentSelection ifNil: [menu := aMenu. menu add: '*nothing selected*' target: self selector: #yourself] ifNotNil: [insideObject := self object. parentObject := self parentObject. inspector ifNil: [inspector := Smalltalk tools inspector new]. inspector inspect: parentObject; object: insideObject. aMenu defaultTarget: inspector. inspector fieldListMenu: aMenu. aMenu items do: [:i | (#(#inspectSelection #exploreSelection #referencesToSelection #defsOfSelection #explorePointers #exploreStrongPointers) includes: i selector) ifTrue: [i target: self]]. aMenu addLine; add: 'monitor changes' target: self selector: #monitor: argument: currentSelection]. monitorList isEmptyOrNil ifFalse: [aMenu addLine; add: 'stop monitoring all' target: self selector: #stopMonitoring]. ^ aMenu! ! !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: '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: 'menus' stamp: 'RAA 9/23/1999 13:19'! selectedClass "Answer the class of the receiver's current selection" ^self doItReceiver class ! ! !ObjectExplorer methodsFor: 'monitoring' stamp: 'sd 11/20/2005 21:27'! monitorList ^monitorList ifNil: [ monitorList := WeakIdentityKeyDictionary new ].! ! !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: 'monitoring' stamp: 'nk 7/31/2004 15:01'! release self world ifNotNil: [ self world stopStepping: self selector: #step ]. super release.! ! !ObjectExplorer methodsFor: 'monitoring' stamp: 'nk 7/12/2003 17:55'! shouldGetStepsFrom: aWorld ^self monitorList notEmpty! ! !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: 'monitoring' stamp: 'sd 11/20/2005 21:27'! stopMonitoring monitorList := nil. self world stopStepping: self selector: #step! ! !ObjectExplorer methodsFor: 'monitoring' stamp: 'nk 7/31/2004 15:01'! world ^ActiveWorld! ! !ObjectExplorer methodsFor: 'updating' stamp: 'MarcusDenker 3/26/2011 21:58'! update: aSymbol aSymbol == #hierarchicalList ifTrue: [ ^self changed: #getList ]. super update: aSymbol! ! !ObjectExplorer methodsFor: 'user interface' stamp: 'JuanVuletich 10/26/2010 14:53'! explorerFor: anObject withLabel: label ^UIManager default explorer: self for: anObject withLabel: label! ! !ObjectExplorer methodsFor: 'user interface' stamp: 'RAA 6/2/2000 16:23'! initialExtent ^300@500! ! !ObjectExplorer methodsFor: 'user interface' stamp: 'eem 5/7/2008 11:17'! openExplorerFor: anObject " ObjectExplorer new openExplorerFor: Smalltalk " | win | win := (self explorerFor: anObject) openInWorld. Cursor wait showWhile: [win submorphs do: [:sm| (sm respondsTo: #expandRoots) ifTrue: [sm expandRoots]]]. ^self ! ! !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 class instanceVariableNames: ''! !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:12'! showIcons ^ ShowIcons ifNil: [ShowIcons := true]! ! !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: 'tools registry' stamp: 'IgorStasenko 2/19/2011 02:59'! registerToolsOn: registry "Add ourselves to registry. See [Smalltalk tools]" registry register: self as: #objectExplorer ! ! ListItemWrapper subclass: #ObjectExplorerWrapper instanceVariableNames: 'itemName parent' classVariableNames: '' poolDictionaries: '' category: 'Tools-Explorer'! !ObjectExplorerWrapper commentStamp: '' prior: 0! Contributed by Bob Arning as part of the ObjectExplorer package. ! !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 11:27'! hasContents ^item hasContentsInExplorer ! ! !ObjectExplorerWrapper methodsFor: 'accessing' stamp: 'IgorStasenko 4/15/2011 17:33'! icon "Answer a form to be used as icon" ^ Smalltalk tools objectExplorer showIcons ifTrue: [item iconOrThumbnailOfSize: 16] ifFalse: [nil]! ! !ObjectExplorerWrapper methodsFor: 'as yet unclassified' stamp: 'nk 7/24/2003 09:14'! parent ^parent! ! !ObjectExplorerWrapper methodsFor: 'as yet unclassified' stamp: 'nk 7/24/2003 09:14'! parent: anObject parent := anObject! ! !ObjectExplorerWrapper methodsFor: 'as yet unclassified' stamp: 'nk 7/24/2003 09:49'! selector parent ifNil: [ ^nil ]. ^(parent withoutListWrapper class allInstVarNames includes: itemName) ifTrue: [ itemName asSymbol ]! ! !ObjectExplorerWrapper methodsFor: 'as yet unclassified' stamp: 'RAA 6/21/1999 10:49'! setItem: anObject name: aString model: aModel item := anObject. model := aModel. itemName := aString.! ! !ObjectExplorerWrapper methodsFor: 'as yet unclassified' 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: '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: '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 class instanceVariableNames: ''! !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 ! ! MessageSend subclass: #ObjectFinalizer instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Finalization'! !ObjectFinalizer commentStamp: 'jcg 4/27/2010 01:01' prior: 0! 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).! ! OrderedCollection subclass: #ObjectFinalizerCollection instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Finalization'! !ObjectFinalizerCollection commentStamp: 'ul 2/26/2010 14:23' prior: 0! 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! ! TestCase subclass: #ObjectFinalizerTests instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Finalization'! !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! ! Object subclass: #ObjectStringConverter instanceVariableNames: 'objectClass regex stringTransformBlock objectTransformBlock' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !ObjectStringConverter commentStamp: 'GaryChambers 3/9/2011 13:37' prior: 0! Generic object<->string converter for use with PluggableTextFieldMorph. Optional regex matching for validation. Optional transform blocks for each conversion direction.! !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: 'gvc 7/30/2009 14:09'! objectClass: aClass "Set the class of object we are dealing with." objectClass := aClass! ! !ObjectStringConverter methodsFor: 'accessing' stamp: 'GaryChambers 3/9/2011 13:31'! objectTransformBlock ^ objectTransformBlock! ! !ObjectStringConverter methodsFor: 'accessing' stamp: 'GaryChambers 3/9/2011 13:31'! objectTransformBlock: anObject objectTransformBlock := anObject! ! !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/8/2011 11:49'! regexString: aString "Setup the regex based on the given string." self regex: aString asRegex! ! !ObjectStringConverter methodsFor: 'accessing' stamp: 'GaryChambers 3/9/2011 13:31'! stringTransformBlock ^ stringTransformBlock! ! !ObjectStringConverter methodsFor: 'accessing' stamp: 'GaryChambers 3/9/2011 13:31'! stringTransformBlock: anObject stringTransformBlock := anObject! ! !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: '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: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 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: '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: '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: 'initialize-release' stamp: 'GaryChambers 3/9/2011 13:33'! initialize "Initialize the receiver." super initialize. self objectTransformBlock: [:obj | obj]; stringTransformBlock: [:string | string]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ObjectStringConverter class instanceVariableNames: ''! !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! ! ClassTestCase subclass: #ObjectTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Objects'! !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: 'assertions-halt' stamp: 'SeanDeNigris 8/28/2011 17:23'! shouldntHaltAfter: aNumber times: aBlock self shouldntHaltWhen: [ aNumber timesRepeat: aBlock ].! ! !ObjectTest methodsFor: 'assertions-halt' stamp: 'SeanDeNigris 8/28/2011 17:18'! shouldntHaltWhen: aBlock self shouldnt: aBlock raise: Halt.! ! !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' 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: '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 ].! ! !ObjectTest methodsFor: 'tests - debugging' stamp: 'SeanDeNigris 8/29/2011 15:45'! testHaltOnce | anObject | anObject := Object new. Halt enableHaltOnce. self should: [anObject haltOnce] raise: Halt. Halt disableHaltOnce. self shouldnt: [anObject haltOnce] raise: Halt. ! ! !ObjectTest methodsFor: 'private' stamp: 'md 10/15/2004 13:45'! a self b.! ! !ObjectTest methodsFor: 'private' stamp: 'md 10/15/2004 13:46'! a1 self b1.! ! !ObjectTest methodsFor: 'private' stamp: 'md 10/15/2004 13:45'! b self haltIf: #testHaltIf.! ! !ObjectTest methodsFor: 'private' stamp: 'md 10/15/2004 13:46'! b1 self haltIf: #testasdasdfHaltIf.! ! AbstractObjectsAsMethod subclass: #ObjectsAsMethodsExample instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-ObjectsAsMethods'! !ObjectsAsMethodsExample methodsFor: 'as yet unclassified' stamp: 'ar 5/17/2003 20:16'! add: a with: b ^a + b! ! !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! ! TestCase subclass: #ObsoleteTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Classes'! !ObsoleteTest commentStamp: 'SteveFreeman 7/17/2010 11:31' prior: 0! 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 ]. ! ! OkToolbar subclass: #OkCancelToolbar instanceVariableNames: 'cancelButton cancelAction cancelled' classVariableNames: '' poolDictionaries: '' category: 'Spec-Widgets-PolyWidgets'! !OkCancelToolbar commentStamp: '' prior: 0! An OkCancelToolbar is a model for a basic Ok-Cancel toolbar! !OkCancelToolbar methodsFor: 'accessing'! cancelButton ^ cancelButton! ! !OkCancelToolbar methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/12/2012 18:03'! initialize "Initialization code for OkCancelToolbar" cancelled := false asValueHolder. cancelAction := [ true ] asValueHolder. super initialize.! ! !OkCancelToolbar methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/12/2012 18:03'! initializePresenter super initializePresenter. cancelButton action: [ cancelAction contents value == false ifFalse: [ cancelled contents: true. owner ifNil: [ self delete ] ifNotNil: [ owner delete ]]].! ! !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: 'initialization' stamp: 'BenjaminVanRyseghem 6/12/2012 18:03'! registerCancelButtonEvents cancelButton label: 'Cancel'; enabled: true; state: false! ! !OkCancelToolbar methodsFor: 'protocol'! cancelAction ^ cancelAction contents! ! !OkCancelToolbar methodsFor: 'protocol'! cancelAction: aBlock ^ cancelAction contents: aBlock! ! !OkCancelToolbar methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/11/2012 18:32'! cancelled ^ cancelled contents! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! OkCancelToolbar class instanceVariableNames: ''! !OkCancelToolbar class methodsFor: 'specs' stamp: 'bvr 6/4/2012 14:51'! defaultSpec ^ { #Panel. #changeTableLayout. #listDirection:. #rightToLeft. #add:. {#model. #hFill}. #add:. {#model. #hFill}. #add:. {#model. #hFill}. #add:. {#model. #hFill}. #add:. {#model. #hFill}. #add:. {#model. #hFill}. #add:. {#model. #okButton. }. #add:. {#model. #cancelButton.}. #hSpaceFill. #vShrinkWrap. }! ! !OkCancelToolbar class methodsFor: 'specs'! title ^ 'Ok Cancel'! ! ComposableModel subclass: #OkToolbar instanceVariableNames: 'okButton okAction' classVariableNames: '' poolDictionaries: '' category: 'Spec-Widgets-PolyWidgets'! !OkToolbar commentStamp: '' prior: 0! An OkCancelToolbar is a model for a basic Ok toolbar! !OkToolbar methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/10/2012 13:05'! okButton ^ okButton! ! !OkToolbar methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/11/2012 10:31'! initialize "Initialization code for OkCancelToolbar" super initialize. okAction := [ true ] asValueHolder.! ! !OkToolbar methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 6/12/2012 18:01'! initializePresenter okButton action: [ okAction contents value == false ifFalse: [ 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 6/12/2012 18:01'! registerOkButtonEvents okButton label: 'Ok'; enabled: true; state: false! ! !OkToolbar methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/10/2012 13:05'! okAction ^ okAction contents! ! !OkToolbar methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/10/2012 13:05'! okAction: aBlock ^ okAction contents: aBlock! ! !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: 'private' stamp: 'BenjaminVanRyseghem 5/10/2012 13:05'! hFill ^ Morph new color: Color transparent; height: 0; vResizing: #rigid; hResizing: #spaceFill! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! OkToolbar class instanceVariableNames: ''! !OkToolbar class methodsFor: 'specs' stamp: 'bvr 6/4/2012 14:51'! defaultSpec ^ { #Panel. #changeTableLayout. #listDirection:. #rightToLeft. #add:. {#model. #hFill}. #add:. {#model. #hFill}. #add:. {#model. #hFill}. #add:. {#model. #hFill}. #add:. {#model. #hFill}. #add:. {#model. #hFill}. #add:. {#model. #hFill}. #add:. {#model. #hFill}. #add:. {#model. #hFill}. #add:. {#model. #okButton.}. #hSpaceFill. #vShrinkWrap. }! ! !OkToolbar class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 5/10/2012 13:07'! title ^ 'Ok Toolbar'! ! URI subclass: #OpaqueURI instanceVariableNames: 'pathComponents' classVariableNames: '' poolDictionaries: '' category: 'Network-URI'! !OpaqueURI commentStamp: 'StephaneDucasse 4/4/2010 21:07' prior: 0! An opaque URI is an absolute URI whose scheme-specific part does not begin with a slash character ('/'). Opaque URIs are not subject to further parsing. An absolute URI has a scheme; a URI that is not absolute is said to be relative. URIs are also classified according to whether they are opaque or hierarchical. Some examples of opaque URIs are: mailto:Pharo-project@lists.gforge.inria.fr news:comp.lang.smalltalk urn:isbn:000102002x! !OpaqueURI methodsFor: 'as yet unclassified' stamp: 'DiogenesMoreira 5/9/2011 14:47'! path ^self schemeSpecificPart! ! !OpaqueURI methodsFor: 'as yet unclassified' stamp: 'DiogenesMoreira 5/9/2011 14:45'! pathComponents ^ pathComponents ifNil: [ pathComponents := (self path findTokens: $\) collect: [ :each | each unescapePercents ] ]! ! !OpaqueURI methodsFor: 'testing' stamp: 'DiogenesMoreira 5/9/2011 14:51'! extension "This method assumes a $. as extension delimiter" | i leafName | self pathComponents ifEmpty: [^'']. leafName := self pathComponents last. i := leafName findLast: [:c | c = $.]. ^i = 0 ifTrue: [''] ifFalse: [leafName copyFrom: i + 1 to: leafName size]. ! ! !OpaqueURI methodsFor: 'testing' stamp: 'mir 2/20/2002 16:55'! isOpaque ^true! ! UITestCase subclass: #OpenToolTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolsTest-Base'! !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: 'CamilloBruni 9/21/2012 14:13'! testOpenBrowseOnInstalledTraitMethod | browser | browser := (Behavior>>#localSelectors) browse. browser changed. browser 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:12'! testOpenBrowseOnTraitMethod | browser | browser := (TPureBehavior>>#localSelectors) browse. browser changed. browser close.! ! !OpenToolTest methodsFor: 'test inspect' stamp: 'CamilloBruni 9/21/2012 14:15'! testInspectArray | inspector | inspector := (1 to: 1000) asArray inspect. inspector changed. inspector close.! ! !OpenToolTest methodsFor: 'test inspect' stamp: 'CamilloBruni 9/21/2012 14:14'! testInspectClass | inspector | inspector := Object inspect. inspector changed. inspector close.! ! !OpenToolTest methodsFor: 'test inspect' stamp: 'CamilloBruni 9/21/2012 14:15'! testInspectDictionary | inspector | inspector := (Dictionary new) inspect. inspector changed. inspector close.! ! !OpenToolTest methodsFor: 'test inspect' stamp: 'CamilloBruni 9/21/2012 14:14'! testInspectInteger | inspector | inspector := 1 inspect. inspector changed. inspector close.! ! !OpenToolTest methodsFor: 'test inspect' stamp: 'CamilloBruni 9/21/2012 14:22'! testInspectTraitClass | inspector | inspector := TPureBehavior inspect. 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.! ! ParseNodeVisitor subclass: #OptimizedBlockLocalTempReadBeforeWrittenVisitor instanceVariableNames: 'inOptimizedBlock readBeforeWritten written' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Support'! !OptimizedBlockLocalTempReadBeforeWrittenVisitor commentStamp: 'StephaneDucasse 11/29/2011 22:25' prior: 0! 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: 'accessing' stamp: 'eem 9/8/2008 14:30'! readBeforeWritten ^readBeforeWritten ifNil: [IdentitySet new]! ! !OptimizedBlockLocalTempReadBeforeWrittenVisitor methodsFor: 'initialize-release' stamp: 'eem 9/5/2009 21:03'! initialize inOptimizedBlock := false! ! !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: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/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: '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! ! SequenceableCollection subclass: #OrderedCollection uses: TSortable instanceVariableNames: 'array firstIndex lastIndex' classVariableNames: '' poolDictionaries: '' category: 'Collections-Sequenceable'! !OrderedCollection commentStamp: '' prior: 0! I represent a collection of objects ordered by the collector.! !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: '*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: '*Tools-Inspector' stamp: 'ar 9/27/2005 18:33'! 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." ^OrderedCollectionInspector! ! !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: '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: 'accessing' stamp: 'sma 5/12/2000 11:42'! capacity "Answer the current capacity of the receiver." ^ array size! ! !OrderedCollection methodsFor: 'accessing' stamp: 'sma 5/12/2000 11:39'! size "Answer how many elements the receiver contains." ^ lastIndex - firstIndex + 1! ! !OrderedCollection methodsFor: 'adding'! add: newObject ^self addLast: newObject! ! !OrderedCollection methodsFor: 'adding'! 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: '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: 'adding'! 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: '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: 'sma 5/12/2000 11:26'! addAll: aCollection "Add each element of aCollection at my end. Answer aCollection." ^ self addAllLast: aCollection! ! !OrderedCollection methodsFor: 'adding'! addAllFirst: anOrderedCollection "Add each element of anOrderedCollection at the beginning of the receiver. Answer anOrderedCollection." anOrderedCollection reverseDo: [:each | self addFirst: each]. ^anOrderedCollection! ! !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: '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'! 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: 'adding'! 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: '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: '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'! copyEmpty "Answer a copy of the receiver that contains no elements." ^self species new! ! !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: 'copying'! 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: 'copying'! 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: 'copying' stamp: 'nice 10/5/2009 08:50'! postCopy array := array copy! ! !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: '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: '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: '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: 'enumerating' stamp: 'hfm 2/12/2009 13:28'! collect: collectBlock thenSelect: selectBlock " Utility method to improve readability. Do not create the intermediate collection." | newCollection | newCollection := self copyEmpty. firstIndex to: lastIndex do:[: index | | newElement | newElement := collectBlock value: ( array at: index ). ( selectBlock value: newElement ) ifTrue:[ newCollection addLast: newElement. ] ]. ^ newCollection! ! !OrderedCollection methodsFor: 'enumerating'! do: aBlock "Override the superclass for performance reasons." | index | index := firstIndex. [index <= lastIndex] whileTrue: [aBlock value: (array at: index). index := index + 1]! ! !OrderedCollection methodsFor: 'enumerating'! reverseDo: aBlock "Override the superclass for performance reasons." | index | index := lastIndex. [index >= firstIndex] whileTrue: [aBlock value: (array at: index). index := index - 1]! ! !OrderedCollection methodsFor: 'enumerating' stamp: 'CamilloBruni 10/20/2012 21:47'! select: aBlock "Evaluate aBlock with each of my elements as the argument. Collect into a new collection like the receiver, only those elements for which aBlock evaluates to true." | newCollection element | newCollection := self copyEmpty. firstIndex to: lastIndex do: [:index | (aBlock value: (element := array at: index)) ifTrue: [ newCollection addLast: element ]]. ^ newCollection! ! !OrderedCollection methodsFor: 'enumerating' stamp: 'hfm 2/12/2009 13:30'! select: selectBlock thenCollect: collectBlock " Utility method to improve readability. Do not create the intermediate collection. " | newCollection | newCollection := self copyEmpty. firstIndex to: lastIndex do:[:index | | element | element := array at: index. ( selectBlock value: element ) ifTrue:[ newCollection addLast: ( collectBlock value: element ) ] ]. ^ newCollection! ! !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: '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: '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: 'removing'! 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: '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: '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 methodsFor: 'removing' stamp: 'ar 5/22/2000 12:19'! removeAt: index | removed | removed := self at: index. self removeIndex: index + firstIndex - 1. ^removed! ! !OrderedCollection methodsFor: 'removing'! 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: '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: 'removing'! 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: '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: '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: 'sorting'! 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! ! !OrderedCollection methodsFor: 'sorting'! 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! ! !OrderedCollection methodsFor: 'sorting'! 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]! ! !OrderedCollection methodsFor: 'sorting'! 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! ! !OrderedCollection methodsFor: 'sorting'! 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! ! !OrderedCollection methodsFor: 'sorting'! sort "Sort this collection into ascending order using the '<=' operator." self sort: [:a :b | a <= b]! ! !OrderedCollection methodsFor: 'sorting' stamp: 'CamilloBruni 10/20/2012 18:11'! sorted: aSortBlock "Return a new sequenceable collection which contains the same elements as self but its elements are sorted by aSortBlock. The block should take two arguments and return true if the first element should preceed the second one." ^self copy sort: aSortBlock! ! !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: '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: 'testing' stamp: 'md 8/13/2008 21:40'! hasContentsInExplorer ^self notEmpty! ! !OrderedCollection methodsFor: 'private'! collector "Private" ^ array! ! !OrderedCollection methodsFor: 'private'! errorConditionNotSatisfied self error: 'no element satisfies condition'! ! !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: '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: '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: '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: '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: '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: 'private' stamp: 'ar 4/16/1999 07:59'! resetTo: index firstIndex := index. lastIndex := firstIndex - 1! ! !OrderedCollection methodsFor: 'private' stamp: 'di 11/14/97 12:54'! setCollection: anArray array := anArray. self reset! ! !OrderedCollection methodsFor: 'private' stamp: 'apb 10/15/2000 18:10'! setContents: anArray array := anArray. firstIndex := 1. lastIndex := array size.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! OrderedCollection class uses: TSortable classTrait instanceVariableNames: ''! !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: 'cmm 10/25/2010 22:27'! new: anInteger ^ self basicNew setCollection: (self arrayType new: anInteger)! ! !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)! ! !OrderedCollection class methodsFor: 'instance creation'! 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: 'stream creation' stamp: 'CamilloBruni 9/5/2011 15:48'! new: size streamContents: aBlock ^ self withAll: (super new: size streamContents: aBlock)! ! !OrderedCollection class methodsFor: 'private' stamp: 'cmm 10/25/2010 22:26'! arrayType ^ Array! ! Inspector subclass: #OrderedCollectionInspector instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tools-Inspector'! !OrderedCollectionInspector methodsFor: 'as yet unclassified' stamp: 'MikeRoberts 8/23/2011 18:03'! fieldList object ifNil: [ ^ OrderedCollection new]. "Guard against incomplete object. You can not ask its size." (object instVarAt: 3) "lastIndex" ifNil: [^self baseFieldList]. ^ self baseFieldList , (object size <= (self i1 + self i2) ifTrue: [(1 to: object size) collect: [:i | i printString]] ifFalse: [(1 to: self i1) , (object size-(self i2-1) to: object size) collect: [:i | i printString]]) " OrderedCollection new inspect (OrderedCollection newFrom: #(3 5 7 123)) inspect (OrderedCollection newFrom: (1 to: 1000)) inspect "! ! !OrderedCollectionInspector methodsFor: 'as yet unclassified' stamp: 'ClementBera 11/15/2012 09:13'! replaceSelectionValue: anObject "The receiver has a list of variables of its inspected object. One of these is selected. The value of the selected variable is set to the value, anObject." selectionIndex <= self numberOfFixedFields ifTrue: [^ super replaceSelectionValue: anObject]. object at: self selectedObjectIndex put: anObject! ! !OrderedCollectionInspector methodsFor: 'as yet unclassified' stamp: 'ClementBera 11/15/2012 09:13'! selectedObjectIndex "Answer the index of the inspectee's collection that the current selection refers to." | basicIndex | basicIndex := selectionIndex - self numberOfFixedFields. ^ (object size <= (self i1 + self i2) or: [basicIndex <= self i1]) ifTrue: [basicIndex] ifFalse: [object size - (self i1 + self i2) + basicIndex]! ! !OrderedCollectionInspector methodsFor: 'as yet unclassified' stamp: 'ClementBera 11/15/2012 09:14'! selection "The receiver has a list of variables of its inspected object. One of these is selected. Answer the value of the selected variable." selectionIndex <= self numberOfFixedFields ifTrue: [^ super selection]. ^ object at: self selectedObjectIndex! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! OrderedCollectionInspector class instanceVariableNames: ''! !OrderedCollectionInspector class methodsFor: 'tools registry' stamp: 'IgorStasenko 2/20/2011 15:14'! registerToolsOn: registry "Register ourselves as inspector for OrderedCollection" registry registerInspector: self for: OrderedCollection ! ! CollectionRootTest subclass: #OrderedCollectionTest uses: TEmptySequenceableTest + TAddTest + TSequencedElementAccessTest + TIncludesWithIdentityCheckTest + TCloneTest + TSetArithmetic + TRemoveForMultiplenessTest + TCreationWithTest + TCopyTest + TPutBasicTest + TIterateSequencedReadableTest + TSubCollectionAccess + TIndexAccess + TCopySequenceableWithReplacement + TCopyPartOfSequenceable + TCopySequenceableSameContents + TCopySequenceableWithOrWithoutSpecificElements - {#testForceToPaddingWith. #testForceToPaddingStartWith} + TPrintOnSequencedTest + TAsStringCommaAndDelimiterSequenceableTest + TConvertTest + TConvertAsSetForMultiplinessIdentityTest + TSequencedConcatenationTest + TBeginsEndsWith + TReplacementSequencedTest + TIndexAccessForMultipliness + TCopyPartOfSequenceableForMultipliness + TConvertAsSortedTest + TPutTest + TSequencedStructuralEqualityTest + TOccurrencesForMultiplinessTest instanceVariableNames: 'empty nonEmpty collectResult emptyButAllocatedWith20 otherCollection indexCollection elementExistsTwice collectionWithElement collectionOfFloat elementNotIn indexArray withoutEqualElements floatCollectionWithSameBeginingEnd duplicateElement collectionWithDuplicateElement collection5Elements collectionWith4Elements' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Sequenceable'! !OrderedCollectionTest commentStamp: 'BG 1/10/2004 22:07' prior: 0! 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: 'as yet unclassified'! 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: 'as yet unclassified'! testStreamContentsProtocol | result index | result:= self collectionClass << [ :s| s nextPutAll: self firstCollection; nextPutAll: self secondCollection ]. self assert: result equals: self firstCollection, self secondCollection.! ! !OrderedCollectionTest methodsFor: 'as yet unclassified'! 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: 'helpers' stamp: 'stephane.ducasse 1/12/2009 17:13'! aValue ^ 33! ! !OrderedCollectionTest methodsFor: 'helpers' stamp: 'stephane.ducasse 1/12/2009 17:13'! anIndex ^ 2! ! !OrderedCollectionTest methodsFor: 'helpers' stamp: 'stephane.ducasse 1/12/2009 17:19'! anotherValue ^ 66! ! !OrderedCollectionTest methodsFor: 'parameters'! accessValuePutIn "return access the element put in the non-empty collection" ^ self perform: self selectorToAccessValuePutIn! ! !OrderedCollectionTest methodsFor: 'parameters'! accessValuePutInOn: s "return access the element put in the non-empty collection" ^ s perform: self selectorToAccessValuePutIn! ! !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: 'parameters'! valuePutIn "the value that we will put in the non empty collection" ^ #x! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'stephane.ducasse 10/30/2008 19:03'! accessCollection ^ indexCollection! ! !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: '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 11:00'! collectionInForIncluding ^ self nonEmpty copyWithoutFirst.! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/23/2009 15:16'! collectionMoreThan1NoDuplicates " return a collection of size 5 without equal elements" ^ withoutEqualElements ! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 5/14/2009 13:59'! collectionMoreThan5Elements " return a collection including at least 5 elements" ^collection5Elements ! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 11:26'! collectionNotIncluded ^ OrderedCollection new add: elementNotIn ; add: elementNotIn ; yourself.! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 10:56'! collectionOfFloat ^ collectionOfFloat ! ! !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: '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: 'requirements' stamp: 'delaunay 4/22/2009 10:21'! collectionWith5Elements " return a collection of size 5 including 5 elements" ^ indexCollection ! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/28/2009 13:49'! collectionWithCopy "return a collection of type 'self collectionWIithoutEqualsElements clas' 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: '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: 'requirements' stamp: 'sd 1/28/2009 16:29'! collectionWithElement "Returns a collection that already includes what is returned by #element." ^ collectionWithElement! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 11:22'! collectionWithElementsToRemove ^ nonEmpty copyWithoutFirst.! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 16:10'! collectionWithEqualElements " return a collecition including atLeast two elements equal" ^collectionWithDuplicateElement ! ! !OrderedCollectionTest methodsFor: 'requirements'! 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: '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/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: 'requirements' stamp: 'delaunay 4/24/2009 10:24'! collectionWithSortableElements " return a collection elements that can be sorte ( understanding message ' < ' or ' > ')" ^ collectionOfFloat ! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'CamilloBruni 9/9/2011 12:12'! collectionWithoutEqualElements " return a collection not including equal elements " ^ withoutEqualElements ! ! !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: 'requirements' stamp: 'StephaneDucasse 5/15/2011 17:27'! element "Returns an object that can be added to the collection returned by #collection." ^ 3! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 11:03'! elementInCollectionOfFloat ^ collectionOfFloat anyOne.! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 11:42'! elementInForElementAccessing " return an element inculded in 'accessCollection '" ^ self accessCollection anyOne! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 11:03'! elementInForIncludesTest " return an element included in nonEmpty " ^ self nonEmpty anyOne! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 13:27'! elementInForIndexAccessing ^ self accessCollection anyOne.! ! !OrderedCollectionTest methodsFor: 'requirements'! elementInForReplacement " return an element included in 'nonEmpty' " ^ self nonEmpty anyOne.! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 11:02'! elementNotIn ^ elementNotIn ! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 11:42'! elementNotInForElementAccessing " return an element not included in 'accessCollection' " ^ elementNotIn ! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 11:32'! elementNotInForIndexAccessing ^ elementNotIn ! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 5/13/2009 16:10'! elementTwiceInForOccurrences " return an element included exactly two time in # collectionWithEqualElements" ^ duplicateElement ! ! !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: '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 15:41'! firstIndex " return an index between 'nonEmpty' bounds that is < to 'second index' " ^1! ! !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: 'requirements' stamp: 'delaunay 4/20/2009 11:49'! indexArray ^ indexArray .! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 14:35'! indexInForCollectionWithoutDuplicates " return an index between 'collectionWithoutEqualsElements' bounds" ^ 2! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 14:44'! indexInNonEmpty " return an index between bounds of 'nonEmpty' " ^ 2! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 14:37'! integerCollection " return a collection only including SmallInteger elements" ^ indexCollection ! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 15:01'! integerCollectionWithoutEqualElements " return a collection of integer without equal elements" ^ withoutEqualElements ! ! !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/27/2009 10:52'! moreThan4Elements " return a collection including at leat 4 elements" ^ indexCollection ! ! !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: '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: 'requirements' stamp: 'delaunay 4/23/2009 14:05'! nonEmptyMoreThan1Element " return a collection with more than one element" ^ withoutEqualElements .! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 5/11/2009 11:29'! nonEmptyWithoutEqualElements " return a collection without equal elements " ^ withoutEqualElements ! ! !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: 'requirements' stamp: 'stephane.ducasse 10/8/2008 16:04'! otherCollection ^ otherCollection! ! !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: '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: 'cyrille.delaunay 12/18/2009 12:05'! result ^ collectResult ! ! !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: 'requirements' stamp: 'delaunay 4/20/2009 15:42'! secondIndex " return an index between 'nonEmpty' bounds that is > to 'second index' " ^2! ! !OrderedCollectionTest methodsFor: 'requirements' stamp: 'delaunay 4/20/2009 11:02'! subCollectionNotIn ^ self collectionNotIncluded .! ! !OrderedCollectionTest methodsFor: 'requirements'! 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: 'requirements' stamp: 'delaunay 4/28/2009 14:11'! withEqualElements " return a collection of float including equal elements (classic equality)" ^ collectionOfFloat , collectionOfFloat! ! !OrderedCollectionTest methodsFor: 'setup' stamp: 'cyrille.delaunay 12/18/2009 13:03'! collection ^ collectionWith4Elements! ! !OrderedCollectionTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/5/2008 12:10'! empty ^ empty! ! !OrderedCollectionTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/6/2008 16:29'! emptyButAllocatedWith20 ^ emptyButAllocatedWith20! ! !OrderedCollectionTest methodsFor: 'setup' stamp: 'stephane.ducasse 10/5/2008 12:10'! nonEmpty ^ nonEmpty! ! !OrderedCollectionTest methodsFor: 'setup' stamp: 'cyrille.delaunay 12/18/2009 13:03'! 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. 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: 'setup' stamp: 'cyrille.delaunay 12/18/2009 13:09'! sizeCollection ^ collectionWith4Elements! ! !OrderedCollectionTest methodsFor: 'test - copy' stamp: 'delaunay 4/17/2009 15:26'! elementToAdd ^ 55! ! !OrderedCollectionTest methodsFor: 'test - creation' stamp: 'stephane.ducasse 12/9/2008 18:31'! collectionClass ^ OrderedCollection! ! !OrderedCollectionTest methodsFor: 'test - creation'! testOfSize "self debug: #testOfSize" | aCol | aCol := self collectionClass ofSize: 3. self assert: (aCol size = 3). ! ! !OrderedCollectionTest methodsFor: 'test - creation'! testWith "self debug: #testWith" | aCol anElement | anElement := self collectionMoreThan5Elements anyOne. aCol := self collectionClass with: anElement. self assert: (aCol includes: anElement).! ! !OrderedCollectionTest methodsFor: 'test - creation'! 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: 'test - creation'! 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: 'test - creation'! 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: 'test - creation'! 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: 'test - creation'! 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: 'test - equality'! testEqualSign "self debug: #testEqualSign" self deny: (self empty = self nonEmpty).! ! !OrderedCollectionTest methodsFor: 'test - equality'! 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: 'test - equality'! 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: 'test - equality'! testEqualSignOfIdenticalCollectionObjects "self debug: #testEqualSignOfIdenticalCollectionObjects" self assert: (self empty = self empty). self assert: (self nonEmpty = self nonEmpty). ! ! !OrderedCollectionTest methodsFor: 'test - iterate' stamp: 'luc.fabresse 11/29/2008 23:09'! expectedSizeAfterReject ^1! ! !OrderedCollectionTest methodsFor: 'test - iterate' stamp: 'stephane.ducasse 10/6/2008 17:38'! speciesClass ^ OrderedCollection! ! !OrderedCollectionTest methodsFor: 'test - remove' stamp: 'damienpollet 1/30/2009 17:16'! elementTwiceIn ^ super elementTwiceIn! ! !OrderedCollectionTest methodsFor: 'test - remove'! 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: '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: '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: '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 - 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: '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 - 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 - 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 - 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 - 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: '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: '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 - 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 - 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 - 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 - 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 - 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: '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 - 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 - 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: 'tests - adding' stamp: 'sd 3/21/2006 22:37'! 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. self shouldnt: [c at: 2 ifAbsentPut: [5]] raise: Error. 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: 'tests - adding'! 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 - adding'! 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 - adding'! 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 - adding'! 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 - adding'! 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: 'tests - adding'! 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 - adding'! 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 - adding'! 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 - as identity set'! 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: 'tests - as identity set'! 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: 'tests - as set tests'! 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 - as set tests'! testAsSetWithEqualsElements | result | result := self withEqualElements asSet. self withEqualElements do: [ :each | self assert: (result occurrencesOf: each) = 1 ]. self assert: result class = Set! ! !OrderedCollectionTest methodsFor: 'tests - as sorted collection' stamp: 'hfm 4/2/2010 13:41'! 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 - as sorted collection'! 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 - as sorted collection'! 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 - at put'! testAtPutOutOfBounds "self debug: #testAtPutOutOfBounds" self should: [self empty at: self anIndex put: self aValue] raise: Error ! ! !OrderedCollectionTest methodsFor: 'tests - at put'! 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 - begins ends with'! 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 - begins ends with'! testsBeginsWithEmpty self deny: (self nonEmpty beginsWith:(self empty)). self deny: (self empty beginsWith:(self nonEmpty )). ! ! !OrderedCollectionTest methodsFor: 'tests - begins ends with'! 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 - begins ends with'! testsEndsWithEmpty self deny: (self nonEmpty endsWith: self empty). self deny: (self empty endsWith: self nonEmpty). ! ! !OrderedCollectionTest methodsFor: 'tests - comma and delimiter'! testAsCommaStringEmpty self assert: self empty asCommaString = ''. self assert: self empty asCommaStringAnd = ''. ! ! !OrderedCollectionTest methodsFor: 'tests - comma and delimiter'! 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 - comma and delimiter'! 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: 'tests - comma and delimiter'! testAsStringOnDelimiterEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim. self assert: emptyStream contents = ''. ! ! !OrderedCollectionTest methodsFor: 'tests - comma and delimiter'! testAsStringOnDelimiterLastEmpty | delim emptyStream | delim := ', '. emptyStream := ReadWriteStream on: ''. self empty asStringOn: emptyStream delimiter: delim last:'and'. self assert: emptyStream contents = ''. ! ! !OrderedCollectionTest methodsFor: 'tests - comma and delimiter'! 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 - comma and delimiter'! 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 - comma and delimiter'! 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 - comma and delimiter'! 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: 'tests - concatenation'! 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: 'tests - concatenation'! 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 - converting'! 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 - converting'! 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 - converting'! assertSameContents: aCollection whenConvertedTo: aClass | result | result := self assertNonDuplicatedContents: aCollection whenConvertedTo: aClass. self assert: result size = aCollection size! ! !OrderedCollectionTest methodsFor: 'tests - converting'! testAsArray "self debug: #testAsArray3" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Array! ! !OrderedCollectionTest methodsFor: 'tests - converting'! testAsBag self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Bag! ! !OrderedCollectionTest methodsFor: 'tests - converting'! testAsByteArray | res | self shouldnt: [self integerCollectionWithoutEqualElements ] raise: Error. 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'! testAsIdentitySet "test with a collection without equal elements :" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: IdentitySet. ! ! !OrderedCollectionTest methodsFor: 'tests - converting'! testAsOrderedCollection self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: OrderedCollection! ! !OrderedCollectionTest methodsFor: 'tests - converting'! testAsSet | | "test with a collection without equal elements :" self assertSameContents: self collectionWithoutEqualElements whenConvertedTo: Set. ! ! !OrderedCollectionTest methodsFor: 'tests - copy'! 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: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! 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 - copy' stamp: 'delaunay 4/17/2009 15:24'! 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 - copy'! 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 - copy'! 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 - copy'! 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: 'delaunay 4/17/2009 15:24'! 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: 'tests - copy' stamp: 'delaunay 3/30/2009 10:33'! testCopyNonEmptyWithoutAllNotIncluded ! ! !OrderedCollectionTest methodsFor: 'tests - copy' stamp: 'delaunay 4/17/2009 15:26'! 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 - copy'! 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 - copy'! 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 - copy - clone'! testCopyCreatesNewObject "self debug: #testCopyCreatesNewObject" | copy | copy := self nonEmpty copy. self deny: self nonEmpty == copy. ! ! !OrderedCollectionTest methodsFor: 'tests - copy - clone'! testCopyEmpty "self debug: #testCopyEmpty" | copy | copy := self empty copy. self assert: copy isEmpty.! ! !OrderedCollectionTest methodsFor: 'tests - copy - clone'! 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 - 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: '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 - 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 - 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 - 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 - copying part of sequenceable'! 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 - copying part of sequenceable'! testCopyAfterEmpty | result | result := self empty copyAfter: self collectionWithoutEqualElements first. self assert: result isEmpty. ! ! !OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable'! 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 - copying part of sequenceable'! testCopyAfterLastEmpty | result | result := self empty copyAfterLast: self collectionWithoutEqualElements first. self assert: result isEmpty.! ! !OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable'! testCopyEmptyMethod | result | result := self collectionWithoutEqualElements copyEmpty . self assert: result isEmpty . self assert: result class= self nonEmpty class.! ! !OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable'! 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 - copying part of sequenceable'! testCopyUpToEmpty | result | result := self empty copyUpTo: self collectionWithoutEqualElements first. self assert: result isEmpty. ! ! !OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable'! 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 - copying part of sequenceable'! testCopyUpToLastEmpty | result | result := self empty copyUpToLast: self collectionWithoutEqualElements first. self assert: result isEmpty.! ! !OrderedCollectionTest methodsFor: 'tests - copying part of sequenceable for multipliness'! 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 - copying part of sequenceable for multipliness'! 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 - copying part of sequenceable for multipliness'! 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 - copying part of sequenceable for multipliness'! 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 - copying same contents'! 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: 'tests - copying same contents'! 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 - copying same contents'! testShallowCopyEmpty | result | result := self empty shallowCopy . self assert: result isEmpty .! ! !OrderedCollectionTest methodsFor: 'tests - copying same contents'! 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 - copying with or without'! 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: 'tests - copying with or without'! 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 - copying with or without'! 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 - copying with or without'! 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: 'tests - copying with replacement'! firstIndexesOf: subCollection 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: subCollection) ifTrue: [ result add: currentIndex. 1 to: subCollection size do: [:i | tmp := tmp copyWithoutFirst. currentIndex := currentIndex + 1] ] ifFalse: [ tmp := tmp copyWithoutFirst. currentIndex := currentIndex +1. ] ]. ^ result. ! ! !OrderedCollectionTest methodsFor: 'tests - copying with replacement'! 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 - copying with replacement'! 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 shouldnt: [self collectionWith2TimeSubcollection ]raise: Error. 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 " specific comportement for the begining of the collection :" ifTrue: [ 1 to: ((firstIndexesOfOccurrence at: i) - 1 ) do: [ :j | self assert: (result at: i) = (self collectionWith2TimeSubcollection at: i) ] ] " between parts till the end : " 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)) ] ] ]. "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: 'tests - copying with replacement'! 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 - element accessing'! 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 - element accessing'! 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 - element accessing'! 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 - element accessing'! 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: 'tests - element accessing'! 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: 'tests - element accessing'! testAtLastError "self debug: #testAtLast" self should: [ self moreThan4Elements atLast: self moreThan4Elements size + 1 ] raise: Error! ! !OrderedCollectionTest methodsFor: 'tests - element accessing'! 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 - element accessing'! 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: 'tests - element accessing'! 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 - element accessing'! testAtRandom | result | result := self nonEmpty atRandom . self assert: (self nonEmpty includes: result).! ! !OrderedCollectionTest methodsFor: 'tests - element accessing'! 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 - element accessing'! 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 - element accessing'! 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 - element accessing'! 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 - element accessing'! testLast "self debug: #testLast" self assert: self moreThan4Elements last = (self moreThan4Elements at: self moreThan4Elements size)! ! !OrderedCollectionTest methodsFor: 'tests - element accessing'! testMiddle "self debug: #testMiddle" self assert: self moreThan4Elements middle = (self moreThan4Elements at: self moreThan4Elements size // 2 + 1)! ! !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: '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: '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 - 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 - equality'! 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 - equality'! 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: 'tests - equality'! 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 - equality'! testHasEqualElementsOfIdenticalCollectionObjects "self debug: #testHasEqualElementsOfIdenticalCollectionObjects" self assert: (self empty hasEqualElements: self empty). self assert: (self nonEmpty hasEqualElements: self nonEmpty). ! ! !OrderedCollectionTest methodsFor: 'tests - fixture'! howMany: subCollection in: collection " return an integer representing how many time 'subCollection' appears in 'collection' " | tmp nTime | tmp:= collection. nTime:= 0. [tmp isEmpty ]whileFalse: [ (tmp beginsWith: subCollection) ifTrue: [ nTime := nTime + 1. 1 to: subCollection size do: [:i | tmp := tmp copyWithoutFirst.] ] ifFalse: [tmp := tmp copyWithoutFirst.] ]. ^ nTime. ! ! !OrderedCollectionTest methodsFor: 'tests - fixture'! test0CopyTest self shouldnt: [ self empty ]raise: Error. self assert: self empty size = 0. self shouldnt: [ self nonEmpty ]raise: Error. self assert: (self nonEmpty size = 0) not. self shouldnt: [ self collectionWithElementsToRemove ]raise: Error. self assert: (self collectionWithElementsToRemove size = 0) not. self collectionWithElementsToRemove do: [:each | self assert: ( self nonEmpty includes: each)]. self shouldnt: [ self elementToAdd ]raise: Error. self deny: (self nonEmpty includes: self elementToAdd ). self shouldnt: [ self collectionNotIncluded ]raise: Error. self collectionNotIncluded do: [ :each | self deny: (self nonEmpty includes: each) ]! ! !OrderedCollectionTest methodsFor: 'tests - fixture'! test0FixtureAsSetForIdentityMultiplinessTest "a collection (of elements for which copy is not identical ) without equal elements:" | anElement res | self shouldnt: [ self elementsCopyNonIdenticalWithoutEqualElements ]raise: Error. 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: 'tests - fixture'! test0FixtureAsStringCommaAndDelimiterTest self shouldnt: [self nonEmpty] raise:Error . self deny: self nonEmpty isEmpty. self shouldnt: [self empty] raise:Error . self assert: self empty isEmpty. self shouldnt: [self nonEmpty1Element ] raise:Error . self assert: self nonEmpty1Element size=1.! ! !OrderedCollectionTest methodsFor: 'tests - fixture'! test0FixtureBeginsEndsWithTest self shouldnt: [self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self assert: self nonEmpty size>1. self shouldnt: [self empty ] raise: Error. self assert: self empty isEmpty.! ! !OrderedCollectionTest methodsFor: 'tests - fixture'! test0FixtureCloneTest self shouldnt: [ self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self empty ] raise: Error. self assert: self empty isEmpty. ! ! !OrderedCollectionTest methodsFor: 'tests - fixture'! test0FixtureConverAsSortedTest self shouldnt: [self collectionWithSortableElements ] raise: Error. self deny: self collectionWithSortableElements isEmpty .! ! !OrderedCollectionTest methodsFor: 'tests - fixture'! test0FixtureCopyPartOfForMultipliness self shouldnt: [self collectionWithSameAtEndAndBegining ] raise: Error. 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 - fixture'! test0FixtureCopyPartOfSequenceableTest self shouldnt: [self collectionWithoutEqualElements ] raise: Error. self collectionWithoutEqualElements do: [:each | self assert: (self collectionWithoutEqualElements occurrencesOf: each)=1]. self shouldnt: [self indexInForCollectionWithoutDuplicates ] raise: Error. self assert: self indexInForCollectionWithoutDuplicates >0 & self indexInForCollectionWithoutDuplicates < self collectionWithoutEqualElements size. self shouldnt: [self empty] raise: Error. self assert: self empty isEmpty .! ! !OrderedCollectionTest methodsFor: 'tests - fixture'! test0FixtureCopySameContentsTest self shouldnt: [self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [self empty ] raise: Error. self assert: self empty isEmpty. ! ! !OrderedCollectionTest methodsFor: 'tests - fixture'! test0FixtureCopyWithOrWithoutSpecificElementsTest self shouldnt: [self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty . self shouldnt: [self indexInNonEmpty ] raise: Error. self assert: self indexInNonEmpty > 0. self assert: self indexInNonEmpty <= self nonEmpty size.! ! !OrderedCollectionTest methodsFor: 'tests - fixture'! test0FixtureCopyWithReplacementTest self shouldnt: [self replacementCollection ]raise: Error. self shouldnt: [self oldSubCollection] raise: Error. self shouldnt: [self collectionWith1TimeSubcollection ]raise: Error. self assert: (self howMany: self oldSubCollection in: self collectionWith1TimeSubcollection ) = 1. ! ! !OrderedCollectionTest methodsFor: 'tests - fixture'! test0FixtureCreationWithTest self shouldnt: [ self collectionMoreThan5Elements ] raise: Error. self assert: self collectionMoreThan5Elements size >= 5.! ! !OrderedCollectionTest methodsFor: 'tests - fixture'! test0FixtureEmptySequenceableTest self shouldnt: [ self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty . self shouldnt: [ self empty ] raise: Error. self assert: self empty isEmpty.! ! !OrderedCollectionTest methodsFor: 'tests - fixture'! test0FixtureIncludeTest | anElementIn | self shouldnt: [ self nonEmpty ]raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self elementNotIn ]raise: Error. anElementIn := true. self nonEmpty detect: [ :each | each = self elementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self shouldnt: [ self anotherElementNotIn ]raise: Error. anElementIn := true. self nonEmpty detect: [ :each | each = self anotherElementNotIn ] ifNone: [ anElementIn := false ]. self assert: anElementIn = false. self shouldnt: [ self empty ] raise: Error. self assert: self empty isEmpty. ! ! !OrderedCollectionTest methodsFor: 'tests - fixture'! test0FixtureIncludeWithIdentityTest | anElement | self shouldnt: [ self collectionWithCopyNonIdentical ]raise: Error. anElement := self collectionWithCopyNonIdentical anyOne. self deny: anElement == anElement copy.! ! !OrderedCollectionTest methodsFor: 'tests - fixture'! test0FixtureIndexAccessFotMultipliness self shouldnt: [ self collectionWithSameAtEndAndBegining ] raise: Error. 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 - fixture'! test0FixtureIndexAccessTest | res collection element | self shouldnt: [ self collectionMoreThan1NoDuplicates ] raise: Error. 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 shouldnt: [ self elementInForIndexAccessing ] raise: Error. self assert: ( (collection := self collectionMoreThan1NoDuplicates )includes: (element:= self elementInForIndexAccessing)). self shouldnt: [ self elementNotInForIndexAccessing ] raise: Error. self deny: (self collectionMoreThan1NoDuplicates includes: self elementNotInForIndexAccessing)! ! !OrderedCollectionTest methodsFor: 'tests - fixture'! test0FixtureIterateSequencedReadableTest | res | self shouldnt: self nonEmptyMoreThan1Element raise: Error. self assert: self nonEmptyMoreThan1Element size > 1. self shouldnt: self empty raise: Error. 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 - fixture'! test0FixtureOccurrencesForMultiplinessTest | cpt anElement collection | self shouldnt: [ self collectionWithEqualElements ] raise: Error. self shouldnt: [ self collectionWithEqualElements ] raise: Error. self shouldnt: [ self elementTwiceInForOccurrences ] raise: Error. 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 - fixture'! test0FixtureOccurrencesTest | tmp | self shouldnt: [self empty ]raise: Error. self assert: self empty isEmpty. self shouldnt: [ self collectionWithoutEqualElements ] raise: Error. self deny: self collectionWithoutEqualElements isEmpty. tmp := OrderedCollection new. self collectionWithoutEqualElements do: [ :each | self deny: (tmp includes: each). tmp add: each. ]. self shouldnt: [ self elementNotInForOccurrences ] raise: Error. self deny: (self collectionWithoutEqualElements includes: self elementNotInForOccurrences)! ! !OrderedCollectionTest methodsFor: 'tests - fixture'! test0FixturePrintTest self shouldnt: [self nonEmpty ] raise: Error.! ! !OrderedCollectionTest methodsFor: 'tests - fixture'! test0FixturePutOneOrMoreElementsTest self shouldnt: self aValue raise: Error. self shouldnt: self indexArray raise: Error. 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 shouldnt: self empty raise: Error. self assert: self empty isEmpty . self shouldnt: self nonEmpty raise: Error. self deny: self nonEmpty isEmpty.! ! !OrderedCollectionTest methodsFor: 'tests - fixture'! test0FixturePutTest self shouldnt: self aValue raise: Error. self shouldnt: self anotherValue raise: Error. self shouldnt: self anIndex raise: Error. self nonEmpty isDictionary ifFalse:[self assert: (self anIndex >=1 & self anIndex <= self nonEmpty size).]. self shouldnt: self empty raise: Error. self assert: self empty isEmpty . self shouldnt: self nonEmpty raise: Error. self deny: self nonEmpty isEmpty.! ! !OrderedCollectionTest methodsFor: 'tests - fixture'! test0FixtureRequirementsOfTAddTest self shouldnt: [ self collectionWithElement ] raise: Exception. self shouldnt: [ self otherCollection ] raise: Exception. self shouldnt: [ self element ] raise: Exception. self assert: (self collectionWithElement includes: self element). self deny: (self otherCollection includes: self element)! ! !OrderedCollectionTest methodsFor: 'tests - fixture'! test0FixtureSequencedConcatenationTest self shouldnt: self empty raise: Exception. self assert: self empty isEmpty. self shouldnt: self firstCollection raise: Exception. self shouldnt: self secondCollection raise: Exception! ! !OrderedCollectionTest methodsFor: 'tests - fixture'! test0FixtureSequencedElementAccessTest self shouldnt: [ self moreThan4Elements ] raise: Error. self assert: self moreThan4Elements size >= 4. self shouldnt: [ self subCollectionNotIn ] raise: Error. self subCollectionNotIn detect: [ :each | (self moreThan4Elements includes: each) not ] ifNone: [ self assert: false ]. self shouldnt: [ self elementNotInForElementAccessing ] raise: Error. self deny: (self moreThan4Elements includes: self elementNotInForElementAccessing). self shouldnt: [ self elementInForElementAccessing ] raise: Error. self assert: (self moreThan4Elements includes: self elementInForElementAccessing)! ! !OrderedCollectionTest methodsFor: 'tests - fixture'! test0FixtureSetAritmeticTest self shouldnt: [ self collection ] raise: Error. self deny: self collection isEmpty. self shouldnt: [ self nonEmpty ] raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: [ self anotherElementOrAssociationNotIn ] raise: Error. self collection isDictionary ifTrue: [ self deny: (self collection associations includes: self anotherElementOrAssociationNotIn key) ] ifFalse: [ self deny: (self collection includes: self anotherElementOrAssociationNotIn) ]. self shouldnt: [ self collectionClass ] raise: Error! ! !OrderedCollectionTest methodsFor: 'tests - fixture'! test0FixtureSubcollectionAccessTest self shouldnt: [ self moreThan3Elements ] raise: Error. self assert: self moreThan3Elements size > 2! ! !OrderedCollectionTest methodsFor: 'tests - fixture' stamp: 'delaunay 4/28/2009 14:11'! test0FixtureTConvertAsSetForMultiplinessTest "a collection ofFloat with equal elements:" | res | self shouldnt: [ self withEqualElements ] raise: Error. self shouldnt: [ self withEqualElements do: [ :each | self assert: each class = Float ] ] raise: Error. 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 shouldnt: [ self elementsCopyNonIdenticalWithoutEqualElements ] raise: Error. self shouldnt: [ self elementsCopyNonIdenticalWithoutEqualElements do: [ :each | self assert: each class = Float ] ] raise: Error. res := true. self elementsCopyNonIdenticalWithoutEqualElements detect: [ :each | (self elementsCopyNonIdenticalWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false! ! !OrderedCollectionTest methodsFor: 'tests - fixture'! test0FixtureTConvertTest "a collection of number without equal elements:" | res | self shouldnt: [ self collectionWithoutEqualElements ]raise: Error. res := true. self collectionWithoutEqualElements detect: [ :each | (self collectionWithoutEqualElements occurrencesOf: each) > 1 ] ifNone: [ res := false ]. self assert: res = false. ! ! !OrderedCollectionTest methodsFor: 'tests - fixture'! test0FixtureTRemoveTest | duplicate | self shouldnt: [ self empty ]raise: Error. self shouldnt: [ self nonEmptyWithoutEqualElements] raise:Error. self deny: self nonEmptyWithoutEqualElements isEmpty. duplicate := true. self nonEmptyWithoutEqualElements detect: [:each | (self nonEmptyWithoutEqualElements occurrencesOf: each) > 1] ifNone: [duplicate := false]. self assert: duplicate = false. self shouldnt: [ self elementNotIn ] raise: Error. self assert: self empty isEmpty. self deny: self nonEmptyWithoutEqualElements isEmpty. self deny: (self nonEmptyWithoutEqualElements includes: self elementNotIn)! ! !OrderedCollectionTest methodsFor: 'tests - fixture'! test0TSequencedStructuralEqualityTest self shouldnt: [self nonEmpty at: 1] raise: Error. "Ensures #nonEmpty is sequenceable"! ! !OrderedCollectionTest methodsFor: 'tests - fixture'! test0TStructuralEqualityTest self shouldnt: [self empty] raise: Error. self shouldnt: [self nonEmpty] raise: Error. self assert: self empty isEmpty. self deny: self nonEmpty isEmpty.! ! !OrderedCollectionTest methodsFor: 'tests - fixture'! testOFixtureReplacementSequencedTest self shouldnt: self nonEmpty raise: Error. self deny: self nonEmpty isEmpty. self shouldnt: self elementInForReplacement raise: Error. self assert: (self nonEmpty includes: self elementInForReplacement ) . self shouldnt: self newElement raise: Error. self shouldnt: self firstIndex raise: Error. self assert: (self firstIndex >= 1 & self firstIndex <= self nonEmpty size). self shouldnt: self secondIndex raise: Error. self assert: (self secondIndex >= 1 & self secondIndex <= self nonEmpty size). self assert: self firstIndex <=self secondIndex . self shouldnt: self replacementCollection raise: Error. self shouldnt: self replacementCollectionSameSize raise: Error. self assert: (self secondIndex - self firstIndex +1)= self replacementCollectionSameSize size ! ! !OrderedCollectionTest methodsFor: 'tests - includes' stamp: 'stephane.ducasse 11/21/2008 14:57'! anotherElementNotIn ^ 42! ! !OrderedCollectionTest methodsFor: 'tests - includes' stamp: 'delaunay 4/2/2009 11:53'! elementNotInForOccurrences ^ 666! ! !OrderedCollectionTest methodsFor: 'tests - includes' stamp: 'delaunay 4/28/2009 10:22'! 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 shouldnt: [ self collectionWithCopyNonIdentical ] raise: Error. collection := self collectionWithCopyNonIdentical. element := collection anyOne copy. "self assert: (collection includes: element)." self deny: (collection identityIncludes: element)! ! !OrderedCollectionTest methodsFor: 'tests - includes'! 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 - includes'! testIncludesAllNoneThere "self debug: #testIncludesAllOfNoneThere'" self deny: (self empty includesAll: self nonEmpty ). self deny: (self nonEmpty includesAll: { self elementNotIn. self anotherElementNotIn })! ! !OrderedCollectionTest methodsFor: 'tests - includes'! 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: 'tests - includes'! testIncludesAnyNoneThere "self debug: #testIncludesAnyOfNoneThere'" self deny: (self nonEmpty includesAny: self empty). self deny: (self nonEmpty includesAny: { self elementNotIn. self anotherElementNotIn })! ! !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: 'tests - includes'! testIncludesElementIsThere "self debug: #testIncludesElementIsThere" self assert: (self nonEmpty includes: self nonEmpty anyOne).! ! !OrderedCollectionTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! testIdentityIndexOf "self debug: #testIdentityIndexOf" | collection element | collection := self collectionMoreThan1NoDuplicates. element := collection first. self assert: (collection identityIndexOf: element) = (collection indexOf: element)! ! !OrderedCollectionTest methodsFor: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 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 - index access' stamp: 'delaunay 4/23/2009 15:14'! 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 - index access' stamp: 'delaunay 4/23/2009 15:14'! 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 - index access' stamp: 'delaunay 4/23/2009 15:14'! 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 - index access'! 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: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 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 - index access' stamp: 'delaunay 4/23/2009 15:14'! 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: 'tests - index access' stamp: 'delaunay 4/23/2009 15:14'! 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 - index access' stamp: 'delaunay 4/23/2009 15:14'! 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 - index access' stamp: 'delaunay 4/23/2009 15:14'! 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! ! !OrderedCollectionTest methodsFor: 'tests - index accessing for multipliness'! testIdentityIndexOfDuplicate "self debug: #testIdentityIndexOf" | collection element | "testing fixture here as this method may not be used by some collections testClass" self shouldnt: [self collectionWithNonIdentitySameAtEndAndBegining ] raise: Error. 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: 'tests - index accessing for multipliness'! 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 - index accessing for multipliness'! 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 - index accessing for multipliness'! 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 - index accessing for multipliness'! 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 - index accessing for multipliness'! 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 - index accessing for multipliness'! 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 - index accessing for multipliness'! 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 - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! testDo! ! !OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 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'! testFindFirstNotIn | result | result:=self empty findFirst: [:each | true]. self assert: result=0. ! ! !OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! testFindLastNotIn | result | result:=self empty findFirst: [:each | true]. self assert: result=0. ! ! !OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! testKeysAndValuesDoEmpty | result | result:= OrderedCollection new. self empty keysAndValuesDo: [:i :value| result add: (value+i)]. self assert: result isEmpty .! ! !OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! 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: 'tests - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! testReverseDoEmpty | result | result:= OrderedCollection new. self empty reverseDo: [: each | result add: each]. self assert: result isEmpty .! ! !OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 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 - iterate on sequenced reable collections'! testWithCollectError self should: [self nonEmptyMoreThan1Element with: self empty collect:[:a :b | ]] raise: Error.! ! !OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 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: 'tests - iterate on sequenced reable collections'! testWithDoError self should: [self nonEmptyMoreThan1Element with: self empty do:[:a :b | ]] raise: Error.! ! !OrderedCollectionTest methodsFor: 'tests - iterate on sequenced reable collections'! 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: 'tests - iterate on sequenced reable collections'! 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 - occurrencesOf'! testOccurrencesOf | collection | collection := self collectionWithoutEqualElements . collection do: [ :each | self assert: (collection occurrencesOf: each) = 1 ].! ! !OrderedCollectionTest methodsFor: 'tests - occurrencesOf'! testOccurrencesOfEmpty | result | result := self empty occurrencesOf: (self collectionWithoutEqualElements anyOne). self assert: result = 0! ! !OrderedCollectionTest methodsFor: 'tests - occurrencesOf'! testOccurrencesOfNotIn | result | result := self collectionWithoutEqualElements occurrencesOf: self elementNotInForOccurrences. self assert: result = 0! ! !OrderedCollectionTest methodsFor: 'tests - occurrencesOf for multipliness'! testOccurrencesOfForMultipliness | collection elem | collection := self collectionWithEqualElements . elem := self elementTwiceInForOccurrences . self assert: (collection occurrencesOf: elem ) = 2. ! ! !OrderedCollectionTest methodsFor: 'tests - printing'! 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: 'tests - printing'! 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 - printing'! 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 - printing'! 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: 'tests - printing'! 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 - printing'! 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 - puting with indexes'! testAtAllIndexesPut self nonEmpty atAllPut: self aValue. self nonEmpty do:[ :each| self assert: each = self aValue]. ! ! !OrderedCollectionTest methodsFor: 'tests - puting with indexes'! testAtAllPut | | self nonEmpty atAll: self indexArray put: self aValue.. self indexArray do: [:i | self assert: (self nonEmpty at: i)=self aValue ]. ! ! !OrderedCollectionTest methodsFor: 'tests - puting with indexes'! 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: 'tests - puting with indexes'! 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 - puting with indexes'! 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 - puting with indexes'! 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 - puting with indexes' stamp: 'GuillermoPolito 5/24/2010 14:31'! 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 - remove'! 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 - remove'! testRemoveAllFoundIn "self debug: #testRemoveElementThatExists" | el aSubCollection | el := self nonEmptyWithoutEqualElements anyOne. aSubCollection := (self nonEmptyWithoutEqualElements copyWithout: el) copyWith: self elementNotIn. self shouldnt: [ | res | res := self nonEmptyWithoutEqualElements removeAllFoundIn: aSubCollection ] raise: Error. self assert: self nonEmptyWithoutEqualElements size = 1. self nonEmptyWithoutEqualElements do: [ :each | self assert: each = el ]! ! !OrderedCollectionTest methodsFor: 'tests - remove'! testRemoveElementFromEmpty "self debug: #testRemoveElementFromEmpty" self should: [ self empty remove: self nonEmptyWithoutEqualElements anyOne ] raise: Error! ! !OrderedCollectionTest methodsFor: 'tests - remove'! 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 - remove'! testRemoveElementThatExists "self debug: #testRemoveElementThatExists" | el res | el := self nonEmptyWithoutEqualElements anyOne. self shouldnt: [ res := self nonEmptyWithoutEqualElements remove: el ] raise: Error. self assert: res == el! ! !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 - 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: '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 - 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 - 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 - replacing'! 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 - replacing'! 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: 'tests - replacing'! 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: 'tests - sequence isempty'! testSequenceAbleIfEmptyifNotEmptyDo "self debug: #testSequenceAbleIfEmptyifNotEmptyDo" self assert: (self nonEmpty ifEmpty: [false] ifNotEmptyDo: [:s | (self accessValuePutInOn: s) = self valuePutIn]).! ! !OrderedCollectionTest methodsFor: 'tests - sequence isempty'! testSequenceIfEmptyifNotEmptyDo "self debug #testSequenceIfEmptyifNotEmptyDo" self assert: (self nonEmpty ifEmpty: [false] ifNotEmptyDo: [:s | (self accessValuePutInOn: s) = self valuePutIn]).! ! !OrderedCollectionTest methodsFor: 'tests - sequence isempty'! testSequenceIfNotEmpty self assert: (self nonEmpty ifNotEmpty: [:s | self accessValuePutInOn: s]) = self valuePutIn! ! !OrderedCollectionTest methodsFor: 'tests - sequence isempty'! testSequenceIfNotEmptyDo self empty ifNotEmptyDo: [:s | self assert: false]. self assert: (self nonEmpty ifNotEmptyDo: [:s | self accessValuePutInOn: s]) = self valuePutIn ! ! !OrderedCollectionTest methodsFor: 'tests - sequence isempty'! testSequenceIfNotEmptyDoifNotEmpty self assert: (self nonEmpty ifNotEmptyDo: [:s | (self accessValuePutInOn: s) = self valuePutIn] ifEmpty: [false])! ! !OrderedCollectionTest methodsFor: 'tests - sequence isempty'! testSequenceIfNotEmptyifEmpty self assert: (self nonEmpty ifEmpty: [false] ifNotEmpty: [:s | (self accessValuePutInOn: s) = self valuePutIn])! ! !OrderedCollectionTest methodsFor: 'tests - set arithmetic'! 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 - set arithmetic'! numberOfSimilarElementsInIntersection ^ self collection occurrencesOf: self anotherElementOrAssociationIn! ! !OrderedCollectionTest methodsFor: 'tests - set arithmetic'! 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: 'tests - set arithmetic'! 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 - set arithmetic'! 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 = 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 = separateCol! ! !OrderedCollectionTest methodsFor: 'tests - set arithmetic'! 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'! 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: 'tests - set arithmetic'! 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 - set arithmetic'! 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 - set arithmetic'! 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 - set arithmetic'! testUnionOfEmpties "self debug: #testUnionOfEmpties" self assert: (self empty union: self empty) isEmpty. ! ! !OrderedCollectionTest methodsFor: 'tests - subcollections access'! 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 - subcollections access'! 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 - subcollections access'! 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: 'tests - subcollections access'! 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 - subcollections access'! 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: 'tests - subcollections access'! 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 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 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: '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 class uses: TEmptySequenceableTest classTrait + TAddTest classTrait + TSequencedElementAccessTest classTrait + TCloneTest classTrait + TCopyTest classTrait + TSetArithmetic classTrait + TCreationWithTest classTrait + TRemoveForMultiplenessTest classTrait + TPutBasicTest classTrait + TIterateSequencedReadableTest classTrait + TSubCollectionAccess classTrait + TIndexAccess classTrait + TCopySequenceableWithReplacement classTrait + TCopyPartOfSequenceable classTrait + TCopySequenceableSameContents classTrait + TCopySequenceableWithOrWithoutSpecificElements classTrait + TPrintOnSequencedTest classTrait + TAsStringCommaAndDelimiterSequenceableTest classTrait + TConvertTest classTrait + TSequencedConcatenationTest classTrait + TBeginsEndsWith classTrait + TReplacementSequencedTest classTrait + TIndexAccessForMultipliness classTrait + TCopyPartOfSequenceableForMultipliness classTrait + TConvertAsSortedTest classTrait + TPutTest classTrait + TIncludesWithIdentityCheckTest classTrait + TConvertAsSetForMultiplinessIdentityTest classTrait + TSequencedStructuralEqualityTest classTrait + TOccurrencesForMultiplinessTest classTrait instanceVariableNames: ''! IdentityDictionary subclass: #OrderedIdentityDictionary instanceVariableNames: 'keys' classVariableNames: '' poolDictionaries: '' category: 'Collections-Sequenceable'! !OrderedIdentityDictionary commentStamp: '' prior: 0! An OrderedIdentityDictionary is a dictionary which keep the order of addition of the elements! !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: '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: 'enumerating' stamp: 'BenjaminVanRyseghem 7/10/2012 21:14'! associationsDo: aBlock keys do: [:k | aBlock value: (self associationAt: k )]! ! !OrderedIdentityDictionary methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 7/10/2012 21:31'! initialize "Initialization code for OrderedIdentityDictionary" "This method is not used since new is overriden to use initalize:" keys := OrderedCollection new. super initialize. ! ! !OrderedIdentityDictionary methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 7/10/2012 21:25'! initialize: aNumber "Initialization code for OrderedIdentityDictionary" keys := OrderedCollection new. super initialize: aNumber! ! !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 ! ! FillStyle subclass: #OrientedFillStyle instanceVariableNames: 'origin direction normal' classVariableNames: '' poolDictionaries: '' category: 'Balloon-Fills'! !OrientedFillStyle commentStamp: '' prior: 0! 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-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: '*morphic-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-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 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: '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:37'! normal: aPoint normal := aPoint! ! !OrientedFillStyle methodsFor: 'accessing' stamp: 'ar 11/11/1998 22:38'! origin ^origin! ! !OrientedFillStyle methodsFor: 'accessing' stamp: 'ar 11/11/1998 22:38'! origin: aPoint origin := aPoint.! ! !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: '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: 'testing' stamp: 'ar 6/18/1999 07:57'! isOrientedFill "Return true if the receiver keeps an orientation (e.g., origin, direction, and normal)" ^true! ! Error subclass: #OutOfMemory instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Exceptions'! !OutOfMemory commentStamp: 'StephaneDucasse 12/18/2009 12:01' prior: 0! 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! ! Notification subclass: #OutOfScopeNotification instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Exceptions'! !OutOfScopeNotification methodsFor: 'as yet unclassified' stamp: 'RAA 2/5/2001 10:41'! defaultAction self resume: false! ! PanelMorph subclass: #OverflowRowMorph instanceVariableNames: 'baseMorphs moreButton moreMorph' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !OverflowRowMorph commentStamp: 'gvc 1/12/2010 13:32' prior: 0! 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: 'accessing' stamp: 'gvc 1/8/2010 19:13'! baseMorphs "Answer the value of baseMorphs" ^ baseMorphs! ! !OverflowRowMorph methodsFor: 'accessing' stamp: 'gvc 1/8/2010 19:13'! baseMorphs: anObject "Set the value of baseMorphs" baseMorphs := anObject! ! !OverflowRowMorph methodsFor: 'accessing' stamp: 'gvc 1/8/2010 19:14'! moreButton "Answer the value of moreButton" ^ moreButton! ! !OverflowRowMorph methodsFor: 'accessing' stamp: 'gvc 1/8/2010 19:14'! moreButton: anObject "Set the value of moreButton" moreButton := anObject! ! !OverflowRowMorph methodsFor: 'accessing' stamp: 'gvc 1/8/2010 20:01'! moreMorph "Answer the value of moreMorph" ^ moreMorph! ! !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 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: '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: '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 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: 'as yet unclassified' stamp: 'gvc 7/1/2010 13:53'! extent: aPoint "Refit the base morphs and potential 'more' button'" super extent: aPoint. self fitBaseMorphs. WorldState addDeferredUIMessage: [self layoutChanged] "since possibly changing actual submorphs during layout processing"! ! !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: 'as yet unclassified' stamp: 'MarcusDenker 4/29/2011 00:37'! hideMore "Hide the morphs that don't fit." self moreVisible ifTrue: [ self moreMorph delete. WorldState addDeferredUIMessage: [self world ifNotNil: [:w | w invalidRect: self moreMorph bounds]]]! ! !OverflowRowMorph methodsFor: 'as yet unclassified' 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/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 1/11/2010 12:48'! moreVisible "Answer whether the more column is visible." ^(self moreMorph ifNil: [^false]) owner notNil! ! !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: '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/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: '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: '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: '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: 'as yet unclassified' stamp: 'gvc 1/11/2010 12:48'! stepTime "Answer the desired time between steps in milliseconds." ^100! ! ImageReadWriter subclass: #PNGReadWriter instanceVariableNames: 'chunk form width height depth backColor bitsPerChannel colorType interlaceMethod bitsPerPixel bytesPerScanline thisScanline prevScanline rowSize globalDataChunk unknownChunks palette transparentPixelValue filtersSeen cachedDecoderMap bigEndian' classVariableNames: 'BPP BlockHeight BlockWidth Debugging StandardColors StandardSwizzleMaps' poolDictionaries: '' category: 'Graphics-Files'! !PNGReadWriter commentStamp: '' prior: 0! I am a subclass of ImageReadWriter that decodes Portable Network Graphics (PNG) images. Submitted by Duane Maxwell! !PNGReadWriter methodsFor: 'accessing' stamp: 'RAA 11/7/2000 09:20'! debugging ^Debugging == true! ! !PNGReadWriter methodsFor: 'accessing' stamp: 'StephaneDucasse 3/17/2010 21:15'! nextImage bigEndian := Smalltalk isBigEndian. filtersSeen := Bag new. globalDataChunk := 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]. chunk := globalDataChunk ifNil: [self error: 'image data is missing']. chunk 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: '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: '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: 'RAA 11/4/2000 17:00'! processIDATChunk interlaceMethod = 0 ifTrue: [ self processNonInterlaced ] ifFalse: [ self processInterlaced ] ! ! !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: 'chunks' stamp: 'lr 7/4/2009 10:42'! 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: chunk from: 1 to: chunk size. 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: 'chunks' stamp: 'lr 7/4/2009 10:42'! processNextChunk | length chunkType crc chunkCrc | length := self nextLong. chunkType := (self next: 4) asString. chunk := self next: length. 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---" globalDataChunk := globalDataChunk ifNil: [ chunk ] ifNotNil: [ globalDataChunk , chunk ]. ^ self ]. unknownChunks add: chunkType! ! !PNGReadWriter methodsFor: 'chunks' stamp: 'lr 7/4/2009 10:42'! 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: chunk size ]. z := ZLibReadStream on: chunk from: 1 to: chunk size. prevScanline := ByteArray new: bytesPerScanline. thisScanline := ByteArray new: bytesPerScanline. 0 to: height - 1 do: [ :y | filter := (z next: 1) first. 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: '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: 'chunks' stamp: 'RAA 11/5/2000 11:24'! processPhysicalPixelChunk "Transcript show: ' PHYSICAL: ',chunk printString." ! ! !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: '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: '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: '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: 'filtering' stamp: 'DSM 3/25/2000 17:55'! filterNone: count ! ! !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: '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: '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: '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: '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: 'miscellaneous' stamp: 'jmv 4/15/2010 10:19'! grayColorsFor: d "return a color table for a gray image" palette := Array new: 1<> 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: 'pixel copies' stamp: 'nice 1/5/2010 15:59'! 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 current 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'! copyPixelsGrayAlpha: y "Handle non-interlaced grayscale with alpha color mode (colorType = 4)" | i pixel gray b | b := BitBlt current 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: 'pixel copies' stamp: 'lr 7/4/2009 10:42'! copyPixelsGrayAlpha: y at: startX by: incX "Handle interlaced grayscale with alpha color mode (colorType = 4)" | i pixel gray b | b := BitBlt current 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: '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: 'nice 1/5/2010 15:59'! 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 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'! copyPixelsRGB: y "Handle non-interlaced RGB color mode (colorType = 2)" | i pixel tempForm tempBits | tempForm := Form extent: width @ 1 depth: 32. tempBits := tempForm bits. pixel := LargePositiveInteger new: 4. pixel at: 4 put: 255. bitsPerChannel = 8 ifTrue: [ i := 1. 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: [ i := 1. 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: '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: '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: '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: '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: '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: '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: '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: '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: 'writing' stamp: 'StephaneDucasse 2/2/2010 12:15'! writeFileSignature stream nextPutAll: #[16r89 16r50 16r4E 16r47 16r0D 16r0A 16r1A 16r0A]! ! !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 17:08'! writeIENDChunkOn: aStream "Write the IEND chunk" aStream nextPutAll: 'IEND' asByteArray.! ! !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: '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: '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: '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: '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: '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 class instanceVariableNames: ''! !PNGReadWriter class methodsFor: 'image reading/writing' stamp: 'nk 7/16/2003 17:57'! typicalFileExtensions "Answer a collection of file extensions (lowercase) which files that I can read might commonly have" ^#('png')! ! !PNGReadWriter class methodsFor: 'initialize' stamp: 'lr 7/4/2009 10:42'! debugging: aBoolean Debugging := aBoolean! ! !PNGReadWriter class methodsFor: 'initialize' stamp: 'lr 7/4/2009 10:42'! initialize " PNGReadWriter initialize " BPP := { #(1 2 4 8 16 ). #(0 0 0 0 0 ). #(0 0 0 24 48 ). #(1 2 4 8 0 ). #(0 0 0 16 32 ). #(0 0 0 0 0 ). #(0 0 0 32 64 ). #(0 0 0 0 0 ) }. BlockHeight := #(8 8 4 4 2 2 1 ). BlockWidth := #(8 4 4 2 2 1 1 ). StandardColors := Color indexedColors collect: [ :aColor | Color r: (aColor red * 255) truncated / 255 g: (aColor green * 255) truncated / 255 b: (aColor blue * 255) truncated / 255 ]. StandardSwizzleMaps := Array new: 4. #(1 2 4 ) do: [ :i | StandardSwizzleMaps at: i put: (self computeSwizzleMapForDepth: i) ]! ! !PNGReadWriter class methodsFor: 'instance creation' stamp: 'lr 7/4/2009 10:42'! createAFormFrom: data | error f | error := ''. f := [ self formFromStream: (RWBinaryOrTextStream with: data) ] ifError: [ :a :b | error := a printString , ' ' , b printString. (StringMorph contents: error) color: Color red; imageForm ]. ^ { f. error }! ! !PNGReadWriter class methodsFor: 'utilities' stamp: 'ar 2/11/2004 00:54'! computeSwizzleMapForDepth: depth "Answer a map that maps pixels in a word to their opposite location. Used for 'middle-endian' forms where the byte-order is different from the bit order (good joke, eh?)." | map swizzled | map := Bitmap new: 256. depth = 4 ifTrue:[ 0 to: 255 do:[:pix| swizzled := 0. swizzled := swizzled bitOr: (((pix bitShift: 0) bitAnd: 15) bitShift: 4). swizzled := swizzled bitOr: (((pix bitShift: -4) bitAnd: 15) bitShift: 0). map at: pix+1 put: swizzled. ]. ^ColorMap colors: map ]. depth = 2 ifTrue:[ 0 to: 255 do:[:pix| swizzled := 0. swizzled := swizzled bitOr: (((pix bitShift: 0) bitAnd: 3) bitShift: 6). swizzled := swizzled bitOr: (((pix bitShift: -2) bitAnd: 3) bitShift: 4). swizzled := swizzled bitOr: (((pix bitShift: -4) bitAnd: 3) bitShift: 2). swizzled := swizzled bitOr: (((pix bitShift: -6) bitAnd: 3) bitShift: 0). map at: pix+1 put: swizzled. ]. ^ColorMap colors: map ]. depth = 1 ifTrue:[ 0 to: 255 do:[:pix| swizzled := 0. swizzled := swizzled bitOr: (((pix bitShift: 0) bitAnd: 1) bitShift: 7). swizzled := swizzled bitOr: (((pix bitShift: -1) bitAnd: 1) bitShift: 6). swizzled := swizzled bitOr: (((pix bitShift: -2) bitAnd: 1) bitShift: 5). swizzled := swizzled bitOr: (((pix bitShift: -3) bitAnd: 1) bitShift: 4). swizzled := swizzled bitOr: (((pix bitShift: -4) bitAnd: 1) bitShift: 3). swizzled := swizzled bitOr: (((pix bitShift: -5) bitAnd: 1) bitShift: 2). swizzled := swizzled bitOr: (((pix bitShift: -6) bitAnd: 1) bitShift: 1). swizzled := swizzled bitOr: (((pix bitShift: -7) bitAnd: 1) bitShift: 0). map at: pix+1 put: swizzled. ]. ^ColorMap colors: map ]. self error: 'Unrecognized depth'! ! TestCase subclass: #PNGReadWriterTest instanceVariableNames: 'fileName' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Tests-Files'! !PNGReadWriterTest methodsFor: 'helpers' stamp: 'SeanDeNigris 7/12/2012 08:44'! deleteFile fileName asFileReference delete! ! !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: '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: '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'! encodeAndDecodeAlpha: original fileName := 'testAlpha', original depth printString,'.png'. self encodeAndDecode: original. self deleteFile.! ! !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: '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: '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: '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: '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: '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. ! ! !PNGReadWriterTest methodsFor: 'helpers' stamp: 'ar 2/29/2004 03:55'! encodeAndDecodeWithError: aStream self should:[self encodeAndDecodeStream: aStream] raise: Error! ! !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: 'helpers' stamp: 'ar 2/12/2004 22:45'! setUp fileName := nil.! ! !PNGReadWriterTest methodsFor: 'helpers' stamp: 'nk 2/17/2004 11:29'! tearDown World changed.! ! !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/12/2004 22:50'! test16Bit self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 16))! ! !PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 00:39'! test16BitDisplay self encodeAndDecodeDisplay: 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/12/2004 22:50'! test1Bit self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 1))! ! !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 - bits' stamp: 'ar 2/11/2004 00:39'! test1BitDisplay self encodeAndDecodeDisplay: 1! ! !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 - bits' stamp: 'ar 2/12/2004 22:50'! test2Bit self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 2))! ! !PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 00:43'! test2BitColors self encodeAndDecodeWithColors: (self drawStuffOn: (Form extent: 33@33 depth: 2))! ! !PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 00:39'! test2BitDisplay self encodeAndDecodeDisplay: 2! ! !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 - bits' stamp: 'ar 2/12/2004 22:50'! test32Bit self encodeAndDecodeForm: (self drawStuffOn: (Form extent: 33@33 depth: 32))! ! !PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/11/2004 00:39'! test32BitDisplay self encodeAndDecodeDisplay: 32! ! !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 - bits' stamp: 'ar 2/11/2004 00:44'! test4BitColors self encodeAndDecodeWithColors: (self drawStuffOn: (Form extent: 33@33 depth: 4))! ! !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'! 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: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 01:57'! test8BitReversed self encodeAndDecodeReverse: (self drawStuffOn: (Form extent: 33@33 depth: 8))! ! !PNGReadWriterTest methodsFor: 'tests - bits' stamp: 'ar 2/12/2004 22:49'! testAlphaCoding self encodeAndDecodeAlpha: (self drawTransparentStuffOn: (Form extent: 33@33 depth: 32))! ! !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 - colors' stamp: 'ar 2/18/2004 23:50'! testBlack16 self encodeAndDecodeColor: Color blue depth: 16! ! !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:50'! testBlack8 self encodeAndDecodeColor: Color blue depth: 8! ! !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'! testBlue32 self encodeAndDecodeColor: Color blue depth: 32! ! !PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:50'! testBlue8 self encodeAndDecodeColor: Color blue depth: 8! ! !PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:50'! testGreen16 self encodeAndDecodeColor: Color green depth: 16! ! !PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:50'! testGreen32 self encodeAndDecodeColor: Color green depth: 32! ! !PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:49'! testGreen8 self encodeAndDecodeColor: Color green depth: 8! ! !PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:49'! testRed16 self encodeAndDecodeColor: Color red depth: 16! ! !PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:48'! testRed32 self encodeAndDecodeColor: Color red depth: 32! ! !PNGReadWriterTest methodsFor: 'tests - colors' stamp: 'ar 2/18/2004 23:49'! testRed8 self encodeAndDecodeColor: Color red depth: 8! ! !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: '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:19'! coloredFiles8 "Created by {Color red. Color green. Color blue. Color black} collect:[:fillC| | ff bytes | ff := Form extent: 32@32 depth: 8. ff fillColor: fillC. bytes := WriteStream on: ByteArray new. PNGReadWriter putForm: ff onStream: bytes. fillC -> (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: '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: 'tests - decoding' stamp: 'ar 2/19/2004 00:20'! testPngDecodingColors16 self decodeColors: self coloredFiles16 depth: 16.! ! !PNGReadWriterTest methodsFor: 'tests - decoding' stamp: 'ar 2/19/2004 00:20'! testPngDecodingColors32 self decodeColors: self coloredFiles32 depth: 32.! ! !PNGReadWriterTest methodsFor: 'tests - decoding' stamp: 'ar 2/19/2004 00:20'! testPngDecodingColors8 self decodeColors: self coloredFiles8 depth: 8.! ! !PNGReadWriterTest methodsFor: 'tests - decoding' stamp: 'ar 2/19/2004 00:28'! testPngEncodingColors16 self encodeColors: self coloredFiles16 depth: 16.! ! !PNGReadWriterTest methodsFor: 'tests - decoding' stamp: 'ar 2/19/2004 00:28'! testPngEncodingColors32 self encodeColors: self coloredFiles32 depth: 32.! ! !PNGReadWriterTest methodsFor: 'tests - decoding' stamp: 'ar 2/19/2004 00:28'! testPngEncodingColors8 self encodeColors: self coloredFiles8 depth: 8.! ! ProtocolClient subclass: #POP3Client instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Network-Protocols'! !POP3Client commentStamp: 'mir 5/12/2003 17:57' prior: 0! 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: 'public protocol' stamp: 'mir 3/7/2002 14:58'! apopLoginUser: userName password: password self loginUser: userName password: password loginMethod: #APOP! ! !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: '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/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: '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: 'len 12/14/2002 17:50'! quit "QUIT " self sendCommand: 'QUIT'. self checkResponse.! ! !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: 'private' stamp: 'mir 11/11/2002 16:20'! loginMethod ^self connectionInfo at: #loginMethod ifAbsent: [nil]! ! !POP3Client methodsFor: 'private' stamp: 'mir 3/8/2002 11:41'! loginMethod: aSymbol ^self connectionInfo at: #loginMethod put: aSymbol! ! !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: '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 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 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: 'private testing' stamp: 'mir 3/7/2002 13:43'! responseIsError ^self lastResponse beginsWith: '-'! ! !POP3Client methodsFor: 'private testing' stamp: 'mir 11/11/2002 15:44'! responseIsWarning ^self lastResponse beginsWith: '-'! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! POP3Client class instanceVariableNames: ''! !POP3Client class methodsFor: 'accessing' stamp: 'mir 3/7/2002 12:51'! defaultPortNumber ^110! ! !POP3Client class methodsFor: 'accessing' stamp: 'mir 3/7/2002 12:52'! logFlag ^#pop! ! !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.! ! ProtocolClientError subclass: #POP3LoginError instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Network-Protocols'! !POP3LoginError commentStamp: 'mir 5/12/2003 17:58' prior: 0! Exception for signaling POP3 login failures.! ListItemWrapper subclass: #PSMCChangeWrapper instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Tools-Diff'! !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: 'AlainPlantec 10/19/2010 21:08'! icon "Answer a form with an icon to represent the receiver" |o| o := self operation. o isNil ifTrue: [^self theme smallJumpIcon]. o isAddition ifTrue: [^self theme smallOkIcon]. o isRemoval ifTrue: [^self theme smallCancelIcon]. ^self theme smallForwardIcon! ! !PSMCChangeWrapper methodsFor: 'accessing' stamp: 'gvc 7/30/2009 13:44'! model: anObject "Set the model." model := anObject! ! !PSMCChangeWrapper methodsFor: 'accessing' stamp: 'gvc 10/30/2006 11:22'! operation "Answer the underlying operation." self subclassResponsibility ! ! !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: 'AlainPlantec 10/19/2010 21:09'! theme ^ UITheme current! ! !PSMCChangeWrapper methodsFor: 'testing' stamp: 'gvc 7/6/2007 14:41'! isConflict "Answer whether the receiver is a conflict item." ^false! ! PSMCChangeWrapper subclass: #PSMCClassChangeWrapper instanceVariableNames: 'conflict contents' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Tools-Diff'! !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'! contents "Answer the contents of the change." ^contents ifNil: [contents := self gatherContents]! ! !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: 'accessing' stamp: 'StephaneDucasse 6/24/2011 16:20'! icon "Answer a form with an icon to represent the receiver" self isConflict ifTrue: [ self localChosen ifTrue: [^self theme smallBackIcon]]. ^super icon! ! !PSMCClassChangeWrapper methodsFor: 'accessing' stamp: 'StephaneDucasse 6/24/2011 16:17'! operation "Answer the patch operation for the class itself or nil if none." |o| o := self model detect: [:i | i targetClassName = self item and: [ i definition isClassDefinition]] ifNone: [ ^ nil ]. ^o! ! !PSMCClassChangeWrapper methodsFor: 'choosing' stamp: 'StephaneDucasse 6/24/2011 16:22'! chooseLocal "Choose the local version." self operation chooseLocal! ! !PSMCClassChangeWrapper methodsFor: 'choosing' stamp: 'StephaneDucasse 6/24/2011 16:22'! chooseRemote "Choose the remote version." self operation chooseRemote! ! !PSMCClassChangeWrapper methodsFor: 'choosing' stamp: 'StephaneDucasse 6/24/2011 16:22'! clearChoice "Choose neither version (be in conflict)." self operation clearChoice! ! !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: 'testing' stamp: 'gvc 7/6/2007 15:42'! remoteChosen "Answer whether the remote version is chosen." ^self conflict remoteChosen! ! ComposableMorph subclass: #PSMCMergeMorph instanceVariableNames: 'patchMorph codeMorph merged' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Tools-Diff'! !PSMCMergeMorph commentStamp: '' prior: 0! A PSMCMergeMorph is a graphical tool to navigate changes and select changes in case of conflicts.! !PSMCMergeMorph methodsFor: 'accessing' stamp: 'gvc 10/29/2006 18:28'! codeMorph "Answer the value of codeMorph" ^ codeMorph! ! !PSMCMergeMorph methodsFor: 'accessing' stamp: 'gvc 10/29/2006 18:28'! codeMorph: anObject "Set the value of codeMorph" codeMorph := anObject! ! !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: 'accessing' stamp: 'gvc 1/8/2009 17:42'! merged: anObject "Set the value of merged" merged := anObject! ! !PSMCMergeMorph methodsFor: 'accessing' stamp: 'gvc 10/29/2006 18:28'! patchMorph "Answer the value of patchMorph" ^ patchMorph! ! !PSMCMergeMorph methodsFor: 'accessing' stamp: 'gvc 10/29/2006 18:28'! patchMorph: anObject "Set the value of patchMorph" patchMorph := anObject! ! !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: 'as yet unclassified' stamp: 'gvc 1/9/2009 15:43'! cancel "Delete the window to cancel." self window delete! ! !PSMCMergeMorph methodsFor: 'as yet unclassified' stamp: 'gvc 11/1/2006 11:53'! compositeText "Answer the composite text from the patch morph." ^self patchMorph compositeText! ! !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: '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/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: 'as yet unclassified' stamp: 'gvc 10/30/2006 09:47'! defaultTitle "Answer the default title label for the receiver." ^'Merge' translated! ! !PSMCMergeMorph methodsFor: 'as yet unclassified' 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 2/4/2010 16:49'! initialColorInSystemWindow: aSystemWindow "Answer the colour the receiver should be when added to a SystemWindow." ^Color transparent! ! !PSMCMergeMorph methodsFor: 'as yet unclassified' 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: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: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' 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: 'as yet unclassified' stamp: 'gvc 11/1/2006 14:26'! newPatchMorph "Answer a new patch morph." ^PSMCMergePatchMorph new borderWidth: 0; addDependent: self; yourself! ! !PSMCMergeMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/29/2009 12:46'! notAllConflictsResolved "Answer whether any conflicts are unresolved." ^self allConflictsResolved not! ! !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: 'as yet unclassified' 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 11/1/2006 11:54'! updateCode "Update the code morph to match selected differences." self changed: #compositeText! ! !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: '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: '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 class instanceVariableNames: ''! !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! ! PSMCPatchMorph subclass: #PSMCMergePatchMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Tools-Diff'! !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: 'GuillermoPolito 5/29/2011 14:51'! 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: self theme 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: self theme 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: self theme 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: 'IgorStasenko 6/24/2011 17:31'! 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: self theme 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: self theme 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: self theme 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: self theme smallRightFlushIcon; keyText: 'Cmd+f'. ^menu! ! !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:50'! hasAnyNonIncomingConflicts "Answer whether there are any conflicts not marked as incoming." ^self allConflicts anySatisfy: [:conflict | conflict isResolved not or: [conflict localChosen]]! ! !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 2/25/2010 13:38'! hasConflicts "Answer whether there are any conflicts." ^self allConflicts notEmpty! ! !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: '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 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: '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/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 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: '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: 'IgorStasenko 6/22/2011 17:51'! selectionIsNotNil ^ self selectedChange notNil! ! !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: '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: '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: '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: 'gvc 7/6/2007 15:46'! useIncomingVersion "Mark the conflict as remote." self selectedChangeWrapper chooseRemote. self changed: #changes. self updateSource! ! !PSMCMergePatchMorph methodsFor: 'hooks' stamp: 'gvc 11/1/2006 14:25'! diffMorphClass "Answer a the class to use for a new diff morph." ^MergeDiffMorph! ! PSMCPatchOperationWrapper subclass: #PSMCOrganizationChangeWrapper instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Tools-Diff'! DiffChangeMorph subclass: #PSMCPatchMorph instanceVariableNames: 'changeTree selectedChangeWrapper' classVariableNames: 'UsedByDefault' poolDictionaries: '' category: 'Polymorph-Tools-Diff'! !PSMCPatchMorph commentStamp: 'LaurentLaffont 2/23/2011 20:21' prior: 0! I'm a Monticello tool based on polymorph used to browse diffs. Activate me with the setting named 'Use Polymorph difference tools'.! !PSMCPatchMorph methodsFor: 'accessing' stamp: 'gvc 1/29/2009 13:17'! changeTree "Answer the value of changeTree" ^ changeTree! ! !PSMCPatchMorph methodsFor: 'accessing' stamp: 'gvc 1/29/2009 13:17'! changeTree: anObject "Set the value of changeTree" changeTree := anObject! ! !PSMCPatchMorph methodsFor: 'accessing' stamp: 'gvc 10/29/2006 18:18'! defaultTitle "Answer the default title label for the receiver." ^'Changes' translated! ! !PSMCPatchMorph methodsFor: 'accessing' stamp: 'gvc 10/26/2006 11:58'! selectedChange "Answer the selected change." ^(self selectedChangeWrapper ifNil: [^nil]) operation! ! !PSMCPatchMorph methodsFor: 'accessing' stamp: 'gvc 10/26/2006 11:57'! selectedChangeWrapper "Answer the selected change." ^selectedChangeWrapper! ! !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: '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: 'as yet unclassified' stamp: 'gvc 1/14/2009 12:47'! browseImplementors "Browse the method implementors." self systemNavigation browseAllImplementorsOf: (self selectedMessageName ifNil: [^self])! ! !PSMCPatchMorph methodsFor: 'as yet unclassified' stamp: 'gvc 1/14/2009 12:47'! browseSenders "Browse the method senders." self systemNavigation browseAllCallsOn: (self selectedMessageName ifNil: [^self])! ! !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: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: 'nice 3/28/2011 23:21'! 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: 'MarianoMartinezPeck 4/26/2012 10:30'! changesMenu: m "Answer the changes menu." |menu| menu := self newMenu addTitle: 'Changes' icon: self theme 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: self theme smallJustifiedIcon; keyText: 'Cmd+v'. menu addToggle: 'Senders...' translated target: self selector: #browseSenders getStateSelector: nil enablementSelector: #selectionIsMethodChange. menu lastItem font: self theme menuFont; icon: self theme smallForwardIcon; keyText: 'Cmd+n'. menu addToggle: 'Implementors...' translated target: self selector: #browseImplementors getStateSelector: nil enablementSelector: #selectionIsMethodChange. menu lastItem font: self theme menuFont; icon: self theme 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: self theme 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 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: '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: '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: 'gvc 8/12/2009 13:28'! selectionHasAcutalClass "Answer whether the currently selected change has an actual class in the image." ^self selectedChangeWrapper ifNil: [false] ifNotNilDo: [:w | w actualClass notNil]! ! !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: '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: '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: 'initialize-release' stamp: 'IgorStasenko 12/19/2012 17: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 changeTree expandAll] ! ! !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 class instanceVariableNames: ''! !PSMCPatchMorph class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'AlainPlantec 10/19/2010 21:11'! taskbarIcon "Answer the icon for the receiver in a task bar." ^self theme smallForwardIcon! ! !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! ! !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 2/9/2010 14:03'! usedByDefault: aBoolean "Specify whether the Polymorph diff tools should be used with Monticello." UsedByDefault := aBoolean! ! PSMCChangeWrapper subclass: #PSMCPatchOperationWrapper instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Tools-Diff'! !PSMCPatchOperationWrapper methodsFor: 'accessing' stamp: 'StephaneDucasse 6/24/2011 15:52'! chooseLocal "Choose the local version." self operation chooseLocal! ! !PSMCPatchOperationWrapper methodsFor: 'accessing' stamp: 'StephaneDucasse 6/24/2011 15:52'! chooseRemote "Choose the remote version." self operation chooseRemote! ! !PSMCPatchOperationWrapper methodsFor: 'accessing' stamp: 'StephaneDucasse 6/24/2011 15:47'! icon "Answer a form with an icon to represent the receiver" self item localChosen ifTrue: [^self theme smallBackIcon]. ^super icon! ! !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: 'converting' stamp: 'GaryChambers 10/26/2011 16:19'! asString "Answer the method name." ^self item definition summary! ! !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: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: 'testing' stamp: 'StephaneDucasse 6/24/2011 15:51'! remoteChosen "Answer whether the remote version is chosen." ^self operation remoteChosen! ! Object subclass: #PSMCSystemSettings instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Settings-Polymorph'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PSMCSystemSettings class instanceVariableNames: ''! !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! ! HelpBuilder subclass: #PackageAPIHelpBuilder instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'HelpSystem-Core-Builders'! !PackageAPIHelpBuilder methodsFor: 'building' stamp: 'tbn 3/23/2010 21:28'! build |pTopic| topicToBuild := (HelpTopic named: rootToBuildFrom bookName). rootToBuildFrom packages do: [:package| pTopic := HelpTopic named: package. topicToBuild addSubtopic: pTopic. self buildPackageTopic: pTopic. ] ! ! !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 ] ! ! MorphTreeNodeModel subclass: #PackageAbstractNodeExample instanceVariableNames: 'contents' classVariableNames: '' poolDictionaries: '' category: 'Morphic-MorphTreeWidget-Examples'! !PackageAbstractNodeExample methodsFor: 'accessing' stamp: 'AlainPlantec 1/16/2010 09:52'! browseItem ! ! !PackageAbstractNodeExample methodsFor: 'accessing' stamp: 'AlainPlantec 1/16/2010 09:52'! doubleClick self browseItem! ! !PackageAbstractNodeExample methodsFor: 'accessing' stamp: 'AlainPlantec 1/16/2010 09:52'! exploreItem self explore! ! !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 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. ! ! !PackageAbstractNodeExample methodsFor: 'menu' stamp: 'AlainPlantec 1/15/2010 14:53'! contents ^ contents ifNil: [contents := super contents]! ! Object subclass: #PackageChecker instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'RPackage-SystemIntegration'! !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 ! ! PackageAbstractNodeExample subclass: #PackageClassNodeExample instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-MorphTreeWidget-Examples'! !PackageClassNodeExample methodsFor: 'accessing' stamp: 'StephaneDucasse 10/15/2011 20:57'! browseItem Smalltalk tools browser fullOnClass: self item selector: nil! ! !PackageClassNodeExample methodsFor: 'menu' stamp: 'AlainPlantec 2/8/2010 09:39'! childNodeClassFromItem: anItem ^PackageMethodCategoryNodeExample! ! !PackageClassNodeExample methodsFor: 'menu' stamp: 'AlainPlantec 1/29/2010 12:16'! childrenItems ^ self item organization categories ! ! !PackageClassNodeExample methodsFor: 'menu' stamp: 'AlainPlantec 1/19/2010 15:44'! methodsInCategory: aCat ^ self item methodsInCategory: aCat! ! TestCase subclass: #PackageDependencyTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-System'! !PackageDependencyTest methodsFor: 'test utility' stamp: 'Alexandre Bergel 5/22/2010 15:38'! dependenciesOfPackageNamed: pkgNameAsString | deps classes | classes := self referencesInPackageNamed: pkgNameAsString. deps := Dictionary new. classes do: [:aClass | | pkg | pkg := PackageOrganizer default packageOfClass: aClass ifNone: []. pkg ifNil: [Transcript cr; show: 'WARNING: No package for ' , pkg] ifNotNil: [(deps at: pkg packageName ifAbsentPut: [OrderedCollection new]) add: aClass]]. deps removeKey: pkgNameAsString ifAbsent: []. ^ deps! ! !PackageDependencyTest methodsFor: 'test utility' stamp: 'Alexandre Bergel 5/22/2010 15:47'! referencesInClass: aClass | classes | classes := IdentitySet new. aClass isTrait ifFalse: [ classes add: aClass superclass ]. "The following line is wrong because methods may be defined in a different package" "aClass methods do: [ :cm | classes addAll: (self referencesInCompiledMethod: cm) ]." ^ classes! ! !PackageDependencyTest methodsFor: 'test utility' stamp: 'Alexandre Bergel 5/22/2010 15:32'! referencesInCompiledMethod: aCompiledMethod | classes | classes := IdentitySet new. 1 to: aCompiledMethod numLiterals do: [:i | | lit | ((lit := aCompiledMethod literalAt: i) isVariableBinding and: [ lit value isBehavior ]) ifTrue: [classes add: lit value ]]. ^ classes! ! !PackageDependencyTest methodsFor: 'test utility' stamp: 'Alexandre Bergel 5/22/2010 15:43'! referencesInPackage: aPackageInfo | classes | classes := IdentitySet new. aPackageInfo classes do: [ :cls | classes addAll: (self referencesInClass: cls) ]. aPackageInfo methods do: [ :mr | classes addAll: (self referencesInCompiledMethod: mr compiledMethod )]. ^ classes! ! !PackageDependencyTest methodsFor: 'test utility' stamp: 'Alexandre Bergel 5/22/2010 15:33'! referencesInPackageNamed: pkgNameAsString | pi | pi := PackageOrganizer default packageNamed: pkgNameAsString ifAbsent: [^ self]. ^ self referencesInPackage: pi! ! !PackageDependencyTest methodsFor: 'test utility' stamp: 'StephaneDucasse 9/9/2010 14:50'! testPackage: pkgName dependsExactlyOn: pkgList "Ensure that the package with the given name depends only on the packages in pkgList. NOTE: If you use this for fixing dependencies, classDeps includes the classes and users from the package(s) not declared as dependents. Basically, you need to fix all the references in classDeps to make the test pass." | classDeps pi pkgDeps | classDeps := IdentityDictionary new. pi := PackageOrganizer default packageNamed: pkgName ifAbsent:[^self]. "unloaded" pi classes do: [ :pkgClass | (classDeps at: (pkgClass superclass ifNil: [ProtoObject]) ifAbsentPut:[OrderedCollection new]) add: pkgClass name, ' superclass'.]. pi methods do: [ :mref | | cm | cm := mref compiledMethod. 1 to: cm numLiterals do: [ :i | | lit | ((lit := cm literalAt: i) isVariableBinding and:[lit value isBehavior]) ifTrue:[(classDeps at: lit value ifAbsentPut:[OrderedCollection new]) add: cm methodClass asString, '>>', cm selector]]]. pkgDeps := Dictionary new. classDeps keys do: [ :aClass | | pkg | pkg := PackageOrganizer default packageOfClass: aClass ifNone:[nil]. pkg ifNil: [ Transcript cr; show: 'WARNING: No package for ', aClass. (classDeps removeKey: aClass) do:[:each| Transcript crtab; show: each]] ifNotNil: [(pkgDeps at: pkg name ifAbsentPut:[OrderedCollection new]) add: aClass]]. (pkgDeps removeKey: pkgName ifAbsent: [#()]) do: [ :aClass | classDeps removeKey: aClass ifAbsent: []]. pkgList do: [ :pkg | self assert: (pkgDeps includesKey: pkg) description: pkgName, ' no longer depends on ', pkg. (pkgDeps removeKey: pkg ifAbsent: [#()]) do: [ :aClass | classDeps removeKey: aClass ifAbsent:[]]]. classDeps keysAndValuesDo: [ :class :deps | Transcript cr; show: class name, ' dependencies:'. deps do: [ :each | Transcript crtab; show: each]]. self assert: pkgDeps isEmpty description: pkgName, ' now depends on ', pkgDeps. ! ! !PackageDependencyTest methodsFor: 'test utility' stamp: 'Alexandre Bergel 5/22/2010 15:36'! testPackage: pkgName dependsOnlyOn: pkgList "Ensure that the package with the given name depends only on the packages in pkgList" | classes pi deps | deps := self dependenciesOfPackageNamed: pkgName. pkgList do: [:pkg | self assert: (deps includesKey: pkg). deps removeKey: pkg]. self assert: deps isEmpty! ! Object subclass: #PackageInfo instanceVariableNames: 'packageName methodCategoryPrefix' classVariableNames: '' poolDictionaries: '' category: 'PackageInfo-Base'! !PackageInfo commentStamp: '' prior: 0! Subclass this class to create new Packages.! !PackageInfo methodsFor: '*RPackage-Core' stamp: 'SeanDeNigris 2/5/2013 16:16'! asRPackageSet ^ RPackageSet named: self packageName.! ! !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: '*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: '*RPackage-Core' stamp: 'cyrille.delaunay 10/29/2010 10:31'! coreMethodsNotDefinedInSubCategories ^ self classesAndMetaClassesNotDefinedInSubCategories gather: [:class | self coreMethodsForClass: class]! ! !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: '*RPackage-Core' stamp: 'cyrille.delaunay 10/29/2010 10:37'! extensionMethodsNotDefinedInSubCategories ^ self externalBehaviorsNotDefinedInSubCategories gather: [:classOrTrait | self extensionMethodsForClass: classOrTrait]! ! !PackageInfo methodsFor: '*RPackage-Core' stamp: 'cyrille.delaunay 10/29/2010 10:37'! externalBehaviorsNotDefinedInSubCategories ^self externalClassesNotDefinedInSubCategories , self externalTraitsNotDefinedInSubCategories! ! !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: '*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: '*RPackage-Core' stamp: 'EstebanLorenzano 1/24/2013 13:40'! isEmpty ^(self classesAndMetaClassesNotDefinedInSubCategories, self coreMethodsNotDefinedInSubCategories, self extensionMethodsNotDefinedInSubCategories) isEmpty ! ! !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: '*Ring-Core-Containers' 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: '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: 'accessing' stamp: 'GuillermoPolito 8/18/2012 13:55'! definedClasses ^self classes! ! !PackageInfo methodsFor: 'accessing' stamp: 'sd 9/12/2010 19:05'! environment ^ Smalltalk globals ! ! !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: 'accessing' stamp: 'sd 9/12/2010 19:07'! foreignSystemCategories ^ self systemOrganization categories reject: [:cat | self includesSystemCategory: cat] ! ! !PackageInfo methodsFor: 'comparing' stamp: 'avi 10/11/2003 14:20'! hash ^ packageName hash! ! !PackageInfo methodsFor: 'comparing' stamp: 'avi 10/11/2003 00:09'! = other ^ other species = self species and: [other packageName = self packageName]! ! !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: 'dependencies' stamp: 'ab 11/18/2002 01:16'! externalCallers ^ self externalRefsSelect: [:literal | literal isKindOf: Symbol] thenCollect: [:l | l].! ! !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: '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: '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: 'dependencies' stamp: 'ab 11/18/2002 01:15'! externalUsers ^ self externalRefsSelect: [:literal | literal isVariableBinding] thenCollect: [:l | l key]! ! !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: '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: '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: '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: '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: '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: '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: '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: 'ab 11/13/2002 01:23'! coreMethods ^ self classesAndMetaClasses gather: [:class | self coreMethodsForClass: class]! ! !PackageInfo methodsFor: 'listing' stamp: 'al 3/1/2006 21:51'! extensionClasses ^ self externalBehaviors reject: [:classOrTrait | (self extensionCategoriesForClass: classOrTrait) isEmpty]! ! !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: '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: 'listing' stamp: 'StephaneDucasse 2/6/2010 17:37'! overriddenMethods ^ Array streamContents: [:stream | self overriddenMethodsDo: [:each | stream nextPut: each]] ! ! !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: 'listing' stamp: 'StephaneDucasse 8/9/2011 18:01'! selectors ^ self methods collect: [:ea | ea selector]! ! !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: '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: 'modifying' stamp: 'StephaneDucasse 8/18/2009 23:17'! addMethod: aMethodReference (self includesClass: aMethodReference actualClass) ifTrue: [self addCoreMethod: aMethodReference] ifFalse: [self addExtensionMethod: aMethodReference]! ! !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: 'modifying' stamp: 'al 3/1/2006 21:42'! externalBehaviors ^self externalClasses , self externalTraits! ! !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: 'modifying' stamp: 'avi 10/11/2003 15:14'! removeMethod: aMethodReference! ! !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: 'naming' stamp: 'ab 10/16/2002 21:22'! externalName ^ self packageName! ! !PackageInfo methodsFor: 'naming' stamp: 'stephaneducasse 2/4/2006 20:40'! methodCategoryPrefix ^ methodCategoryPrefix ifNil: [methodCategoryPrefix := '*', self packageName asLowercase]! ! !PackageInfo methodsFor: 'naming' stamp: 'stephaneducasse 2/4/2006 20:40'! packageName ^ packageName ifNil: [packageName := self categoryName]! ! !PackageInfo methodsFor: 'naming' stamp: 'stephaneducasse 2/4/2006 20:40'! packageName: aString packageName := aString! ! !PackageInfo methodsFor: 'naming' stamp: 'ab 10/28/2002 10:38'! systemCategoryPrefix ^ self packageName! ! !PackageInfo methodsFor: 'printing' stamp: 'stephane.ducasse 8/26/2008 20:43'! printOn: aStream super printOn: aStream. aStream nextPutAll: '(',self packageName,')'.! ! !PackageInfo methodsFor: 'registering' stamp: 'avi 11/12/2003 23:12'! register PackageOrganizer default registerPackage: self! ! !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: 'testing' stamp: 'VeronicaUquillas 8/31/2011 14:04'! changeRecordForOverriddenMethod: aMethodReference | sourceFilesCopy method position | method := aMethodReference actualClass compiledMethodAt: aMethodReference selector. position := method filePosition. sourceFilesCopy := SourceFiles collect: [ :x | x isNil ifTrue: [ nil ] ifFalse: [ x readOnlyCopy ] ]. [ | file prevPos prevFileIndex chunk stamp methodCategory tokens | method fileIndex = 0 ifTrue: [ ^ nil ]. file := sourceFilesCopy at: method fileIndex. [ position notNil & file notNil ] whileTrue: [ file position: (0 max: position - 150). "Skip back to before the preamble" [ file position < (position - 1) ] whileTrue: [ chunk := file nextChunk ]. "then pick it up from the front" "Preamble is likely a linked method preamble, if we're in a changes file (not the sources file). Try to parse it for prior source position and file index" prevPos := nil. stamp := ''. (chunk findString: 'methodsFor:' startingAt: 1) > 0 ifTrue: [ tokens := Scanner new scanTokens: chunk ] ifFalse: [ tokens := Array new "ie cant be back ref" ]. ((tokens size between: 7 and: 8) and: [ (tokens at: tokens size - 5) = #methodsFor: ]) ifTrue: [ (tokens at: tokens size - 3) = #stamp: ifTrue: [ "New format gives change stamp and unified prior pointer" stamp := tokens at: tokens size - 2. prevPos := tokens last. prevFileIndex := sourceFilesCopy fileIndexFromSourcePointer: prevPos. prevPos := sourceFilesCopy filePositionFromSourcePointer: prevPos ] ifFalse: [ "Old format gives no stamp; prior pointer in two parts" prevPos := tokens at: tokens size - 2. prevFileIndex := tokens last ]. (prevPos = 0 or: [ prevFileIndex = 0 ]) ifTrue: [ prevPos := nil ] ]. ((tokens size between: 5 and: 6) and: [ (tokens at: tokens size - 3) = #methodsFor: ]) ifTrue: [ (tokens at: tokens size - 1) = #stamp: ifTrue: [ "New format gives change stamp and unified prior pointer" stamp := tokens at: tokens size ] ]. methodCategory := tokens after: #methodsFor: ifAbsent: [ 'as yet unclassifed' ]. (self includesMethodCategory: methodCategory ofClass: aMethodReference actualClass) ifTrue: [ methodCategory = (Smalltalk globals at: #Categorizer ifAbsent: [ Smalltalk globals at: #ClassOrganizer ]) default ifTrue: [ methodCategory := methodCategory , ' ' ]. ^ ChangeRecord new file: file position: position type: #method class: aMethodReference theNonMetaClassName category: methodCategory meta: aMethodReference classIsMeta stamp: stamp ]. position := prevPos. prevPos notNil ifTrue: [ file := sourceFilesCopy at: prevFileIndex ] ]. ^ nil ] ensure: [ sourceFilesCopy do: [ :x | x notNil ifTrue: [ x close ] ] ]! ! !PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:18'! coreCategoriesForClass: aClass ^ aClass organization categories select: [:cat | (self isForeignClassExtension: cat) not]! ! !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: 'ab 11/13/2002 01:20'! extensionCategoriesForClass: aClass ^ aClass organization categories select: [:cat | self isYourClassExtension: cat]! ! !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: 'testing' stamp: 'dvf 10/18/2002 23:22'! extensionMethodsFromClasses: classes ^classes gather: [:class | self extensionMethodsForClass: class]! ! !PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:22'! foreignExtensionCategoriesForClass: aClass ^ aClass organization categories select: [:cat | self isForeignClassExtension: cat]! ! !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: 'StephaneDucasse 2/6/2010 16:39'! includesChangeRecord: aChangeRecord ^ aChangeRecord methodClass notNil and: [self includesMethodCategory: aChangeRecord category ofClass: aChangeRecord methodClass]! ! !PackageInfo methodsFor: 'testing' stamp: 'sd 9/12/2010 19:07'! includesClassNamed: aClassName ^ self includesSystemCategory: ((self systemOrganization categoryOfElement: aClassName) ifNil: [^false])! ! !PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:23'! includesClass: aClass ^ self includesSystemCategory: aClass theNonMetaClass category! ! !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: '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: 'StephaneDucasse 8/9/2011 18:00'! includesMethodReference: aMethodRef ^ self includesMethod: aMethodRef selector ofClass: aMethodRef actualClass! ! !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'! includesSystemCategory: categoryName ^ self category: categoryName matches: self systemCategoryPrefix! ! !PackageInfo methodsFor: 'testing' stamp: 'ab 11/13/2002 01:23'! isForeignClassExtension: categoryName ^ categoryName first = $* and: [(self isYourClassExtension: categoryName) not]! ! !PackageInfo methodsFor: 'testing' stamp: 'StephaneDucasse 2/6/2010 16:41'! isOverrideCategory: aString ^ aString endsWith: '-override'! ! !PackageInfo methodsFor: 'testing' stamp: 'StephaneDucasse 2/6/2010 16:41'! isOverrideMethod: aMethodReference ^ self isOverrideCategory: aMethodReference category! ! !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: 'testing' stamp: 'avi 3/10/2004 12:37'! isYourClassExtension: categoryName ^ categoryName notNil and: [self category: categoryName asLowercase matches: self methodCategoryPrefix]! ! !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: 'dvf 10/18/2002 23:22'! outsideClasses ^ProtoObject withAllSubclasses difference: self classesAndMetaClasses! ! !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: 'testing' stamp: 'StephaneDucasse 8/21/2011 17:46'! referenceForMethod: aSymbol ofClass: aClass ^ RGMethodDefinition realClass: aClass selector: aSymbol! ! !PackageInfo methodsFor: 'testing' stamp: 'sd 9/12/2010 19:08'! systemCategories ^ self systemOrganization categories select: [:cat | self includesSystemCategory: cat]! ! !PackageInfo methodsFor: 'testing' stamp: 'sd 9/12/2010 19:08'! systemOrganization ^self environment organization! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PackageInfo class instanceVariableNames: ''! !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: 'initialization' stamp: 'avi 2/18/2004 00:46'! initialize self allSubclassesDo: [:ea | ea 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/12/2003 23:00'! named: aString ^ PackageOrganizer default packageNamed: aString ifAbsent: [(self new packageName: aString) register]! ! !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]) ! ! TestCase subclass: #PackageInfoTest instanceVariableNames: 'createdClasses' classVariableNames: '' poolDictionaries: '' category: 'Tests-PackageInfo'! !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:23'! setUp super setUp. createdClasses := nil! ! !PackageInfoTest methodsFor: 'running' stamp: 'AlexandreBergel 5/26/2008 22:29'! tearDown super tearDown. createdClasses ifNotNil: [createdClasses do: [:cls | cls removeFromSystem ]]! ! !PackageInfoTest methodsFor: 'util' stamp: 'AlexandreBergel 5/26/2008 22:31'! packageClass ^ PackageInfo! ! !PackageInfoTest methodsFor: 'util' stamp: 'GuillermoPolito 4/27/2012 11:02'! testGatherExtensionsFromSamePackage | extensionMethod | extensionMethod := (Morph>>#clearArea). self assert: (extensionMethod category beginsWith: '*'). self assert: (((PackageInfo named: 'Morphic') extensionMethods collect: #method) includes: extensionMethod)! ! PackageAbstractNodeExample subclass: #PackageMethodCategoryNodeExample instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-MorphTreeWidget-Examples'! !PackageMethodCategoryNodeExample methodsFor: 'accessing' stamp: 'AlainPlantec 2/8/2010 09:39'! childNodeClassFromItem: anItem ^ PackageMethodNodeExample! ! !PackageMethodCategoryNodeExample methodsFor: 'accessing' stamp: 'AlainPlantec 1/29/2010 12:16'! childrenItems ^ self parentNode item methodsInCategory: self item! ! PackageAbstractNodeExample subclass: #PackageMethodNodeExample instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-MorphTreeWidget-Examples'! !PackageMethodNodeExample methodsFor: 'as yet unclassified' stamp: 'StephaneDucasse 10/15/2011 20:57'! browseItem Smalltalk tools browser fullOnClass: self itemClass selector: self selector ! ! !PackageMethodNodeExample methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 1/26/2010 14:03'! compiledMethod ^ self itemClass compiledMethodAt: self selector ifAbsent: [self itemClass class compiledMethodAt: self selector ifAbsent: []]! ! !PackageMethodNodeExample methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 1/26/2010 13:49'! itemClass ^ self parentNode parentNode item. ! ! !PackageMethodNodeExample methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 1/26/2010 13:49'! selector ^ self item! ! PackageAbstractNodeExample subclass: #PackageNodeExample instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-MorphTreeWidget-Examples'! !PackageNodeExample methodsFor: 'accessing' stamp: 'AlainPlantec 1/15/2010 15:15'! asString ^ self item packageName! ! !PackageNodeExample methodsFor: 'nil' stamp: 'AlainPlantec 2/8/2010 09:39'! childNodeClassFromItem: anItem ^ PackageClassNodeExample ! ! !PackageNodeExample methodsFor: 'nil' stamp: 'AlainPlantec 1/29/2010 12:17'! childrenItems ^ self item classes ! ! Object subclass: #PackageOrganizer instanceVariableNames: 'packages' classVariableNames: '' poolDictionaries: '' category: 'PackageInfo-Base'! !PackageOrganizer methodsFor: '*rpackage-core' stamp: 'cyrilledelaunay 1/31/2011 14:50'! packagesDictionary ^ packages! ! !PackageOrganizer methodsFor: 'accessing' stamp: 'avi 11/12/2003 23:01'! packageNames ^ packages keys! ! !PackageOrganizer methodsFor: 'accessing' stamp: 'avi 11/12/2003 23:01'! packages ^ packages values! ! !PackageOrganizer methodsFor: 'cleaning' stamp: 'StephaneDucasse 7/11/2010 22:58'! 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]. ]. self changed: #packages; changed: #packageNames.! ! !PackageOrganizer methodsFor: 'initializing' stamp: 'alain.plantec 5/28/2009 10:13'! initialize super initialize. packages := Dictionary new! ! !PackageOrganizer methodsFor: 'registering' stamp: 'avi 11/12/2003 23:01'! registerPackage: aPackageInfo packages at: aPackageInfo packageName put: aPackageInfo. self changed: #packages; changed: #packageNames. ! ! !PackageOrganizer methodsFor: 'registering' stamp: 'avi 11/12/2003 21:08'! registerPackageNamed: aString ^ self registerPackage: (PackageInfo named: aString)! ! !PackageOrganizer methodsFor: 'registering' stamp: 'avi 11/12/2003 23:08'! unregisterPackage: aPackageInfo packages removeKey: aPackageInfo packageName ifAbsent: []. self changed: #packages; changed: #packageNames. ! ! !PackageOrganizer methodsFor: 'registering' stamp: 'avi 11/12/2003 21:10'! unregisterPackageNamed: aString self unregisterPackage: (self packageNamed: aString ifAbsent: [^ self])! ! !PackageOrganizer methodsFor: 'searching' stamp: 'MarcusDenker 7/12/2012 18:01'! allPackagesContainingUnimplementedCalls "Answer a Set of Packages that have classes which contain messages that have unimplemented calls" ^ (SystemNavigation new allClassesWithUnimplementedCalls keys collect: [:d| (self packageOfClass: d) packageName ]) . ! ! !PackageOrganizer methodsFor: 'searching' stamp: 'stephane.ducasse 9/4/2008 12:50'! mostSpecificPackageOfClass: aClass ^ self mostSpecificPackageOfClass: aClass ifNone: [self noPackageFound]! ! !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: 'searching' stamp: 'stephane.ducasse 9/4/2008 12:50'! mostSpecificPackageOfMethod: aMethodReference ^ self mostSpecificPackageOfMethod: aMethodReference ifNone: [self noPackageFound]! ! !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: 'searching' stamp: 'avi 10/11/2003 14:21'! noPackageFound self error: 'No package found'! ! !PackageOrganizer methodsFor: 'searching' stamp: 'avi 11/12/2003 23:08'! packageNamed: aString ifAbsent: errorBlock ^ packages at: aString ifAbsent: errorBlock! ! !PackageOrganizer methodsFor: 'searching' stamp: 'avi 10/11/2003 14:21'! packageOfClass: aClass ^ self packageOfClass: aClass ifNone: [self noPackageFound]! ! !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: 'avi 10/11/2003 14:21'! packageOfMethod: aMethodReference ^ self packageOfMethod: aMethodReference ifNone: [self noPackageFound]! ! !PackageOrganizer methodsFor: 'searching' stamp: 'avi 10/11/2003 14:22'! packageOfMethod: aMethodReference ifNone: errorBlock ^ self packages detect: [:ea | ea includesMethodReference: aMethodReference] ifNone: errorBlock! ! !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 class instanceVariableNames: 'default'! !PackageOrganizer class methodsFor: 'instance creation' stamp: 'stephaneducasse 2/4/2006 20:40'! default ^ default ifNil: [default := self new]! ! !PackageOrganizer class methodsFor: 'instance creation' stamp: 'avi 10/13/2003 15:25'! new ^ self basicNew initialize! ! AbstractPackageSelectedPlugin subclass: #PackageTasksPlugin instanceVariableNames: 'morph tasks index panel' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Plugin'! !PackageTasksPlugin commentStamp: '' prior: 0! 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: 'announcement' stamp: 'GuillermoPolito 5/2/2012 13:35'! packageSelected: anAnnouncement | package name | 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: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 13:37'! display ^panel! ! !PackageTasksPlugin methodsFor: 'display' stamp: 'GuillermoPolito 5/2/2012 12:38'! index ^index! ! !PackageTasksPlugin methodsFor: 'display' 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: 'display' stamp: 'GuillermoPolito 5/2/2012 13:32'! selectedIndex ^index! ! !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: 'GuillermoPolito 5/2/2012 12:38'! tasks ^tasks! ! !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 class instanceVariableNames: ''! !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! ! MorphTreeModel subclass: #PackageTreeExample instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-MorphTreeWidget-Examples'! !PackageTreeExample commentStamp: '' prior: 0! PackageTreeExample new open! !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 12/15/2009 20:11'! doubleClick self selectedNode ifNotNil: [:n | n doubleClick]! ! !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 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! ! !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 1/29/2010 12:14'! rootItems ^ PackageOrganizer default packages ! ! !PackageTreeExample methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 2/7/2010 22:44'! rootNodeClassFromItem: anItem ^ PackageNodeExample! ! AbstractPackageWidget subclass: #PackageWidget instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Nautilus-Widgets'! !PackageWidget commentStamp: '' prior: 0! PackageWidget is the basic implementation of a wiget managing packages! MorphTreeModel subclass: #PaginatedMorphTreeModel instanceVariableNames: 'pageSize' classVariableNames: '' poolDictionaries: '' category: 'Morphic-MorphTreeWidget-Pagination'! !PaginatedMorphTreeModel methodsFor: 'accessing' stamp: 'AlainPlantec 10/10/2011 11:27'! defaultChunkSize ^ nil! ! !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/10/2011 11:29'! treeMorphClass ^ PaginatedMorphTreeMorph ! ! !PaginatedMorphTreeModel methodsFor: 'pager managing' stamp: 'AlainPlantec 10/10/2011 11:22'! chunkSize ^ pageSize ! ! !PaginatedMorphTreeModel methodsFor: 'pager managing' stamp: 'AlainPlantec 10/10/2011 11:22'! chunkSize: anIntegerOrNil self setPageSize: anIntegerOrNil. self changed: #chunkSize ! ! !PaginatedMorphTreeModel methodsFor: 'pager managing' stamp: 'AlainPlantec 10/10/2011 11:27'! defaultPageSize ^ nil! ! !PaginatedMorphTreeModel methodsFor: 'pager managing' stamp: 'AlainPlantec 10/10/2011 11:22'! pageSize ^ pageSize ! ! !PaginatedMorphTreeModel methodsFor: 'pager managing' stamp: 'AlainPlantec 10/10/2011 11:23'! pageSize: anIntegerOrNil self setPageSize: anIntegerOrNil. self changed: #pageSize ! ! !PaginatedMorphTreeModel methodsFor: 'pager managing' stamp: 'AlainPlantec 10/10/2011 11:22'! setPageSize: anIntegerOrNil pageSize := anIntegerOrNil. ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PaginatedMorphTreeModel class instanceVariableNames: ''! !PaginatedMorphTreeModel class methodsFor: 'examples' stamp: 'ThierryGoubier 2/10/2013 21: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 changed: #(#rootNodes #openItemPath 40). self assert: treeMorph pager currentPage == 2! ! MorphTreeMorph subclass: #PaginatedMorphTreeMorph instanceVariableNames: 'pager' classVariableNames: '' poolDictionaries: '' category: 'Morphic-MorphTreeWidget-Pagination'! !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: '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: 'geometry' stamp: 'AlainPlantec 10/10/2011 11:08'! extent: newExtent self extent = newExtent ifTrue: [^ self]. super extent: newExtent. self updatePager. ! ! !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: 'geometry' stamp: 'AlainPlantec 10/10/2011 11:06'! innerBounds | inner | inner := super innerBounds. inner := inner withBottom: inner bottom - self pagerHeight. ^ inner! ! !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'! addNavigationPane: aNavigPane pager := aNavigPane. self addMorph: pager. pager buildPanel. self updatePager. self changed! ! !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'! 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:55'! pager ^ pager ! ! !PaginatedMorphTreeMorph methodsFor: 'pager managing' stamp: 'AlainPlantec 10/10/2011 11:12'! pagerColor ^ self color darker alpha: 0.6! ! !PaginatedMorphTreeMorph methodsFor: 'pager managing' stamp: 'AlainPlantec 10/10/2011 10:55'! pagerHeight ^ self pager ifNil: [0] ifNotNil: [pager computedHeight]! ! !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]. ! ! !PaginatedMorphTreeMorph methodsFor: 'pager managing' stamp: 'AlainPlantec 10/10/2011 10:58'! updatePager self pager ifNotNil: [self pager buildPanel]! ! !PaginatedMorphTreeMorph methodsFor: 'scrolling' stamp: 'AlainPlantec 10/10/2011 10:56'! vScrollBarValue: scrollValue super vScrollBarValue: scrollValue. self pager ifNotNil: [:p | p vScrollBarValue: scrollValue]! ! !PaginatedMorphTreeMorph methodsFor: 'updating' stamp: 'AlainPlantec 10/10/2011 11:07'! buildContents super buildContents. self updatePager! ! !PaginatedMorphTreeMorph methodsFor: 'updating' stamp: 'ThierryGoubier 2/8/2013 16:25'! update: aSymbol aSymbol == #pageSize ifTrue: [ ^ self pageSize: model pageSize ]. aSymbol == #chunkSize ifTrue: [ ^ self chunkSize: model chunkSize ]. ((aSymbol isKindOf: Array) and: [ aSymbol size > 1 and: [ aSymbol first == self nodeListSelector and: [ aSymbol second == #openItemPath ] ] ]) ifTrue: [ | rest | rest := aSymbol allButFirst: 2. [ rest notEmpty ] whileTrue: [ | i 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 ]. "allow directed path opening where multiple trees exist" ^ super update: aSymbol! ! !PaginatedMorphTreeMorph methodsFor: 'updating' stamp: 'AlainPlantec 10/10/2011 11:08'! updateContentsWithPreviouslyExpanded: aNodeList super updateContentsWithPreviouslyExpanded: aNodeList. self updatePager! ! TestCase subclass: #PaginatedMorphTreeMorphTests instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Widgets'! !PaginatedMorphTreeMorphTests methodsFor: 'tests' stamp: 'ThierryGoubier 2/10/2013 21:03'! testChunkPager "This test demonstrate a paginating morphTreeMorph in action." "self testExample." | treeMorph aWindow aModel | aModel := PaginatedMorphTreeModel itemsList: (1 to: 100) asArray. aWindow := aModel theme newWindowIn: World for: aModel title: 'test'. treeMorph := aModel defaultTreeMorph. treeMorph chunkSize: 30. treeMorph buildContents. aWindow addMorph: treeMorph fullFrame: (LayoutFrame fractions: (0 @ 0 corner: 1 @ 1) offsets: (0 @ 0 corner: 0 @ 0)). aWindow open. aModel changed: #(#rootNodes #openItemPath 40). self assert: treeMorph pager lastIndex == 40. aWindow close! ! !PaginatedMorphTreeMorphTests methodsFor: 'tests' stamp: 'ThierryGoubier 2/10/2013 21:00'! testPager "This test demonstrate a paginating morphTreeMorph in action." "self testExample." | 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 changed: #(#rootNodes #openItemPath 40). self assert: treeMorph pager currentPage == 2. aWindow close! ! BorderedMorph subclass: #PanelMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !PanelMorph commentStamp: 'gvc 5/18/2007 12:38' prior: 0! 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: '*Spec-Layout' stamp: 'BenjaminVanRyseghem 7/31/2012 18:08'! checkSplitters | size | size := submorphs size. (self submorphsSatisfying: [:e | e isKindOf: ProportionalSplitterMorph ]) do: [:e || index idx | index := submorphs identityIndexOf: e. idx := index + 1. "above" [ idx <= size and: [ ((submorphs at: idx) isKindOf: ProportionalSplitterMorph) not ]] whileTrue: [ e addLeftOrTop: (submorphs at: idx). idx := idx +1 ]. idx := index - 1. "below" [ idx > 0 and: [ ((submorphs at: idx) isKindOf: ProportionalSplitterMorph) not ]] whileTrue: [ e addRightOrBottom: (submorphs at: idx). idx := idx -1 ]]! ! !PanelMorph methodsFor: '*Spec-Layout' stamp: 'BenjaminVanRyseghem 7/31/2012 15:47'! newHSplitter ^ ProportionalSplitterMorph new beSplitsTopAndBottom; setProperty: #model toValue: self.! ! !PanelMorph methodsFor: '*Spec-Layout' 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-Layout' stamp: 'BenjaminVanRyseghem 7/31/2012 15:47'! newVSplitter ^ ProportionalSplitterMorph new setProperty: #model toValue: self.! ! !PanelMorph methodsFor: '*Spec-Layout' 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: '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: '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: '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: 'initialization' stamp: 'gvc 7/26/2006 17:31'! defaultBorderWidth "Answer the default border width for the receiver." ^0! ! !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: 'initialize' stamp: 'gvc 7/27/2006 10:36'! defaultColor "Answer the default color for the receiver." ^Color transparent! ! !PanelMorph methodsFor: 'protocol' stamp: 'gvc 8/20/2009 15:49'! enabled: aBoolean "Pass on to submorphs." self submorphsDo: [:m | (m respondsTo: #enabled:) ifTrue: [ m enabled: aBoolean]]! ! !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: '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 subclass: #PanelMorphWithSplitters instanceVariableNames: 'paneMorphs' classVariableNames: '' poolDictionaries: '' category: 'Spec-Widgets-Utilities'! !PanelMorphWithSplitters commentStamp: '' prior: 0! A PanelMorphWithSplitters is which add splitters the way SystemWindow do it! !PanelMorphWithSplitters methodsFor: 'initialization'! initialize "Initialization code for PanelMorphWithSplitter" super initialize. paneMorphs := OrderedCollection new.! ! !PanelMorphWithSplitters methodsFor: 'layout-properties'! layoutFrame: aFrame self activate. super layoutFrame: aFrame! ! !PanelMorphWithSplitters methodsFor: 'submorphs-add/remove' stamp: 'BenjaminVanRyseghem 3/23/2012 17:00'! addMorph: aMorph paneMorphs add: aMorph. ^ super addMorph: aMorph! ! !PanelMorphWithSplitters methodsFor: 'submorphs-add/remove'! addMorph: aMorph fullFrame: aLayout paneMorphs add: aMorph. super addMorph: aMorph fullFrame: aLayout! ! !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: 'private'! 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: '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: '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: 'private'! 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'! 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.]! ! Object subclass: #Paragraph instanceVariableNames: 'text textStyle firstCharacterIndex container lines positionWhenComposed offsetToEnd maxRightX selectionStart selectionStop wantsColumnBreaks focused caretRect showCaret findReplaceSelectionRegex secondarySelection extraSelectionBlocks refreshExtraSelection composer' classVariableNames: 'InsertionPointColor' poolDictionaries: '' category: 'Morphic-Text Support'! !Paragraph commentStamp: 'AlainPlantec 9/15/2011 16:13' prior: 0! 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: '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: '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: 'access' stamp: 'AlainPlantec 10/24/2010 14:30'! caretWidth ^ Editor dumbbellCursor ifTrue: [ 2 ] ifFalse: [ 0 ]! ! !Paragraph methodsFor: 'access' stamp: 'AlainPlantec 9/15/2011 17:15'! composer ^ composer ifNil: [composer := TextComposer new]! ! !Paragraph methodsFor: 'access' stamp: 'di 10/24/97 17:38'! extent ^ container width @ (lines last bottom - lines first top)! ! !Paragraph methodsFor: 'access' stamp: 'di 11/8/97 15:41'! firstCharacterIndex ^ firstCharacterIndex! ! !Paragraph methodsFor: 'access' stamp: 'AlainPlantec 11/17/2010 22:58'! focused ^ focused ifNil: [focused := false] ! ! !Paragraph methodsFor: 'access' stamp: 'rr 3/22/2004 12:41'! focused: aBoolean focused := aBoolean! ! !Paragraph methodsFor: 'access' stamp: 'di 10/23/97 21:01'! lastCharacterIndex ^ lines last last! ! !Paragraph methodsFor: 'access' stamp: 'FernandoOlivero 6/18/2011 18:38'! maxRightX ^ maxRightX! ! !Paragraph methodsFor: 'access' stamp: 'sbw 10/13/1999 22:31'! numberOfLines ^lines size! ! !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 methodsFor: 'access' stamp: 'tbn 8/5/2009 09:51'! showCaret: aBool showCaret := aBool ! ! !Paragraph methodsFor: 'access' stamp: 'sw 1/13/98 21:31'! string ^ text string! ! !Paragraph methodsFor: 'access' stamp: 'di 10/21/97 14:39'! text ^ text! ! !Paragraph methodsFor: 'access' stamp: 'jm 11/19/97 20:27'! textOwner: ignored "See TextOnCurve"! ! !Paragraph methodsFor: 'access' stamp: 'di 10/21/97 14:39'! textStyle ^ textStyle! ! !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: 'access' stamp: 'FernandoOlivero 4/12/2011 10:01'! theme ^ UITheme current! ! !Paragraph methodsFor: 'access' stamp: 'RAA 5/6/2001 15:04'! wantsColumnBreaks ^wantsColumnBreaks! ! !Paragraph methodsFor: 'access' stamp: 'RAA 5/6/2001 15:03'! wantsColumnBreaks: aBoolean wantsColumnBreaks := aBoolean! ! !Paragraph methodsFor: 'alignment' stamp: 'di 10/25/97 19:26'! centered textStyle centered! ! !Paragraph methodsFor: 'alignment' stamp: 'di 10/25/97 19:26'! justified textStyle justified! ! !Paragraph methodsFor: 'alignment' stamp: 'di 10/25/97 19:26'! leftFlush textStyle leftFlush! ! !Paragraph methodsFor: 'alignment' stamp: 'di 10/25/97 19:26'! rightFlush textStyle rightFlush! ! !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: 'di 11/15/97 09:21'! composeAllStartingAt: characterIndex firstCharacterIndex := characterIndex. offsetToEnd := text size - firstCharacterIndex. self composeAll! ! !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: 'composition' stamp: 'di 10/22/97 11:13'! compositionRectangle ^ container! ! !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: '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: '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'! 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: '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: '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: '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: '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: 'editing' stamp: 'CamilloBruni 2/6/2012 23:29'! actionAttributesUnder: aClickPoint event: anEvent do: aBlock |startBlock| startBlock := self characterBlockAtPoint: aClickPoint. (text attributesAt: startBlock stringIndex forStyle: textStyle) select: [ :attribute| attribute mayActOnEvent: anEvent ] thenDo: [:attribute | | target 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] ifNone: [nil]) ifNotNil: [ aBlock cull: attribute cull: boxes ]]! ! !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: '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: '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: '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: 'initialization' stamp: 'alain.plantec 5/28/2009 10:12'! initialize super initialize. self positionWhenComposed: 0 @ 0! ! !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: 'selection' stamp: 'ar 4/12/2005 19:53'! characterBlockAtPoint: aPoint "Answer a CharacterBlock for the character in the text at aPoint." | line | line := lines at: (self lineIndexForPoint: aPoint). ^ ((text string isWideString) ifTrue: [ MultiCharacterBlockScanner new text: text textStyle: textStyle ] ifFalse: [CharacterBlockScanner new text: text textStyle: textStyle]) characterBlockAtPoint: aPoint index: nil in: line! ! !Paragraph methodsFor: 'selection' stamp: 'ar 4/12/2005 19:53'! characterBlockForIndex: index "Answer a CharacterBlock for the character in text at index." | line | line := lines at: (self lineIndexForCharacter: index). ^ ((text string isWideString) ifTrue: [ MultiCharacterBlockScanner new text: text textStyle: textStyle ] ifFalse: [ CharacterBlockScanner new text: text textStyle: textStyle ]) characterBlockAtPoint: nil index: ((index max: line first) min: text size+1) in: line! ! !Paragraph methodsFor: 'selection' stamp: 'jm 11/19/97 22:56'! containsPoint: aPoint ^ (lines at: (self lineIndexForPoint: aPoint)) rectangle containsPoint: aPoint! ! !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: 'selection' stamp: 'AlainPlantec 9/15/2011 15:57'! extraSelectionChanged refreshExtraSelection := true! ! !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: 'selection' stamp: 'AlainPlantec 9/15/2011 15:57'! findReplaceSelectionColor ^ self theme currentSettings findReplaceSelectionColor ! ! !Paragraph methodsFor: 'selection' stamp: 'AlainPlantec 9/15/2011 15:57'! findReplaceSelectionRegex: aRegex findReplaceSelectionRegex := aRegex. ! ! !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: 'AlainPlantec 9/15/2011 15:57'! secondarySelection: aSubString secondarySelection := aSubString. ! ! !Paragraph methodsFor: 'selection' stamp: 'AlainPlantec 9/15/2011 15:57'! secondarySelectionColor ^ self theme currentSettings secondarySelectionColor ! ! !Paragraph methodsFor: 'selection' stamp: 'AlainPlantec 9/15/2011 15:57'! selectionBarColor ^ self theme selectionBarColor! ! !Paragraph methodsFor: 'selection' stamp: 'FernandoOlivero 4/12/2011 10:11'! selectionColor ^ self focused ifTrue: [self theme selectionColor] ifFalse: [self theme unfocusedSelectionColor]. ! ! !Paragraph methodsFor: 'selection' stamp: 'IgorStasenko 1/14/2011 13:44'! selectionColor: aColor "ignored"! ! !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: '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: 'selection' stamp: 'ls 11/2/2001 23:10'! 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 corner: cb2 bottomLeft). ^ rects! ! !Paragraph methodsFor: 'selection' stamp: 'di 12/2/97 19:57'! selectionStart: startBlock selectionStop: stopBlock selectionStart := startBlock. selectionStop := stopBlock.! ! !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: '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: 'private' stamp: 'di 11/8/97 15:47'! adjustLineIndicesBy: delta firstCharacterIndex := firstCharacterIndex + delta. lines do: [:line | line slide: delta]. ! ! !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: '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: '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: '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: '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: '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/24/97 17:40'! lines ^ lines! ! !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: 'di 10/21/97 21:36'! positionWhenComposed: pos positionWhenComposed := pos! ! !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 class instanceVariableNames: ''! !Paragraph class methodsFor: 'settings' stamp: 'AlainPlantec 12/19/2009 23:46'! insertionPointColor ^ InsertionPointColor ifNil: [InsertionPointColor := (TranslucentColor r: 0.0 g: 0.0 b: 0.8 alpha: 0.8)]! ! !Paragraph class methodsFor: 'settings' stamp: 'AlainPlantec 12/19/2009 23:46'! insertionPointColor: aColor InsertionPointColor := aColor! ! Object subclass: #ParagraphSelectionBlock instanceVariableNames: 'first last color' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Text Support'! !ParagraphSelectionBlock methodsFor: 'accessing' stamp: 'AlainPlantec 11/13/2010 09:13'! first ^ first! ! !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: 'initialize-release' stamp: 'AlainPlantec 11/13/2010 08:42'! first: firstCharBlock last: lastCharBlock color: aColor first := firstCharBlock. last := lastCharBlock. color := aColor! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ParagraphSelectionBlock class instanceVariableNames: ''! !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! ! Object subclass: #ParseNode instanceVariableNames: 'comment pc' classVariableNames: 'Bfp BtpLong CodeBases CodeLimits DblExtDoAll Dup EndMethod EndRemote Jmp JmpLimit JmpLong LdFalse LdInstLong LdInstType LdLitIndType LdLitType LdMinus1 LdNil LdSelf LdSuper LdTempType LdThisContext LdTrue LoadLong LongLongDoAll NodeFalse NodeNil NodeSelf NodeSuper NodeThisContext NodeTrue Pop Send SendLimit SendLong SendLong2 SendPlus SendType ShortStoP StdLiterals StdSelectors StdVariables Store StorePop' poolDictionaries: 'TextConstants' category: 'Compiler-ParseNodes'! !ParseNode commentStamp: '' prior: 0! 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: '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: '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:38'! emitCodeForEffect: stack encoder: encoder self emitCodeForValue: stack encoder: encoder. encoder genPop. stack pop: 1! ! !ParseNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 16:39'! emitCodeForJump: dist encoder: encoder dist = 0 ifFalse: [encoder genJump: 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: 'code generation' stamp: 'nk 7/10/2004 10:04'! pc "Used by encoder source mapping." ^pc ifNil: [ 0 ] ! ! !ParseNode methodsFor: 'code generation' stamp: 'eem 8/4/2008 13:57'! pc: anInteger "Used by encoder source mapping." pc := anInteger! ! !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/15/2008 09:52'! sizeCode: encoder forJump: dist ^dist = 0 ifTrue: [0] ifFalse: [encoder sizeJump: dist]! ! !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: 'code generation' stamp: 'eem 5/14/2008 16:53'! sizeCodeForEffect: encoder ^(self sizeCodeForValue: encoder) + encoder sizePop! ! !ParseNode methodsFor: 'code generation' stamp: 'eem 5/14/2008 16:57'! sizeCodeForReturn: encoder ^(self sizeCodeForValue: encoder) + encoder sizeReturnTop! ! !ParseNode methodsFor: 'comment'! comment ^comment! ! !ParseNode methodsFor: 'comment'! comment: newComment comment := newComment! ! !ParseNode methodsFor: 'converting'! asReturnNode ^ReturnNode new expr: self! ! !ParseNode methodsFor: 'encoding'! encodeSelector: selector ^nil! ! !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: 'printing' stamp: 'NikoSchwarz 6/5/2010 17:48'! printAsIfCompiledOn: aStream "Refer to the comment in Object|printOn:." self printOn: aStream indent: 0. ! ! !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: '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: 'printing'! printOn: aStream indent: anInteger "If control gets here, avoid recursion loop." super printOn: aStream! ! !ParseNode methodsFor: 'printing'! printOn: aStream indent: level precedence: p self printOn: aStream indent: level! ! !ParseNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:51'! printWithClosureAnalysis ^String streamContents: [:str| self printWithClosureAnalysisOn: str]! ! !ParseNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! printWithClosureAnalysisOn: aStream "Refer to the comment in Object|printOn:." aStream nextPut: ${. self printWithClosureAnalysisOn: aStream indent: 0. aStream nextPut: $}.! ! !ParseNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! printWithClosureAnalysisOn: aStream indent: anInteger "If control gets here, avoid recursion loop." super printWithClosureAnalysisOn: aStream! ! !ParseNode methodsFor: 'printing' stamp: 'eem 6/2/2008 11:47'! printWithClosureAnalysisOn: aStream indent: level precedence: p self printWithClosureAnalysisOn: aStream indent: level! ! !ParseNode methodsFor: 'printing' stamp: 'ms 8/1/2006 16:47'! shortPrintOn: aStream self printOn: aStream indent: 0! ! !ParseNode methodsFor: 'testing'! 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'! canCascade ^false! ! !ParseNode methodsFor: 'testing' stamp: 'eem 2/3/2011 09:12'! ensureCanCascade: encoder! ! !ParseNode methodsFor: 'testing'! isArg ^false! ! !ParseNode methodsFor: 'testing' stamp: 'eem 6/16/2008 09:37'! isAssignmentNode ^false! ! !ParseNode methodsFor: 'testing' stamp: 'eem 9/25/2008 12:11'! isBlockNode ^false! ! !ParseNode methodsFor: 'testing'! isComplex "Used for pretty printing to determine whether to start a new line" ^false! ! !ParseNode methodsFor: 'testing'! isConstantNumber "Overridden in LiteralNode" ^false! ! !ParseNode methodsFor: 'testing' stamp: 'md 1/20/2006 16:22'! isDoIt "polymorphic with RBNodes; called by debugger" ^ false! ! !ParseNode methodsFor: 'testing' stamp: 'ls 1/29/2004 21:11'! isJust: node ^false! ! !ParseNode methodsFor: 'testing' stamp: 'di 4/5/2000 11:14'! isLiteral ^ false! ! !ParseNode methodsFor: 'testing' stamp: 'md 7/27/2006 19:14'! isMessage ^false! ! !ParseNode methodsFor: 'testing'! isMessage: selSymbol receiver: rcvrPred arguments: argsPred "See comment in MessageNode." ^false! ! !ParseNode methodsFor: 'testing' stamp: 'John M McIntosh 3/2/2009 19:58'! isMessageNode ^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: 'testing'! isReturnSelf ^false! ! !ParseNode methodsFor: 'testing'! isReturningIf ^false! ! !ParseNode methodsFor: 'testing' stamp: 'tk 8/2/1999 18:39'! isSelfPseudoVariable "Overridden in VariableNode." ^false! ! !ParseNode methodsFor: 'testing'! isSpecialConstant ^ false! ! !ParseNode methodsFor: 'testing' stamp: 'di 10/12/1999 15:28'! isTemp ^ false! ! !ParseNode methodsFor: 'testing'! isUndefTemp ^ false! ! !ParseNode methodsFor: 'testing'! isUnusedTemp ^ false! ! !ParseNode methodsFor: 'testing' stamp: 'ar 11/19/2002 14:58'! isVariableNode ^false! ! !ParseNode methodsFor: 'testing'! isVariableReference ^false! ! !ParseNode methodsFor: 'testing'! nowHasDef "Ignored in all but VariableNode"! ! !ParseNode methodsFor: 'testing'! nowHasRef "Ignored in all but VariableNode"! ! !ParseNode methodsFor: 'testing'! toDoIncrement: ignored "Only meant for Messages or Assignments - else return nil" ^ nil! ! !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: 'visiting' stamp: 'eem 7/20/2009 19:44'! nodesDo: aBlock self accept: (ParseNodeEnumerator ofBlock: aBlock)! ! !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: '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: '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 class instanceVariableNames: ''! !ParseNode class methodsFor: 'accessing' stamp: 'ajh 8/12/2002 11:10'! blockReturnCode ^ EndRemote! ! !ParseNode class methodsFor: 'accessing' stamp: 'ajh 8/6/2002 12:04'! popCode ^ Pop! ! !ParseNode class methodsFor: 'accessing' stamp: 'eem 5/21/2008 13:18'! pushNilCode ^LdNil! ! !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"! ! !ParseNode class methodsFor: 'class initialization'! 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! ! ParseNodeVisitor subclass: #ParseNodeEnumerator instanceVariableNames: 'theBlock theSelectBlock' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Support'! !ParseNodeEnumerator commentStamp: 'eem 8/31/2010 11:41' prior: 0! 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: 'initialize-release' stamp: 'eem 7/20/2009 19:44'! ofBlock: aBlock theBlock := aBlock! ! !ParseNodeEnumerator methodsFor: 'initialize-release' stamp: 'eem 8/31/2010 11:24'! ofBlock: aBlock select: aSelectBlock theBlock := aBlock. theSelectBlock := aSelectBlock! ! !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'! 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'! 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'! 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'! visitCommentNode: aCommentNode (theSelectBlock isNil or: [theSelectBlock value: aCommentNode]) ifFalse: [^nil]. theBlock value: aCommentNode. ^super visitCommentNode: aCommentNode! ! !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'! visitFutureNode: aFutureNode (theSelectBlock isNil or: [theSelectBlock value: aFutureNode]) ifFalse: [^nil]. theBlock value: aFutureNode. ^super visitFutureNode: aFutureNode! ! !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'! visitLiteralNode: aLiteralNode (theSelectBlock isNil or: [theSelectBlock value: aLiteralNode]) ifFalse: [^nil]. theBlock value: aLiteralNode. ^super visitLiteralNode: aLiteralNode! ! !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'! 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'! 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'! visitNewArrayNode: aNewArrayNode (theSelectBlock isNil or: [theSelectBlock value: aNewArrayNode]) ifFalse: [^nil]. theBlock value: aNewArrayNode. ^super visitNewArrayNode: aNewArrayNode! ! !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'! visitReturnNode: aReturnNode (theSelectBlock isNil or: [theSelectBlock value: aReturnNode]) ifFalse: [^nil]. theBlock value: aReturnNode. ^super visitReturnNode: aReturnNode! ! !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'! visitTempVariableNode: aTempVariableNode (theSelectBlock isNil or: [theSelectBlock value: aTempVariableNode]) ifFalse: [^nil]. theBlock value: aTempVariableNode. ^super visitTempVariableNode: aTempVariableNode! ! !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 class instanceVariableNames: ''! !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! ! Object subclass: #ParseNodeVisitor instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Support'! !ParseNodeVisitor commentStamp: '' prior: 0! 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 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 9/10/2008 15:13'! visitBlockNode: aBlockNode aBlockNode statements do: [:statement| statement accept: self]! ! !ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 9/10/2008 15:14'! visitBraceNode: aBraceNode aBraceNode elements do: [:element| element accept: self]! ! !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'! visitCommentNode: aCommentNode! ! !ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 5/30/2008 10:07'! visitFieldNode: aFieldNode! ! !ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 5/30/2008 10:07'! visitInstanceVariableNode: anInstanceVariableNode! ! !ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 5/30/2008 10:07'! visitLiteralNode: aLiteralNode! ! !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 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'! visitMethodNode: aMethodNode aMethodNode block accept: self! ! !ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 5/30/2008 10:07'! visitNewArrayNode: aNewArrayNode! ! !ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 5/30/2008 10:07'! visitRemoteTempVectorNode: aRemoteTempVectorNode! ! !ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 9/10/2008 15:53'! visitReturnNode: aReturnNode aReturnNode expr accept: self! ! !ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 5/30/2008 10:07'! visitSelectorNode: aSelectorNode! ! !ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 5/30/2008 10:07'! visitTempVariableNode: aTempVariableNode! ! !ParseNodeVisitor methodsFor: 'visiting' stamp: 'eem 5/30/2008 10:32'! visitVariableNode: aVariableNode! ! Object subclass: #ParseStack instanceVariableNames: 'position length' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Support'! !ParseStack commentStamp: '' prior: 0! I keep track of the current and high position of the stack that will be needed by code being compiled.! !ParseStack methodsFor: 'accessing'! pop: n (position := position - n) < 0 ifTrue: [self error: 'Parse stack underflow']! ! !ParseStack methodsFor: 'accessing' stamp: 'eem 9/12/2008 10:31'! position: n (position := n) > length ifTrue: [length := position]! ! !ParseStack methodsFor: 'accessing'! push: n (position := position + n) > length ifTrue: [length := position]! ! !ParseStack methodsFor: 'accessing'! size ^length! ! !ParseStack methodsFor: 'initialization'! init length := position := 0! ! !ParseStack methodsFor: 'printing'! printOn: aStream super printOn: aStream. aStream nextPutAll: ' at '; print: position; nextPutAll: ' of '; print: length! ! !ParseStack methodsFor: 'results'! position ^position! ! Scanner subclass: #Parser instanceVariableNames: 'here hereType hereMark hereEnd prevMark prevEnd encoder requestor parseNode failBlock requestorOffset tempsMark doitFlag properties category' classVariableNames: 'AllowBlockArgumentAssignment Warns' poolDictionaries: '' category: 'Compiler-Kernel'! !Parser commentStamp: '' prior: 0! I parse Smalltalk syntax and create a MethodNode that is the root of the parse tree. I look one token ahead.! !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: 'error correction' stamp: 'cwp 10/15/2007 23:00'! canDeclareClassVariable ^encoder classEncoding ~~ UndefinedObject! ! !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: '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: '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: '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: '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: '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: 'error correction' stamp: 'SeanDeNigris 12/8/2011 15:26'! 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 evaluatorClass evaluate: classDefinition. ^ encoder global: (Smalltalk globals associationAt: classSymbol) name: classSymbol! ! !Parser methodsFor: 'error correction' stamp: 'cwp 10/15/2007 22:58'! possibleVariablesFor: proposedVariable ^encoder possibleVariablesFor: proposedVariable! ! !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: '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 correction'! 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: '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: 'error correction'! 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: 'error handling' stamp: 'eem 5/14/2008 13:34'! addWarning: aString "ignored by the default compiler."! ! !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 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: 'error handling' stamp: 'pavel.krivanek 11/21/2008 16:57'! interactive ^ UIManager default interactiveParserFor: requestor! ! !Parser methodsFor: 'error handling'! notify: aString "Notify problem at token before 'here'." ^self notify: aString at: prevMark + requestorOffset! ! !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: '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: 'expression types'! argumentName hereType == #word ifFalse: [^self expected: 'Argument name']. ^self advance! ! !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 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: '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: '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: '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: '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: '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: 'expression types' stamp: 'eem 5/29/2008 09:36'! newMethodNode ^self encoder methodNodeClass new! ! !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: '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 11:51'! statements: argNodes innerBlock: inner ^self statements: argNodes innerBlock: inner blockNode: BlockNode new! ! !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: '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: '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: '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: '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: 'pragmas' stamp: 'eem 11/29/2008 16:44'! addPragma: aPragma properties := properties copyWith: aPragma! ! !Parser methodsFor: 'pragmas' stamp: 'jb 7/1/2011 10:53'! pragmaLiteral "Read a pragma literal." (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 evaluatorClass evaluate: self advance ]. ^ self expected: 'Literal constant'! ! !Parser methodsFor: 'pragmas' stamp: 'jb 7/1/2011 10:53'! 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 evaluatorClass 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: '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: '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: '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: 'pragmas' stamp: 'StephaneDucasse 6/2/2010 09:58'! properties ^ properties ifNil: [ properties := AdditionalMethodState new ]! ! !Parser methodsFor: 'primitives'! allocateLiteral: lit encoder litIndex: lit! ! !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: '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: 'primitives' stamp: 'lr 9/29/2010 08:12'! primitive: anIntegerOrString "Create indexed primitive." ^self primitive: anIntegerOrString error: nil! ! !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: '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: 'primitives' stamp: 'lr 9/29/2010 08:12'! primitive: aNameString module: aModuleStringOrNil "Create named primitive." ^self primitive: aNameString module: aModuleStringOrNil error: nil! ! !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: 'public access' stamp: 'nice 8/27/2010 20:54'! encoder ^encoder ifNil: [encoder := EncoderForV3PlusClosures new]! ! !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: '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: '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: '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: 'public access' stamp: 'eem 5/6/2008 13:42'! parseArgsAndTemps: aString notifying: req "Parse the argument, aString, notifying req if an error occurs. Otherwise, answer a two-element Array containing Arrays of strings (the argument names and temporary variable names)." aString == nil ifTrue: [^#()]. doitFlag := false. "Don't really know if a doit or not!!" ^self initPattern: aString notifying: req return: [:pattern | (pattern at: 2) , (self temporariesIn: (pattern at: 1))]! ! !Parser methodsFor: 'public access'! parseMethodComment: aString setPattern: aBlock "Answer the method comment for the argument, aString. Evaluate aBlock with the message pattern in the form #(selector, arguments, precedence)." self initPattern: aString notifying: nil return: aBlock. currentComment==nil ifTrue: [^OrderedCollection new] ifFalse: [^currentComment]! ! !Parser methodsFor: 'public access' stamp: 'nice 12/25/2009 19:14'! parseParameterNames: aString "Answer the parameter names 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: 2]! ! !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: 'public access' stamp: 'md 1/20/2006 16:31'! parse: sourceStream class: class noPattern: noPattern notifying: req ifFail: aBlock ^ self parse: sourceStream class: class noPattern: noPattern context: nil notifying: req ifFail: aBlock! ! !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: 'scanning' stamp: 'hmm 7/16/2001 19:23'! endOfLastToken ^ prevEnd ifNil: [mark]! ! !Parser methodsFor: 'scanning'! match: type "Answer with true if next tokens type matches." hereType == type ifTrue: [self advance. ^true]. ^false! ! !Parser methodsFor: 'scanning' stamp: 'di 6/7/2000 08:44'! matchReturn ^ self match: #upArrow! ! !Parser methodsFor: 'scanning'! matchToken: thing "Matches the token, not its type." here = thing ifTrue: [self advance. ^true]. ^false! ! !Parser methodsFor: 'scanning'! startOfNextToken "Return starting position in source of next token." hereType == #doIt ifTrue: [^source position + 1]. ^hereMark! ! !Parser methodsFor: 'temps'! bindArg: name ^ self bindTemp: name! ! !Parser methodsFor: 'temps'! bindTemp: name ^name! ! !Parser methodsFor: 'temps' stamp: 'eem 5/13/2008 12:17'! bindTemp: name in: methodSelector ^name! ! !Parser methodsFor: 'private'! addComment parseNode ~~ nil ifTrue: [parseNode comment: currentComment. currentComment := nil]! ! !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: '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: 'private' stamp: 'AlainPlantec 12/4/2009 08:56'! warns "return whether the parser will ask the user for correction" ^ self class warningAllowed! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Parser class instanceVariableNames: ''! !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 ]! ! !Parser class methodsFor: 'setting' stamp: 'AlainPlantec 12/4/2009 07:17'! allowBlockArgumentAssignment ^ AllowBlockArgumentAssignment ifNil: [AllowBlockArgumentAssignment := false]! ! !Parser class methodsFor: 'setting' stamp: 'AlainPlantec 12/4/2009 07:17'! allowBlockArgumentAssignment: aBoolean AllowBlockArgumentAssignment := aBoolean! ! !Parser class methodsFor: 'setting' stamp: 'StephaneDucasse 3/3/2010 13:39'! doNotWarnUser "Do not ask the user for certain situation such as use of undefined variables" Warns := false.! ! !Parser class methodsFor: 'setting' stamp: 'StephaneDucasse 3/3/2010 13:39'! silent "Do not ask the user for certain situation such as use of undefined variables" Warns := false.! ! !Parser class methodsFor: 'setting' stamp: 'StephaneDucasse 3/3/2010 13:40'! warnUser "Ask the user for certain situation such as use of undefined variables" Warns := true. ! ! !Parser class methodsFor: 'setting' stamp: 'AlainPlantec 12/4/2009 07:20'! warningAllowed "Ask the user for certain situation such as use of undefined variables" ^ Warns ifNil: [Warns := false] ! ! !Parser class methodsFor: 'setting' stamp: 'AlainPlantec 12/4/2009 07:19'! warningAllowed: aBoolean "Ask the user for certain situation such as use of undefined variables" Warns := aBoolean. ! ! Notification subclass: #ParserNotification instanceVariableNames: 'name' classVariableNames: '' poolDictionaries: '' category: 'Compiler-Exceptions'! !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 methodsFor: 'as yet unclassified' stamp: 'cwp 10/17/2007 21:36'! openMenuIn: aBlock self subclassResponsibility! ! !ParserNotification methodsFor: 'as yet unclassified' stamp: 'cwp 10/17/2007 23:29/eem 9/5/2009 11:10 - => :='! setName: aString name := aString! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ParserNotification class instanceVariableNames: ''! !ParserNotification class methodsFor: 'as yet unclassified' stamp: 'cwp 10/17/2007 23:31'! name: aString ^ (self new setName: aString) signal! ! Object subclass: #Password instanceVariableNames: 'cache sequence' classVariableNames: '' poolDictionaries: '' category: 'Network-Kernel'! !Password commentStamp: '' prior: 0! "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/3/98 21:36'! cache: anObject cache := anObject! ! !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: 'mir 6/29/2001 01:01'! sequence ^sequence! ! !Password methodsFor: 'accessing' stamp: 'tk 1/5/98 21:14'! sequence: anNumber sequence := anNumber! ! !Password methodsFor: 'as yet unclassified' 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: 'as yet unclassified' 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 class instanceVariableNames: ''! !Password class methodsFor: 'as yet unclassified' 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].! ! TextEntryDialogWindow subclass: #PasswordDialogWindow instanceVariableNames: 'textEditor showPassword' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Windows'! !PasswordDialogWindow commentStamp: 'LaurentLaffont 4/15/2011 20:17' prior: 0! 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: '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: 'protocol' stamp: 'BenjaminVanRyseghem 5/4/2012 22:43'! beDecrypted textEditor font: self theme textFont! ! !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:48'! showPassword ^ showPassword ifNil: [ showPassword := false ]! ! !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: 'private' stamp: 'BenjaminVanRyseghem 5/4/2012 22:52'! showPasswordButton ^ (CheckboxMorph on: self selected: #showPassword changeSelected: #showPassword:) label: 'Show password'; labelClickable: true; height: 25.! ! TextEntryDialogWindow subclass: #PasswordInitializationDialogWindow instanceVariableNames: 'confirmationTextEditorMorph confirmationTextMorph showPassword container' classVariableNames: '' poolDictionaries: '' category: 'KeyChain-UI'! !PasswordInitializationDialogWindow commentStamp: '' prior: 0! 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: 'accessing' stamp: 'BenjaminVanRyseghem 5/7/2012 11:29'! confirmationTextEditorMorph ^ confirmationTextEditorMorph! ! !PasswordInitializationDialogWindow methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/7/2012 11:29'! confirmationTextEditorMorph: anObject confirmationTextEditorMorph := anObject! ! !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: 'actions' stamp: 'BenjaminVanRyseghem 5/9/2012 23:09'! defaultLabel ^ 'Enter your password'! ! !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: 'BenjaminVanRyseghem 5/11/2012 15:58'! buildInvalidPasswordLabel container := PanelMorph new color: Color transparent; changeProportionalLayout; height: 25; vResizing: #rigid; hResizing: #spaceFill; yourself. ^ container! ! !PasswordInitializationDialogWindow methodsFor: 'creation' stamp: 'BenjaminVanRyseghem 5/11/2012 15:55'! invalidPasswordLabel ^ LabelMorph new text: ''! ! !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: '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 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: 'creation' stamp: 'BenjaminVanRyseghem 5/11/2012 16:04'! setInvalidLabel self setInvalidLabel: ('passwords are not the same' asMorph color: Color red)! ! !PasswordInitializationDialogWindow methodsFor: 'creation' stamp: 'IgorStasenko 12/20/2012 14:56'! setInvalidLabel: aString container removeAllMorphs. container addMorph: aString asMorph fullFrame: LayoutFrame identity ! ! !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/9/2012 23:30'! autoAccept ^false! ! !PasswordInitializationDialogWindow methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 5/9/2012 23:30'! initialize "Initialization code for PasswordInitializationDialogWindow" super initialize. self textFont: UITheme current textFont.! ! !PasswordInitializationDialogWindow methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 5/7/2012 11:40'! newConfirmationTextMorph ^ 'Please confirm your password' asMorph.! ! !PasswordInitializationDialogWindow methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/10/2012 23:45'! beDecrypted textEditorMorph font: self theme textFont. confirmationTextEditorMorph font: self theme textFont.! ! !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: '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: 'private' stamp: 'BenjaminVanRyseghem 5/10/2012 23:44'! showPassword: aBoolean (showPassword := aBoolean) ifTrue: [ self beDecrypted ] ifFalse: [ self beEncrypted ]. self changed: #showPassword! ! BorderedMorph subclass: #PasteUpMorph instanceVariableNames: 'backgroundMorph worldState griddingOn' classVariableNames: 'WindowEventHandler WorldAnnouncer' poolDictionaries: '' category: 'Morphic-Worlds'! !PasteUpMorph commentStamp: 'nice 11/4/2009 23:06' prior: 0! 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. A World, the entire Smalltalk screen, is a PasteUpMorph. A World responds true to isWorld. model cursor ?? padding ?? backgroundMorph A Form that covers the background. turtleTrailsForm Moving submorphs may leave trails on this form. turtlePen Draws the trails. lastTurtlePositions A Dictionary of (aPlayer -> aPoint) so turtle trails can be drawn only once each step cycle. The point is the start of the current stroke. isPartsBin If true, every object dragged out is copied. autoLineLayout ?? indicateCursor ?? resizeToFit ?? wantsMouseOverHalos If true, simply moving the cursor over a submorph brings up its halo. worldState If I am also a World, keeps the hands, damageRecorder, stepList etc. griddingOn If true, submorphs are on a grid ! !PasteUpMorph methodsFor: '*Morphic-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: '*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: '*Polymorph-Widgets' stamp: 'gvc 2/3/2010 17:59'! backgroundMorph "Answer the background morph if any." ^backgroundMorph! ! !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]! ! !PasteUpMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/18/2007 16:14'! currentWindow "Answer the top window." ^SystemWindow topWindow! ! !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: '*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: '*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: '*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: '*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: '*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: '*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: '*Polymorph-Widgets' stamp: 'BenjaminVanRyseghem 9/26/2011 03:51'! navigationKey: event "Check for active window navigation." (self theme openTasklist: event) ifTrue: [^true]. TasklistMorph useHistoricalShortcuts ifTrue: [ (event commandKeyPressed and: [event shiftPressed not]) ifTrue: [ event keyCharacter = Character arrowLeft ifTrue: [self navigateWindowBackward. ^true]. event keyCharacter = Character arrowRight ifTrue: [self navigateWindowForward. ^true]]] ifFalse: [ event keyString = '' ifTrue: [ self navigateWindowForward. ^ true ]. event keyString = '' ifTrue: [ self navigateWindowBackward. ^ true ]]. ^false! ! !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: '*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: '*Polymorph-Widgets' stamp: 'gvc 12/11/2007 16:53'! 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: '*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: '*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: '*Polymorph-Widgets' stamp: 'gvc 4/18/2007 14:36'! systemWindows "Answer the system windows in the world." ^self submorphsSatisfying: [:m | m isSystemWindow]! ! !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: '*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: '*Tools' stamp: 'MarcusDenker 11/30/2012 11:13'! 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. self. #openRecentSubmissionsBrowser:. 'Make a Recent Submissions browser visible'}. { $W. Smalltalk tools finder. #open. 'Open a new Finder'}. { $Z. ChangeList. #browseRecentLog. 'Browse recently-logged changes'}. { $\. SystemWindow. #sendTopWindowToBack. 'Send the top window to the back'}. }. ! ! !PasteUpMorph methodsFor: '*morphic-windows' stamp: 'ThierryGoubier 7/12/2012 11:25'! bringWindowsFullOnscreen "Make ever SystemWindow on the desktop be totally on-screen, whenever possible." | rs r | rs := 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: '*morphic-windows' stamp: 'MarianoMartinezPeck 5/2/2012 23:49'! closeAllWindowsDiscardingChanges World systemWindows do: [:w | [w delete] valueSupplyingAnswer: false]! ! !PasteUpMorph methodsFor: '*morphic-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: '*morphic-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: '*morphic-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-windows' stamp: 'GuillermoPolito 5/29/2011 14:51'! 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 & (collapsed isEmpty & nakedMorphs isEmpty)) ifTrue: [^ Beeper beep]. (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 | (collapsed isEmpty & 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: '*morphic-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: '*morphic-windows' stamp: 'stephane.ducasse 9/25/2008 13:35'! fullRepaintNeeded worldState doFullRepaint. self windowsSatisfying: [:w | w makeMeVisible. false]. ! ! !PasteUpMorph methodsFor: '*morphic-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: 'accessing' stamp: 'Alexandre Bergel 1/7/2010 16:53'! announcer WorldAnnouncer ifNil: [ WorldAnnouncer := Announcer new ]. ^ WorldAnnouncer! ! !PasteUpMorph methodsFor: 'accessing' stamp: 'marcus.denker 11/10/2008 10:04'! 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: 'accessing' stamp: 'tak 3/15/2005 17:31'! removeModalWindow self modalWindow: nil! ! !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: 'alarms-scheduler' stamp: 'ar 9/11/2000 16:40'! addAlarm: aSelector withArguments: argArray for: aTarget at: scheduledTime "Add a new alarm with the given set of parameters" worldState addAlarm: aSelector withArguments: argArray for: aTarget at: scheduledTime.! ! !PasteUpMorph methodsFor: 'alarms-scheduler' stamp: 'ar 9/11/2000 16:39'! removeAlarm: aSelector for: aTarget "Remove the alarm with the given selector" worldState removeAlarm: aSelector for: aTarget! ! !PasteUpMorph methodsFor: 'as yet unclassified ' stamp: 'CamilloBruni 2/4/2012 14:45'! 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" self submorphs select: [:each | each hasProperty: #morphHierarchy] thenDo: [:each | each delete]. (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: 'caching' stamp: 'HenrikSperreJohansen 9/10/2009 15:15'! releaseCachedState super releaseCachedState. self removeModalWindow. self isWorldMorph ifTrue:[self cleanseStepList].! ! !PasteUpMorph methodsFor: 'change reporting' stamp: 'IgorStasenko 12/22/2012 03:00'! invalidRect: damageRect from: aMorph "Clip damage reports to my bounds, since drawing is clipped to my bounds." self == self outermostWorldMorph ifTrue: [worldState recordDamagedRect: (damageRect intersect: self bounds ifNone: [ ^ self ])] ifFalse: [super invalidRect: damageRect from: aMorph] ! ! !PasteUpMorph methodsFor: 'classification' stamp: 'di 7/27/1999 10:46'! isWorldMorph ^ worldState notNil! ! !PasteUpMorph methodsFor: 'copying' stamp: 'tk 7/30/2001 09:26'! veryDeepCopyWith: deepCopier "See storeDataOn:" ^ self isWorldMorph ifTrue: [self] "never copy the World" ifFalse: [super veryDeepCopyWith: deepCopier]! ! !PasteUpMorph methodsFor: 'display' stamp: 'ar 9/7/2002 15:24'! gradientFillColor: aColor "For backwards compatibility with GradientFillMorph" self flag: #fixThis. self useGradientFill. self fillStyle colorRamp: {0.0 -> self fillStyle colorRamp first value. 1.0 -> aColor}. self changed! ! !PasteUpMorph methodsFor: 'display' stamp: 'ar 10/5/2000 18:52'! setGradientColor: evt "For backwards compatibility with GradientFillMorph" self flag: #fixThis. self changeColorTarget: self selector: #gradientFillColor: originalColor: (self fillStyle isGradientFill ifTrue: [self fillStyle colorRamp last value] ifFalse: [color]) hand: evt hand.! ! !PasteUpMorph methodsFor: 'drawing' stamp: 'MarcusDenker 11/19/2009 12:46'! drawOn: aCanvas "Draw in order: - background color - grid, if any - 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 drawOn: aCanvas. "draw grid" (self griddingOn and: [self gridVisible]) ifTrue: [aCanvas fillRectangle: self bounds fillStyle: (self gridFormOrigin: self gridOrigin grid: self gridModulus background: nil line: Color lightGray)]. "draw background sketch." backgroundMorph ifNotNil: [ self clipSubmorphs ifTrue: [ aCanvas clipBy: self clippingBounds during: [ :canvas | canvas fullDrawMorph: backgroundMorph ]] ifFalse: [ aCanvas fullDrawMorph: backgroundMorph ]]! ! !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: 'dropping/grabbing' stamp: 'StephaneDucasse 7/18/2010 15:45'! 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. self isWorldMorph ifTrue: ["Add the given morph to this world and start stepping it if it wants to be." self addMorphFront: aMorph. (aMorph fullBounds intersects: self viewBox) ifFalse: [Beeper beep. aMorph position: self bounds center]] ifFalse: [super acceptDroppingMorph: aMorph event: evt]. aMorph submorphsDo: [:m | (m isKindOf: HaloMorph) ifTrue: [m delete]]. self world startSteppingSubmorphsOf: aMorph. self bringTopmostsToFront. ! ! !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: 'dropping/grabbing' stamp: 'sw 7/6/1999 13:26'! originAtCenter ^ self hasProperty: #originAtCenter! ! !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: '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: 'dropping/grabbing' stamp: 'ar 10/11/2000 18:22'! wantsDroppedMorph: aMorph event: evt self isWorldMorph ifTrue:[^true]. "always" self visible ifFalse: [^ false]. "will be a call to #hidden again very soon" self dropEnabled ifFalse: [^ false]. ^ true! ! !PasteUpMorph methodsFor: 'event handling' stamp: 'BenjaminVanRyseghem 10/25/2012 15:05'! 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 | UsersManager default currentUser 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: 'AlainPlantec 12/10/2009 15:28'! handlesKeyboard: evt ^self isWorldMorph or:[evt keyCharacter == Character tab and: [self tabAmongFields]]! ! !PasteUpMorph methodsFor: 'event handling' stamp: 'ar 10/3/2000 22:46'! handlesMouseDown: evt ^true! ! !PasteUpMorph methodsFor: 'event handling' stamp: 'BenjaminVanRyseghem 9/26/2011 03:13'! keyStroke: anEvent "A keystroke has been made. Service event handlers and, if it's a keystroke presented to the world, dispatch it to #unfocusedKeystroke:" | selected | super keyStroke: anEvent. "Give event handlers a chance" selected := self selectedObject. selected isNil ifFalse:[ selected moveOrResizeFromKeystroke: anEvent ]. self isWorldMorph ifTrue: [self keystrokeInWorld: anEvent]. (anEvent keyCharacter == Character tab) ifTrue: [self tabAmongFields ifTrue:[^ self tabHitWithEvent: anEvent]]. ! ! !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: 'event handling' stamp: 'ar 10/6/2000 00:04'! mouseUp: evt self isWorldMorph ifTrue:[self removeAlarm: #invokeWorldMenu:]. super mouseUp: evt.! ! !PasteUpMorph methodsFor: 'event handling' stamp: 'ar 1/10/2001 21:29'! wantsDropFiles: anEvent ^self isWorldMorph! ! !PasteUpMorph methodsFor: 'event handling' stamp: 'AlainPlantec 12/10/2009 11:38'! wantsEasySelection "Answer if the receiver want easy selection mode" ^ self isEasySelecting ! ! !PasteUpMorph methodsFor: 'event handling' stamp: 'StephaneDucasse 7/18/2010 16:37'! wantsKeyboardFocusFor: aSubmorph aSubmorph wouldAcceptKeyboardFocus ifTrue: [ ^ true]. ^ super wantsKeyboardFocusFor: aSubmorph! ! !PasteUpMorph methodsFor: 'event handling' stamp: 'tbn 3/12/2010 01:52'! wantsWindowEvent: anEvent ^self isWorldMorph or: [self windowEventHandler notNil]! ! !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: '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: '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: 'events-processing' stamp: 'ar 4/5/2001 21:42'! processEvent: anEvent using: defaultDispatcher "Reimplemented to install the receiver as the new ActiveWorld if it is one" | priorWorld result | self isWorldMorph ifFalse:[^super processEvent: anEvent using: defaultDispatcher]. priorWorld := ActiveWorld. ActiveWorld := self. result := super processEvent: anEvent using: defaultDispatcher. ActiveWorld := priorWorld. ^result! ! !PasteUpMorph methodsFor: 'geometry' stamp: 'RAA 6/20/2000 12:42'! extent: aPoint super extent: aPoint. worldState ifNotNil: [ worldState viewBox ifNotNil: [ worldState canvas: nil. worldState viewBox: bounds ]. ].! ! !PasteUpMorph methodsFor: 'geometry' stamp: 'di 8/28/2000 23:13'! gridPoint: ungriddedPoint self griddingOn ifFalse: [^ ungriddedPoint]. ^ (ungriddedPoint - self position - self gridOrigin grid: self gridModulus) + self position + self gridOrigin! ! !PasteUpMorph methodsFor: 'geometry' stamp: 'RAA 6/1/2000 10:28'! position: aPoint "Prevent moving a world (e.g. via HandMorph>>specialGesture:)" "for now, let's allow it and see what happens" self isWorldMorph ifFalse: [^super position: aPoint]. super position: aPoint. self viewBox ifNotNil: [self viewBox: (aPoint extent: self viewBox extent)]. ! ! !PasteUpMorph methodsFor: 'geometry testing' stamp: 'RAA 6/2/2000 10:22'! fullContainsPoint: pt "The world clips its children" worldState ifNil: [^super fullContainsPoint: pt]. ^bounds containsPoint: pt ! ! !PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 13:15'! griddingOn ^ griddingOn ifNil: [false]! ! !PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 16:48'! griddingOnOff griddingOn := self griddingOn not. self changed! ! !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: 'gridding' stamp: 'di 8/24/2000 13:29'! gridModulus ^ self gridSpec extent! ! !PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 16:47'! gridModulus: newModulus self gridSpecPut: (self gridOrigin extent: newModulus). self changed! ! !PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 13:28'! gridOrigin ^ self gridSpec origin! ! !PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 13:29'! gridOrigin: newOrigin ^ self gridSpecPut: (newOrigin extent: self gridModulus)! ! !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: 'gridding' stamp: 'di 8/24/2000 13:28'! gridSpecPut: newSpec "Gridding rectangle provides origin and modulus" ^ self setProperty: #gridSpec toValue: newSpec! ! !PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 16:11'! gridVisible ^ self hasProperty: #gridVisible! ! !PasteUpMorph methodsFor: 'gridding' stamp: 'di 8/24/2000 16:47'! gridVisibleOnOff self setProperty: #gridVisible toValue: self gridVisible not. self changed! ! !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: 'gridding' stamp: 'jb 7/1/2011 10:56'! 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 evaluatorClass 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 evaluatorClass 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: '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: 'halos and balloon help' stamp: 'di 9/26/2000 21:39'! wantsDirectionHandles ^ super wantsDirectionHandles and: [self isWorldMorph not]! ! !PasteUpMorph methodsFor: 'halos and balloon help' stamp: 'StephaneDucasse 2/19/2010 16:02'! wantsHaloFromClick (owner isSystemWindow) ifTrue: [^ false]. ^ true. ! ! !PasteUpMorph methodsFor: 'initialization' stamp: 'AlexandreBergel 7/30/2008 14:17'! 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 value] on: Error do: [:ex | ActiveWorld := priorWorld. ActiveEvent := priorEvent. ActiveHand := priorHand. ex pass]! ! !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: 'initialization' stamp: 'dgd 2/14/2003 22:38'! defaultBorderWidth "answer the default border width for the receiver" ^ 1! ! !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: 'initialization' stamp: 'StephaneDucasse 7/18/2010 15:20'! initialize "initialize the state of the receiver" super initialize. self enableDragNDrop. self clipSubmorphs: true! ! !PasteUpMorph methodsFor: 'interaction loop' stamp: 'ls 5/6/2003 16:51'! doOneCycleNow "see the comment in doOneCycleNowFor:" worldState doOneCycleNowFor: self. ! ! !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: '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: 'menu & halo' stamp: 'ar 10/3/2000 17:02'! deleteBalloonTarget: aMorph "Delete the balloon help targeting the given morph" self handsDo:[:h| h deleteBalloonTarget: aMorph].! ! !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: '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: '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: 'painting' stamp: 'IgorStasenko 12/22/2012 03:01'! 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: 'printing' stamp: 'sw 10/18/2000 10:54'! printOn: aStream "Reimplemented to add a tag showing that the receiver is currently functioning as a 'world', if it is" super printOn: aStream. self isWorldMorph ifTrue: [aStream nextPutAll: ' [world]']! ! !PasteUpMorph methodsFor: 'project state' stamp: 'di 7/27/1999 10:46'! canvas ^ worldState canvas! ! !PasteUpMorph methodsFor: 'project state' stamp: 'di 7/27/1999 10:46'! firstHand ^ worldState hands first! ! !PasteUpMorph methodsFor: 'project state' stamp: 'di 7/27/1999 10:46'! hands ^ worldState hands! ! !PasteUpMorph methodsFor: 'project state' stamp: 'nk 7/4/2003 16:47'! handsDo: aBlock ^ worldState ifNotNil: [ worldState handsDo: aBlock ]! ! !PasteUpMorph methodsFor: 'project state' stamp: 'nk 7/4/2003 16:46'! handsReverseDo: aBlock ^ worldState ifNotNil: [ worldState handsReverseDo: aBlock ]! ! !PasteUpMorph methodsFor: 'project state' stamp: 'sw 10/9/1999 22:51'! isStepping: aMorph ^ worldState isStepping: aMorph! ! !PasteUpMorph methodsFor: 'project state' stamp: 'ar 10/22/2000 16:43'! isStepping: aMorph selector: aSelector ^ worldState isStepping: aMorph selector: aSelector! ! !PasteUpMorph methodsFor: 'project state' stamp: 'sw 9/5/2000 06:45'! listOfSteppingMorphs ^ worldState listOfSteppingMorphs "self currentWorld listOfSteppingMorphs"! ! !PasteUpMorph methodsFor: 'project state' stamp: 'sw 9/5/2000 09:56'! stepListSize ^ worldState stepListSize "Transcript cr; show: self currentWorld stepListSize printString, ' items on steplist as of ', Date dateAndTimeNow printString"! ! !PasteUpMorph methodsFor: 'project state' stamp: 'sw 9/5/2000 09:59'! steppingMorphsNotInWorld | all | all := self allMorphs. ^ self listOfSteppingMorphs select: [:m | (all includes: m) not] "self currentWorld steppingMorphsNotInWorld do: [:m | m delete]"! ! !PasteUpMorph methodsFor: 'project state' stamp: 'AlainPlantec 10/17/2009 20:31'! viewBox "This tortured workaround arises from a situation encountered in which a PasteUpMorph was directliy lodged as a submorph of another PasteUpMorph of identical size" ^ worldState ifNil: [super viewBox] ifNotNil: [worldState viewBox]! ! !PasteUpMorph methodsFor: 'project state' stamp: 'dgd 2/22/2003 14:12'! viewBox: newViewBox "I am now displayed within newViewBox; react." self isWorldMorph ifTrue: [(self viewBox isNil or: [self viewBox extent ~= newViewBox extent]) ifTrue: [worldState canvas: nil]. worldState viewBox: newViewBox]. super position: newViewBox topLeft. fullBounds := bounds := newViewBox. "Paragraph problem workaround; clear selections to avoid screen droppings." self flag: #arNote. "Probably unnecessary" self isWorldMorph ifTrue: [worldState handsDo: [:hand | hand releaseKeyboardFocus]. self fullRepaintNeeded]! ! !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: 'stepping' stamp: 'AlainPlantec 10/17/2009 18:13'! cleanseStepList "Remove morphs from the step list that are not in this World." worldState cleanseStepListForWorld: self! ! !PasteUpMorph methodsFor: 'stepping' stamp: 'RAA 6/7/2000 10:12'! runLocalStepMethods worldState runLocalStepMethodsIn: self ! ! !PasteUpMorph methodsFor: 'stepping' stamp: 'RAA 5/24/2000 10:27'! runStepMethods worldState runStepMethodsIn: self ! ! !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: 'stepping' stamp: 'ar 10/22/2000 16:36'! startStepping: aMorph at: scheduledTime selector: aSelector arguments: args stepTime: stepTime worldState startStepping: aMorph at: scheduledTime selector: aSelector arguments: args stepTime: stepTime.! ! !PasteUpMorph methodsFor: 'stepping' stamp: 'RAA 8/14/2000 11:50'! step (self isWorldMorph and: [owner notNil]) ifTrue: [ ^self runLocalStepMethods ]. super step! ! !PasteUpMorph methodsFor: 'stepping' stamp: 'RAA 5/24/2000 11:08'! stopStepping: aMorph "Remove the given morph from the step list." worldState stopStepping: aMorph ! ! !PasteUpMorph methodsFor: 'stepping' stamp: 'ar 10/22/2000 16:40'! stopStepping: aMorph selector: aSelector "Remove the given morph from the step list." worldState stopStepping: aMorph selector: aSelector ! ! !PasteUpMorph methodsFor: 'structure' stamp: 'di 7/27/1999 10:46'! activeHand ^ worldState ifNotNil: [worldState activeHand] ifNil: [super activeHand]! ! !PasteUpMorph methodsFor: 'structure' stamp: 'GuillermoPolito 9/1/2010 18:42'! world worldState ifNil: [^super world]. ^self! ! !PasteUpMorph methodsFor: 'submorphs-accessing' stamp: 'RAA 5/24/2000 12:09'! allMorphsDo: aBlock "Enumerate all morphs in the world, including those held in hands." super allMorphsDo: aBlock. self isWorldMorph ifTrue: [worldState handsReverseDo: [:h | h allMorphsDo: aBlock]]. ! ! !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: 'submorphs-add/remove' stamp: 'di 7/15/1999 09:51'! addAllMorphs: array super addAllMorphs: array. self isWorldMorph ifTrue: [array do: [:m | self startSteppingSubmorphsOf: m]]. ! ! !PasteUpMorph methodsFor: 'submorphs-add/remove' stamp: 'RAA 12/16/2000 18:37'! addMorphFront: aMorph ^self addMorphInFrontOfLayer: aMorph ! ! !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: '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: 'taskbar' stamp: 'MarcusDenker 3/23/2011 15:37'! removeTaskbar "Remove the receiver's taskbars." self taskbars do: [:each | each removeFromWorld]! ! !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: 'testing' stamp: 'AlainPlantec 12/10/2009 11:37'! 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." ^ self isWorldMorph and: [worldState isEasySelecting] ! ! !PasteUpMorph methodsFor: 'testing' stamp: 'RAA 8/14/2000 11:50'! stepTime (self isWorldMorph and: [owner notNil]) ifTrue: [ ^1 ]. ^super stepTime! ! !PasteUpMorph methodsFor: 'thumbnail' stamp: 'AlainPlantec 10/19/2010 21:11'! icon "Answer a form with an icon to represent the receiver" ^ self isWorldMorph ifTrue: [self theme homeIcon] ifFalse: [self theme projectIcon]! ! !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: 'viewing' stamp: 'dgd 4/4/2006 13:58'! bringTopmostsToFront submorphs select:[:m| m wantsToBeTopmost] thenDo:[:m| self addMorphInLayer: m].! ! !PasteUpMorph methodsFor: 'wiw support' stamp: 'dgd 8/31/2004 16:25'! addMorphInLayer: aMorph super addMorphInLayer: aMorph. aMorph wantsToBeTopmost ifFalse:[self bringTopmostsToFront].! ! !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: 'world menu' stamp: 'AlainPlantec 1/9/2010 06:07'! collapseNonWindows self nonWindows reject: [:m | m isSticky] thenDo: [:m | m collapse]! ! !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: 'dgd 9/11/2004 20:45'! delayedInvokeWorldMenu: evt self addAlarm: #invokeWorldMenu: with: evt after: 200! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'AlainPlantec 2/17/2010 00:22'! discoveredWorldMenu ^ worldState ifNil: [owner discoveredWorldMenu] ifNotNil: [worldState discoveredWorldMenu] ! ! !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: 'world menu' stamp: 'StephaneDucasse 3/3/2010 15:32'! drawingClass ^ ImageMorph! ! !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: 'world menu' stamp: 'StephaneDucasse 7/4/2012 19:52'! findAChangeSorter: evt "Locate a change sorter, open it, and bring it to the front. Create one if necessary" self findAWindowSatisfying: [:aWindow | (aWindow model isKindOf: Smalltalk tools changeSorter) or: [aWindow model isKindOf: Smalltalk tools dualChangeSorter]] orMakeOneUsing: [Smalltalk tools dualChangeSorter new openWithSpec]! ! !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: '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: '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: '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: '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: '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: 'world menu' stamp: 'AlainPlantec 2/17/2010 01:53'! invokeWorldMenuFromEscapeKey self invokeWorldMenu: ActiveEvent! ! !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 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: '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: 'world menu' stamp: 'AlainPlantec 12/13/2009 08:11'! lastKeystroke "Answer the last keystroke fielded by the receiver" ^ self valueOfProperty: #lastKeystroke ifAbsent: ['']! ! !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: 'world menu' stamp: 'StephaneDucasse 6/22/2012 18:54'! 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 ?' 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: 'world menu' stamp: 'AlainPlantec 10/17/2009 17:32'! nonWindows ^ (self submorphs select: [:m | (m isSystemWindow) not and: [m wantsToBeTopmost not]])! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'StephaneDucasse 5/15/2011 18:10'! openRecentSubmissionsBrowser: evt RecentMessageList openInWorld.! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'AlainPlantec 2/17/2010 00:29'! resetWorldMenu worldState ifNil: [owner resetWorldMenu] ifNotNil: [worldState resetWorldMenu] ! ! !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: '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: 'world menu' stamp: 'AlainPlantec 2/16/2010 23:38'! worldMenu ^ worldState ifNil: [owner worldMenu] ifNotNil: [worldState worldMenu] ! ! !PasteUpMorph methodsFor: 'world menu' stamp: 'AlainPlantec 2/16/2010 23:43'! worldMenuAt: aMenuItemName ^ worldState ifNil: [owner worldMenuAt: aMenuItemName] ifNotNil: [worldState worldMenuAt: aMenuItemName] ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'RAA 5/24/2000 22:29'! activeHand: aHandMorph "temporarily retained for old main event loops" worldState activeHand: aHandMorph. ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'ar 10/26/2000 14:52'! addHand: aHandMorph "Add the given hand to the list of hands for this world." aHandMorph owner ifNotNil:[aHandMorph owner removeHand: aHandMorph]. worldState addHand: aHandMorph. aHandMorph privateOwner: self. ! ! !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: 'world state' stamp: 'StephaneDucasse 7/18/2010 16:10'! 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 isWorldMorph ifFalse: [ aMorphOrList privateOwner: nil. self firstHand attachMorph: aMorphOrList. self startSteppingSubmorphsOf: aMorphOrList] ifTrue: [ aMorphOrList privateOwner: nil. 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: 'world state' stamp: 'RAA 5/24/2000 10:45'! assuredCanvas ^worldState assuredCanvas! ! !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: '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: 'world state' stamp: 'AlainPlantec 12/3/2009 15:56'! defaultWorldColor ^ self class defaultWorldColor! ! !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 state' stamp: 'RAA 5/25/2000 15:43'! displayWorld self outermostWorldMorph privateOuterDisplayWorld ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'RAA 5/24/2000 12:23'! displayWorldSafely worldState displayWorldSafely: self. ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'ls 5/6/2003 16:51'! doOneCycle "see the comment in doOneCycleFor:" worldState doOneCycleFor: self! ! !PasteUpMorph methodsFor: 'world state' stamp: 'RAA 5/24/2000 11:59'! doOneSubCycle "Like doOneCycle, but preserves activeHand." worldState doOneSubCycleFor: self! ! !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: 'world state' stamp: 'nice 1/5/2010 15:59'! 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 current 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: 'world state' stamp: 'AlainPlantec 5/7/2010 21:49'! haloMorphs ^ self hands collect: [:h | h halo] thenSelect: [:halo| halo notNil]! ! !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 state' stamp: 'MarcusDenker 4/13/2011 14:43'! install owner := nil. "since we may have been inside another world previously" ActiveWorld := self. ActiveHand := self hands first. "default" ActiveEvent := nil. submorphs do: [:ss | ss owner isNil ifTrue: [ss privateOwner: self]]. "Transcript that was in outPointers and then got deleted." self viewBox: Display boundingBox. Sensor flushAllButDandDEvents. worldState handsDo: [:h | h initForEvents]. self borderWidth: 0. "default" SystemWindow noteTopWindowIn: self. self displayWorldSafely! ! !PasteUpMorph methodsFor: 'world state' stamp: 'nb 6/17/2003 12:25'! nextPage "backstop for smart next-page buttons that look up the containment hierarchy until they find somone who is willing to field this command. If we get here, the 'next' button was not embedded in a book, so we can do nothing useful" Beeper beep! ! !PasteUpMorph methodsFor: 'world state' stamp: 'nb 6/17/2003 12:25'! previousPage "backstop for smartprev-page buttons that look up the containment hierarchy until they find somone who is willing to field this command. If we get here, the button was not embedded in a book, so we can do nothing useful" Beeper beep! ! !PasteUpMorph methodsFor: 'world state' stamp: 'RAA 5/25/2000 15:43'! privateOuterDisplayWorld worldState displayWorld: self submorphs: submorphs ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'ar 10/5/2000 16:23'! removeHand: aHandMorph "Remove the given hand from the list of hands for this world." (worldState hands includes: aHandMorph) ifFalse: [^self]. aHandMorph dropMorphs. self invalidRect: aHandMorph fullBounds. worldState removeHand: aHandMorph. ! ! !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 state' stamp: 'dgd 9/5/2004 19:46'! restoreMainDockingBarDisplay "Restore the display of docking bars" self dockingBars do: [:each | each updateBounds]! ! !PasteUpMorph methodsFor: 'world state' stamp: 'gvc 2/3/2010 18:00'! restoreMorphicDisplay DisplayScreen startUp. ThumbnailMorph recursionReset. self extent: Display extent; viewBox: Display boundingBox; handsDo: [:h | h visible: true; showTemporaryCursor: nil]; resizeBackgroundMorph; restoreMainDockingBarDisplay; fullRepaintNeeded. WorldState addDeferredUIMessage: [Cursor normal show]. ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'stephane.ducasse 5/1/2009 22:11'! sleep worldState canvas ifNil: [^ self "already called (clean this up)"]. Cursor normal show. "restore the normal cursor" worldState canvas: nil. "free my canvas to save space" self fullReleaseCachedState. ! ! !PasteUpMorph methodsFor: 'world state' stamp: 'AlainPlantec 5/7/2010 21:48'! someHalo "Return some halo that's currently visible in the world" ^ (self haloMorphs) ifEmpty: [] ifNotEmpty: [:m | m first]! ! !PasteUpMorph methodsFor: 'world state' stamp: 'RAA 6/1/2000 19:01'! startSteppingSubmorphsOf: aMorph "Ensure that all submorphs of the given morph that want to be stepped are added to the step list. Typically used after adding a morph to the world." aMorph allMorphsDo: [:m | m wantsSteps ifTrue: [m arrangeToStartSteppingIn: m world]. ] ! ! !PasteUpMorph methodsFor: 'private' stamp: 'ar 3/14/2000 23:20'! privateFullMoveBy: delta "Private. Overridden to prevent drawing turtle trails when a playfield is moved" self setProperty: #turtleTrailsDelta toValue: delta. super privateFullMoveBy: delta. self removeProperty: #turtleTrailsDelta. ! ! !PasteUpMorph methodsFor: 'private' stamp: 'RAA 6/1/2000 14:23'! privateMoveBy: delta super privateMoveBy: delta. worldState ifNotNil: [ worldState viewBox ifNotNil: [ worldState viewBox: bounds ]. ].! ! !PasteUpMorph methodsFor: 'private' stamp: 'nk 7/8/2003 09:18'! privateRemoveMorph: aMorph backgroundMorph == aMorph ifTrue: [ backgroundMorph := nil ]. ^super privateRemoveMorph: aMorph. ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PasteUpMorph class instanceVariableNames: ''! !PasteUpMorph class methodsFor: 'cleanup' stamp: 'MarcusDenker 4/22/2011 10:37'! cleanUp World cleanseOtherworldlySteppers.! ! !PasteUpMorph class methodsFor: 'setting' stamp: 'AlainPlantec 12/3/2009 15:56'! defaultWorldColor ^ Color r: 0.937 g: 0.937 b: 0.937. ! ! !PasteUpMorph class methodsFor: 'system startup' stamp: 'rww 10/1/2001 01:17'! shutDown World ifNotNil:[ World triggerEvent: #aboutToLeaveWorld. ].! ! !PasteUpMorph class methodsFor: 'system startup' stamp: 'rww 10/1/2001 01:17'! startUp World ifNotNil:[ World restoreMorphicDisplay. World triggerEvent: #aboutToEnterWorld. ].! ! Object variableSubclass: #Path instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Core-Kernel'! !Path commentStamp: '' prior: 0! 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: '*Network-Url' stamp: 'abc 5/11/2012 17:33'! asUrl ^ FileUrl pathParts: self segments asOrderedCollection isAbsolute: self isAbsolute! ! !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: '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: '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: '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: 'cwp 10/11/2009 11:05'! delimiter ^ $/! ! !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: 'accessing' stamp: 'cwp 12/23/2008 11:25'! extensionDelimiter ^ self class extensionDelimiter! ! !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: 'accessing' stamp: 'sd 2/11/2011 21:02'! fullName "Return the fullName of the receiver." ^ self printString! ! !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: '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: '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: '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: 'comparing' stamp: 'cwp 10/25/2009 23:05'! containsReference: aReference ^ false! ! !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: 'comparing' stamp: 'cwp 11/16/2009 09:06'! isChildOf: anObject ^ self parent = anObject! ! !Path methodsFor: 'comparing' stamp: 'CamilloBruni 9/5/2012 18:07'! isContainedBy: anObject "DoubleDispatch helper for #contains:" ^ anObject containsPath: self! ! !Path methodsFor: 'converting' stamp: 'EstebanLorenzano 4/12/2012 14:28'! asFileReference ^ FileSystem disk referenceTo: self! ! !Path methodsFor: 'converting' stamp: 'cwp 10/10/2009 18:04'! asPathWith: anObject ^ self! ! !Path methodsFor: 'converting' stamp: 'EstebanLorenzano 4/12/2012 14:30'! asReference self deprecated: 'Use #asFileReference instead' on: '12 April 2012' in: 'Pharo 1.4' . ^ self asFileReference! ! !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: '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: 'navigating' stamp: 'cwp 11/17/2009 23:52'! , extension ^ self withName: self basename extension: extension! ! !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: 'navigating' stamp: 'cwp 9/22/2009 09:08'! asResolvedBy: anObject ^ anObject resolvePath: self! ! !Path methodsFor: 'navigating' stamp: 'cwp 11/15/2009 00:00'! makeRelative: anObject ^ anObject relativeToPath: self! ! !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: 'navigating' stamp: 'cwp 11/15/2009 00:00'! relativeTo: anObject ^ anObject makeRelative: self! ! !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: 'navigating' stamp: 'cwp 3/29/2011 16:23'! relativeToReference: aReference ^ self relativeToPath: aReference path! ! !Path methodsFor: 'navigating' stamp: 'cwp 11/16/2009 10:19'! resolve ^ self! ! !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: '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: 'navigating' stamp: 'cwp 9/22/2009 09:06'! resolveReference: aReference ^ aReference! ! !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 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: 'printing' stamp: 'cwp 11/17/2009 10:22'! printOn: aStream self printOn: aStream delimiter: self delimiter. ! ! !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: 'printing' stamp: 'cwp 1/13/2009 21:27'! printWithDelimiter: aCharacter ^ String streamContents: [:out | self printOn: out delimiter: aCharacter]! ! !Path methodsFor: 'testing' stamp: 'cwp 2/26/2011 10:58'! isAbsolute self subclassResponsibility ! ! !Path methodsFor: 'testing' stamp: 'DamienPollet 2/20/2011 04:00'! isEmpty ^ self size = 0! ! !Path methodsFor: 'testing' stamp: 'cwp 12/13/2008 21:00'! isRelative ^ self isAbsolute not! ! !Path methodsFor: 'testing' stamp: 'cwp 2/26/2011 11:03'! isRoot self subclassResponsibility ! ! !Path methodsFor: 'testing' stamp: 'cwp 7/18/2009 00:42'! isWorkingDirectory ^ self size = 0! ! !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: 'private' stamp: 'cwp 10/25/2009 19:53'! isAllParents 1 to: self size do: [:i | (self at: i) = '..' ifFalse: [^ false]]. ^ true! ! !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: '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 class instanceVariableNames: ''! !Path class methodsFor: 'encodings' stamp: 'StephaneDucasse 2/18/2011 22:31'! extensionDelimiter "Return the extension delimiter character." ^ $.! ! !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: '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: 'instance creation' stamp: 'CamilloBruni 5/7/2012 02:19'! from: aString ^ self from: aString delimiter: $/! ! !Path class methodsFor: 'instance creation' stamp: 'tbn 6/26/2012 21:03'! from: aString delimiter: aDelimiterCharacter "Answer a path composed of several elements delimited by aCharacter" | pathCls | aString isEmpty ifTrue: [ ^ self root ]. pathCls := ((self isAbsoluteUnixPath: aString) or: [self isAbsoluteWindowsPath: aString]) ifTrue: [AbsolutePath] ifFalse:[RelativePath]. ^ pathCls withAll: (pathCls canonicalizeElements: (aDelimiterCharacter split: aString))! ! !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: '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:42'! root "Answer the root path - ie, / on unix" ^ AbsolutePath new! ! !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: 'private' stamp: 'CamilloBruni 1/19/2012 15:03'! addElement: element to: result element = '..' ifTrue: [^ self addParentElementTo: result]. element = '' ifTrue: [^ self addEmptyElementTo: result]. element = '.' ifFalse: [result add: element]! ! !Path class methodsFor: 'private' stamp: 'cwp 10/26/2009 13:41'! addEmptyElementTo: result result isEmpty ifTrue: [result add: ''] ! ! !Path class methodsFor: 'private' stamp: 'cwp 10/26/2009 13:39'! addParentElementTo: result result isEmpty ifTrue: [result add: '..'] ifFalse: [result removeLast] ! ! !Path class methodsFor: 'private' stamp: 'cwp 10/26/2009 13:30'! canonicalizeElements: aCollection | result | result := OrderedCollection new. aCollection do: [:element | self addElement: element to: result]. ^ result! ! !Path class methodsFor: 'private' stamp: 'tbn 6/26/2012 21:02'! isAbsoluteUnixPath: aString ^aString first = $/ ! ! !Path class methodsFor: 'private' stamp: 'tbn 6/26/2012 21:02'! isAbsoluteWindowsPath: aString ^aString matchesRegex: '[a-zA-Z]\:\\.*'! ! !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 5/8/2012 17:47'! withAll: aCollection | inst | inst := self new: aCollection size. aCollection withIndexDo: [:segment :index | inst at: index put: segment]. ^ inst! ! Shape subclass: #PathShape instanceVariableNames: 'bounds vertices' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Geometry'! !PathShape commentStamp: 'LaurentLaffont 3/31/2011 21:05' prior: 0! 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: '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:40'! addVertex: aPoint "Add a vertex to the path." self vertices add: aPoint. self basicBounds ifNotNil: [ self bounds: (self bounds quickMergePoint: aPoint)] ! ! !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 methodsFor: 'as yet unclassified' 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: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 class instanceVariableNames: ''! !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! ! TestCase variableSubclass: #PathTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Tests-Core'! !PathTest methodsFor: 'tests' stamp: 'PavelKrivanek 11/25/2012 20:15'! testAbsolutePath | path | self assert: (AbsolutePath new isAbsolute). self assert: (Path root isAbsolute). path := AbsolutePath from: 'parent/child/grandChild' delimiter: $/. self assert: path size = 3. self assert: (path at: 1) = 'parent'. self assert: (path at: 2) = 'child'. self assert: (path at: 3) = 'grandChild'. path := AbsolutePath from: '/' delimiter: $/. self assert: path = Path root. ! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/3/2012 11:15'! testAbsolutePrintString | path actual | path := Path / 'plonk' / 'griffle'. actual := path printString. self assert: actual = 'Path / ''plonk'' / ''griffle'''! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testAbsoluteWithParents | path allPaths | path := Path / 'plonk' / 'griffle' / 'nurb'. allPaths := path withParents. self assert: allPaths size = 4. self assert: allPaths first isRoot. self assert: allPaths second basename = 'plonk'. self assert: allPaths second size = 1. self assert: (allPaths second isChildOf: allPaths first). self assert: allPaths third basename = 'griffle'. self assert: allPaths third size = 2. self assert: (allPaths third isChildOf: allPaths second). self assert: allPaths fourth basename = 'nurb'. self assert: allPaths fourth size = 3. self assert: (allPaths fourth isChildOf: allPaths third). self assert: allPaths fourth = path. self assert: allPaths fourth == path! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/12/2012 14:28'! testAsReference | path reference | path := Path * 'plonk'. reference := path asFileReference. self assert: reference class = FileReference. self assert: reference path = path! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testBasename | path | path := Path * 'plonk' / 'griffle'. self assert: path basename = 'griffle'! ! !PathTest methodsFor: 'tests' stamp: 'SeanDeNigris 6/23/2012 11:42'! testBasenameWithoutExtension "self debug: #testBasenameWithoutExtension" | path | path := Path * 'plonk' / 'griffle'. self assert: path basenameWithoutExtension = 'griffle'. path := Path * 'plonk' / 'griffle.taz'. self assert: path basenameWithoutExtension = 'griffle'. path := Path * 'plonk' / 'griffle.taz.zork'. self assert: path basenameWithoutExtension = 'griffle.taz'.! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testCommaAddsExtension | path result | path := Path * 'plonk' . result := path, 'griffle'. self assert: result basename = 'plonk.griffle'! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testCommaAddsExtensionAgain | path result | path := Path * 'plonk.griffle'. result := path, 'nurp'. self assert: result basename = '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: '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: 'EstebanLorenzano 4/2/2012 11:42'! testEqual | a b | a := Path * 'plonk'. b := Path * 'plonk'. self deny: a == b. self assert: a = b.! ! !PathTest methodsFor: 'tests' stamp: 'CamilloBruni 6/22/2012 18:20'! testExtensions self assert: (Path from: 'foo') extensions asArray equals: #(). self assert: (Path from: 'foo.tar') extensions asArray equals: #( 'tar' ). self assert: (Path from: 'foo.tar.gz') extensions asArray equals: #( 'tar' 'gz'). self assert: (Path from: 'foo.1.tar.gz') extensions asArray equals: #( '1' 'tar' 'gz').! ! !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'! testIsAbsolute self assert: (Path / 'plonk') isAbsolute! ! !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: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'! testIsEmpty self assert: (Path workingDirectory) isEmpty! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testIsNotAbsolute self deny: (Path * 'plonk') isAbsolute! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testIsNotRelative self deny: (Path / 'plonk') isRelative! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testIsNotRoot self deny: (Path / 'plonk') isRoot! ! !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'! testIsRoot self assert: Path root isRoot! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testMakeRelative "self run: #testMakeRelative" | parent child relative | parent := Path / 'griffle' / 'bibb'. child := Path / 'griffle' / 'plonk' / 'nurp'. relative := parent makeRelative: child. self assert: relative = (Path parent / 'plonk' / 'nurp')! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testParent | path parent | path := (Path * 'plonk') / 'griffle'. parent := path parent. self assert: parent isRelative. self assert: (parent at: 1) = 'plonk'! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testParentParent | path | path := (Path * '..') parent. self assert: path size = 2. self assert: (path at: 1) = '..'. self assert: (path at: 2) = '..'.! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! 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) = 'plonk'. self assert: (absolute at: 2) = 'griffle'. self assert: (absolute at: 3) = 'zonk'. ! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testParse "self run: #testParse" | path | path := Path from: 'parent/child/grandChild' delimiter: $/. self assert: path size = 3. self assert: (path at: 1) = 'parent'. self assert: (path at: 2) = 'child'. self assert: (path at: 3) = 'grandChild'. ! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testParseBogus "self run: #testParseBogus" | path | path := Path from: 'parent?<>~ \child/grandChild' delimiter: $/. self assert: path size = 2. self assert: (path at: 1) = 'parent?<>~ \child'. self assert: (path at: 2) = 'grandChild'. ! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testParseTrailingSlash | path | path := Path from: 'griffle/' delimiter: $/. self assert: path size = 1. self assert: (path at: 1) = 'griffle'! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 5/4/2012 15:50'! testParseWindowsPathWithUnixDelimiters "self run: #testParse" | path | path := WindowsStore new pathFromString: 'C:\a/b/c'. self assert: path segments size = 4. self assert: path segments = #('C:' 'a' 'b' 'c') ! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testPrintRelativeWithParent | path | path := Path parent / 'foo'. self assert: (path printWithDelimiter: $/) = '../foo'! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testPrintWithDelimiter | path | path := (Path * 'plonk') / 'griffle'. self assert: (path printWithDelimiter: $%) = 'plonk%griffle'! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/3/2012 11:15'! testRelativePrintString | path actual | path := Path * 'plonk' / 'griffle'. actual := path printString. self assert: actual = 'Path * ''plonk'' / ''griffle'''! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! 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 = (Path * 'plonk' / 'nurp')! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testRelativeToBranch | parent child relative | parent := Path / 'griffle' / 'bibb'. child := Path / 'griffle' / 'plonk' / 'nurp'. relative := child relativeTo: parent. self assert: relative = (Path parent / 'plonk' / 'nurp')! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testRelativeWithParents | path allPaths | path := Path * 'plonk' / 'griffle' / 'nurb'. allPaths := path withParents. self assert: allPaths size = 3. self assert: allPaths first basename = 'plonk'. self assert: allPaths first size = 1. self assert: allPaths second basename = 'griffle'. self assert: allPaths second size = 2. self assert: (allPaths second isChildOf: allPaths first). self assert: allPaths third basename = 'nurb'. self assert: allPaths third size = 3. self assert: (allPaths third isChildOf: allPaths second). self assert: allPaths third == path! ! !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: 'EstebanLorenzano 4/2/2012 11:42'! testResolvePath "self debug: #testResolvePath" | path | path := Path / 'grandfather' / 'father' / 'child'. self assert: (path resolvePath: Path / 'grandfather') = (Path / 'grandfather'). self assert: (path resolvePath: Path / 'child') = (Path / 'child'). self assert: (path resolvePath: Path * 'grandfather') = (Path / 'grandfather' / 'father' / 'child' / 'grandfather'). self assert: (path resolvePath: Path * 'child') = (Path / 'grandfather' / 'father' / 'child' / 'child'). self assert: (path resolvePath: Path * 'grandfather') = (Path / 'grandfather' / 'father' / 'child' / 'grandfather'). self assert: (path resolvePath: Path * 'child') = (Path / 'grandfather' / 'father' / 'child' / 'child'). self assert: (path resolvePath: (Path parent) / '..') = (Path / 'grandfather') ! ! !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'! testResolveString "self debug: #testResolveString" | path result | path := Path * 'plonk'. result := path resolve: 'griffle'. self assert: result class = path class. self assert: result size = 2. self assert: (result at: 1) = 'plonk'. self assert: (result at: 2) = 'griffle'.! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testRootParent | root | root := Path root. self assert: root parent == root! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/3/2012 11:16'! testRootPrintString | path actual | path := Path root. actual := path printString. self assert: actual = 'Path root'! ! !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: 'EstebanLorenzano 4/2/2012 11:42'! testSimpleResolution | base relative absolute | base := Path / 'plonk'. relative := (Path * 'griffle') / 'zonk'. absolute := base resolve: relative. self assert: absolute isAbsolute. self assert: (absolute at: 1) = 'plonk'. self assert: (absolute at: 2) = 'griffle'. self assert: (absolute at: 3) = 'zonk'. ! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testSlash | path actual | path := Path * 'plonk'. actual := path / 'griffle'. self assert: actual class = path class. self assert: (actual printWithDelimiter: $/) = 'plonk/griffle'! ! !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: 'EstebanLorenzano 4/2/2012 11:42'! testUnequalSize | a b | a := Path * 'plonk'. b := (Path * 'plonk') / 'griffle'. self deny: a = b.! ! !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: '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: 'EstebanLorenzano 4/2/2012 11:42'! testWithExtentionAddsExtension | path result | path := Path * 'plonk'. result := path withExtension: 'griffle'. self assert: result basename = 'plonk.griffle'! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testWithExtentionReplacesExtension | path result | path := Path * 'plonk.griffle'. result := path withExtension: 'griffle'. self assert: result basename = 'plonk.griffle'! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/3/2012 11:16'! testWorkingDirPrintString | path actual | path := Path workingDirectory. actual := path printString. self assert: actual = 'Path workingDirectory'! ! !PathTest methodsFor: 'tests' stamp: 'EstebanLorenzano 4/2/2012 11:42'! testWorkingDirectoryParent | path | path := Path workingDirectory parent. self assert: path size = 1. self assert: (path at: 1) = '..'! ! TestCase subclass: #PerformTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CompilerTests'! !PerformTest commentStamp: 'HenrikSperreJohansen 5/19/2010 02:33' prior: 0! 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: '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! ! !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: 'testing' stamp: 'HenrikSperreJohansen 5/19/2010 02:39'! testPerformWithArgsLargeFrame self shouldnt: [self doPerformOldLargeFrame] raise: Error. ! ! !PerformTest methodsFor: 'testing' stamp: 'HenrikSperreJohansen 5/19/2010 02:39'! testPerformWithArgsSmallFrame self shouldnt: [self doPerformOldSmallFrame] raise: Error. ! ! ComposableModel subclass: #PermissionsEditor instanceVariableNames: 'canBrowse canDebug canDropOSFile canEditCode canEditUser canEvaluateCode canInspect canRunStartupScript canShowMorphHalo user isRoot lock' classVariableNames: '' poolDictionaries: '' category: 'KeyChain-UI'! !PermissionsEditor commentStamp: '' prior: 0! A PermissionsEditor is a GUI for editing a user permissions! !PermissionsEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 15:50'! canBrowse ^ canBrowse! ! !PermissionsEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 15:50'! canDebug ^ canDebug! ! !PermissionsEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 15:50'! canDropOSFile ^ canDropOSFile! ! !PermissionsEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 15:50'! canEditCode ^ canEditCode! ! !PermissionsEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 15:50'! canEditUser ^ canEditUser! ! !PermissionsEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 15:50'! canEvaluateCode ^ canEvaluateCode! ! !PermissionsEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 15:50'! canInspect ^ canInspect! ! !PermissionsEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 15:50'! canRunStartupScript ^ canRunStartupScript! ! !PermissionsEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 15:50'! canShowMorphHalo ^ canShowMorphHalo! ! !PermissionsEditor methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 15:50'! isRoot ^ isRoot! ! !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 8/2/2012 16:23'! initialize "Initialization code for PermissionsEditor" 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:24'! initializeDialogWindow: aWindow aWindow okAction: [ user contents 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 8/2/2012 16:23'! initializePresenter self registerIsRootEvents. self registerUserEvent.! ! !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 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: '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: 'initialize' stamp: 'BenjaminVanRyseghem 5/21/2012 16:04'! setCanBrowse canBrowse state: false; enabled: false; whenChangedDo: [ self checkRoot ]; label: 'Can browse code ?'.! ! !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: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 16:05'! setCanEditCode canEditCode state: false; enabled: false; whenChangedDo: [ self checkRoot ]; label: 'Can edit code ?'! ! !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: '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: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: '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 14:06'! setIsRoot isRoot state: false; enabled: false; label: 'Is this user root ?'! ! !PermissionsEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/21/2012 13:55'! user ^ user contents! ! !PermissionsEditor methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/21/2012 13:55'! user: anUser ^ user contents: anUser! ! !PermissionsEditor methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/21/2012 15:56'! initialExtent ^ (360@300)! ! !PermissionsEditor methodsFor: 'private' stamp: 'BenjaminVanRyseghem 5/21/2012 15:48'! title ^ user contents ifNil: 'Permissions editor' ifNotNil: [:usr | 'Editing ', usr username, '''s permissions' ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PermissionsEditor class instanceVariableNames: ''! !PermissionsEditor class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 1/15/2013 13:51'! internSpec ^{#ComposableSpec. #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)}}! ! Object subclass: #PersonDataExample instanceVariableNames: 'firstName secondName age married' classVariableNames: '' poolDictionaries: '' category: 'Morphic-MorphTreeWidget-Examples'! !PersonDataExample methodsFor: 'accessing' stamp: 'AlainPlantec 2/1/2010 11:51'! age "Answer the value of age" ^ age! ! !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'! 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'! married "Answer the value of married" ^ married! ! !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'! secondName "Answer the value of secondName" ^ secondName! ! !PersonDataExample methodsFor: 'accessing' stamp: 'AlainPlantec 2/1/2010 11:51'! secondName: anObject "Set the value of secondName" secondName := anObject! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PersonDataExample class instanceVariableNames: ''! !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! ! PharoTheme subclass: #PharoOrangeTheme instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Themes'! !PharoOrangeTheme commentStamp: '' prior: 0! I am GLMUITheme2, a small customization based on GLMUITheme (Glamorous) by Tudor Girba. GLMUITheme2 defaultSettings: nil. GLMUITheme2 beCurrent. GLMUITheme2 setPreferredWorldBackground. World backgroundMorph: nil. ! !PharoOrangeTheme methodsFor: 'border-styles' stamp: 'IgorStasenko 1/13/2011 16:40'! listNormalBorderStyleFor: listMorph ^ SimpleBorder new color: (Color black alpha: 0.2); width: 1. ! ! !PharoOrangeTheme methodsFor: 'border-styles' stamp: 'IgorStasenko 1/13/2011 16:43'! scrollPaneNormalBorderStyleFor: aScrollPane "Return the normal borderStyle for the given scroll pane." ^ SimpleBorder new color: (Color black alpha: 0.2); width: 1. ! ! !PharoOrangeTheme methodsFor: 'defaults' stamp: 'IgorStasenko 1/13/2011 16:35'! dialogWindowPreferredCornerStyleFor: aDialogWindow "Answer the preferred corner style for the given dialog." ^#square! ! !PharoOrangeTheme methodsFor: 'defaults' stamp: 'IgorStasenko 1/14/2011 13:32'! selectionBarColor ^ self selectionColor alpha: 0.15 ! ! !PharoOrangeTheme methodsFor: 'fill-styles-buttons' stamp: 'IgorStasenko 1/13/2011 01:15'! buttonMouseOverFillStyleFor: aButton "Return the button mouse over fillStyle for the given color." ^ CompositeFillStyle fillStyles: { self buttonNormalFillStyleFor: aButton. SolidFillStyle color: (Color black alpha: 0.1) } ! ! !PharoOrangeTheme methodsFor: 'fill-styles-buttons' stamp: 'IgorStasenko 1/13/2011 17:54'! buttonSelectedFillStyleFor: aButton "Return the normal button fillStyle for the given button." | top bottom | top := settings selectionColor lighter lighter. bottom := Color gray alpha: 0.1. ^ CompositeFillStyle fillStyles: { self buttonNormalFillStyleFor: aButton. (GradientFillStyle ramp: { 0.8->bottom. 0.9->top. 1.0->top.}) origin: aButton bounds origin; direction: 0 @ aButton height; radial: false } ! ! !PharoOrangeTheme methodsFor: 'fill-styles-buttons' stamp: 'IgorStasenko 1/13/2011 01:17'! buttonSelectedMouseOverFillStyleFor: aButton "Return the normal button fillStyle for the given button." ^ CompositeFillStyle fillStyles: { self buttonSelectedFillStyleFor: aButton. SolidFillStyle color: (Color black alpha: 0.1) } ! ! !PharoOrangeTheme methodsFor: 'fill-styles-buttons' stamp: 'IgorStasenko 1/13/2011 17:08'! controlButtonMouseOverFillStyleFor: aButton ^ self buttonMouseOverFillStyleFor: aButton ! ! !PharoOrangeTheme methodsFor: 'fill-styles-buttons' stamp: 'IgorStasenko 1/13/2011 17:07'! controlButtonNormalFillStyleFor: aButton "Return the normal control button fillStyle for the given button. Control buttons are generally used for drop-lists and expanders." ^self buttonNormalFillStyleFor: aButton! ! !PharoOrangeTheme methodsFor: 'fill-styles-buttons' stamp: 'IgorStasenko 1/13/2011 18:03'! menuItemSelectedFillStyleFor: aMenuItem ^ settings selectionColor! ! !PharoOrangeTheme methodsFor: 'private' stamp: 'IgorStasenko 1/13/2011 17:59'! glamorousBaseSelectionColorFor: aButton ^ settings selectionColor! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PharoOrangeTheme class instanceVariableNames: ''! !PharoOrangeTheme class methodsFor: 'accessing' stamp: 'StephaneDucasse 1/17/2011 12:37'! baseSelectionColor ^ Color orange alpha: 0.66! ! !PharoOrangeTheme class methodsFor: 'accessing' stamp: 'IgorStasenko 1/14/2011 13:37'! lightSelectionColor ^ self baseSelectionColor! ! !PharoOrangeTheme class methodsFor: 'accessing' stamp: 'StephaneDucasse 4/3/2011 22:39'! themeName ^ 'Orange Pharo'! ! !PharoOrangeTheme class methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 9/11/2010 12:35'! veryLightSelectionColor ^ self lightSelectionColor lighter ! ! !PharoOrangeTheme class methodsFor: 'settings' stamp: 'SvenVanCaekenberghe 9/19/2010 18:48'! setDejaVuFontsLarge StandardFonts setFontsFromSpec: #( (buttonFont: 'BitmapDejaVu' 12) (codeFont: 'BitmapDejaVu' 12) (defaultFont: 'BitmapDejaVu' 12) (listFont: 'BitmapDejaVu' 12) (menuFont: 'BitmapDejaVu' 12) (balloonFont: 'BitmapDejaVu' 9) (haloFont: 'BitmapDejaVu' 9) (windowTitleFont: 'BitmapDejaVuBold' 12))! ! !PharoOrangeTheme class methodsFor: 'settings' stamp: 'SvenVanCaekenberghe 9/19/2010 18:48'! setDejaVuFontsSmall StandardFonts setFontsFromSpec: #( (buttonFont: 'BitmapDejaVu' 9) (codeFont: 'BitmapDejaVu' 9) (defaultFont: 'BitmapDejaVu' 9) (listFont: 'BitmapDejaVu' 9) (menuFont: 'BitmapDejaVu' 9) (balloonFont: 'BitmapDejaVu' 7) (haloFont: 'BitmapDejaVu' 7) (windowTitleFont: 'BitmapDejaVuBold' 9))! ! UIThemeWatery2 subclass: #PharoTheme instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Themes'! !PharoTheme commentStamp: '' prior: 0! self defaultSettings: nil. self beCurrent. ! !PharoTheme 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"! ! !PharoTheme 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]]! ! !PharoTheme methodsFor: 'border-styles' stamp: 'TudorGirba 1/13/2011 23:06'! configureWindowBorderFor: aWindow " super configureWindowBorderFor: aWindow. aWindow roundedCorners: #()" | aStyle | aStyle := SimpleBorder new color: (Color black alpha: 0.5); width: 1. aWindow borderStyle: aStyle.! ! !PharoTheme methodsFor: 'border-styles' stamp: 'TudorGirba 1/13/2011 22:59'! configureWindowDropShadowFor: aWindow aWindow hasDropShadow: false! ! !PharoTheme methodsFor: 'border-styles' stamp: 'tg 9/4/2010 22:55'! dropListNormalBorderStyleFor: aDropList "Return the normal borderStyle for the given drop list" ^ self buttonNormalBorderStyleFor: aDropList! ! !PharoTheme 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))! ! !PharoTheme 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! ! !PharoTheme methodsFor: 'border-styles' stamp: 'tg 8/31/2010 15:28'! tabLabelNormalBorderStyleFor: aTabLabel " ^SimpleBorder new width: 0; baseColor: (self buttonBaseColorFor: aTabLabel) darker " ^ self buttonNormalBorderStyleFor: aTabLabel! ! !PharoTheme methodsFor: 'border-styles' stamp: 'StephaneDucasse 4/11/2011 22:31'! tabPanelBorderStyleFor: aTabGroup ^ ExtendedTabPanelBorder new width: 1; baseColor: ((self glamorousDarkBaseColorFor: aTabGroup)); tabSelector: aTabGroup tabSelectorMorph! ! !PharoTheme methodsFor: 'border-styles' stamp: 'tg 9/4/2010 20:23'! taskbarThumbnailCornerStyleFor: aMorph "Answer the corner style for the taskbar thumbnail/tasklist." ^#square! ! !PharoTheme methodsFor: 'border-styles' stamp: 'tg 9/4/2010 20:56'! taskbarThumbnailNormalBorderStyleFor: aWindow ^ self buttonNormalBorderStyleFor: aWindow! ! !PharoTheme 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! ! !PharoTheme methodsFor: 'border-styles-buttons' stamp: 'tg 9/4/2010 23:06'! buttonCornerStyleIn: aThemedMorph "If asked, we only allow square corners" ^ #square! ! !PharoTheme methodsFor: 'border-styles-buttons' stamp: 'tg 9/9/2010 22:43'! 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! ! !PharoTheme methodsFor: 'border-styles-scrollbars' stamp: 'tg 8/31/2010 13:27'! scrollbarPagingAreaCornerStyleIn: aThemedMorph ^#square! ! !PharoTheme methodsFor: 'fill-styles' stamp: 'tg 9/3/2010 12:30'! dockingBarNormalFillStyleFor: aToolDockingBar ^ SolidFillStyle color: Color transparent! ! !PharoTheme methodsFor: 'fill-styles' stamp: 'tg 9/5/2010 20:47'! dropListDisabledFillStyleFor: aDropList "Return the disabled fillStyle for the given drop list." ^ self textEditorDisabledFillStyleFor: aDropList! ! !PharoTheme 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! ! !PharoTheme methodsFor: 'fill-styles' stamp: 'tg 9/5/2010 20:48'! listDisabledFillStyleFor: aList "Return the disabled fillStyle for the given list." ^ self textEditorDisabledFillStyleFor: aList! ! !PharoTheme methodsFor: 'fill-styles' stamp: 'tg 9/5/2010 20:51'! progressBarFillStyleFor: aProgressBar ^ self glamorousBasePassiveBackgroundColorFor: aProgressBar! ! !PharoTheme methodsFor: 'fill-styles' stamp: 'tg 9/7/2010 13:52'! progressBarProgressFillStyleFor: aProgressBar ^ (self glamorousLightSelectionColorFor: aProgressBar)! ! !PharoTheme 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! ! !PharoTheme methodsFor: 'fill-styles' stamp: 'tg 9/5/2010 20:48'! sliderDisabledFillStyleFor: aSlider "Return the disabled fillStyle for the given slider." ^ self textEditorDisabledFillStyleFor: aSlider! ! !PharoTheme methodsFor: 'fill-styles' stamp: 'SeanDeNigris 1/29/2013 08:29'! splitterNormalFillStyleFor: aSplitter |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! ! !PharoTheme methodsFor: 'fill-styles' stamp: 'SeanDeNigris 1/29/2013 08:29'! splitterPressedFillStyleFor: aSplitter ^ self splitterNormalFillStyleFor: aSplitter.! ! !PharoTheme methodsFor: 'fill-styles' stamp: 'tg 8/31/2010 12:51'! taskbarFillStyleFor: aTaskbar ^ self buttonNormalFillStyleFor: aTaskbar! ! !PharoTheme methodsFor: 'fill-styles' stamp: 'tg 9/5/2010 20:46'! textEditorDisabledFillStyleFor: aTextEditor "Return the disabled fillStyle for the given text editor." ^self glamorousBasePassiveBackgroundColorFor: aTextEditor! ! !PharoTheme methodsFor: 'fill-styles' stamp: 'tg 9/13/2010 10:41'! windowActiveFillStyleFor: aWindow "We do not want the lighting effect when the window goes inactive" ^SolidFillStyle color: self class baseColor! ! !PharoTheme methodsFor: 'fill-styles' stamp: 'tg 9/3/2010 12:22'! windowActiveTitleFillStyleFor: aWindow ^ self glamorousNormalFillStyleFor: aWindow height: aWindow labelHeight! ! !PharoTheme 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! ! !PharoTheme methodsFor: 'fill-styles' stamp: 'tg 9/2/2010 13:51'! windowInactiveTitleFillStyleFor: aWindow "We do not want the lighting effect when the window goes inactive" ^self windowActiveTitleFillStyleFor: aWindow! ! !PharoTheme 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! ! !PharoTheme methodsFor: 'fill-styles-buttons' stamp: 'ThierryGoubier 5/22/2012 17:13'! buttonPressedFillStyleFor: aButton "Return the normal button fillStyle for the given button." (aButton valueOfProperty: #noFill ifAbsent: [false]) ifTrue: [^ SolidFillStyle color: Color transparent ]. ^ self glamorousReverseFillStyleFor: aButton height: aButton height! ! !PharoTheme 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! ! !PharoTheme 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! ! !PharoTheme methodsFor: 'fill-styles-buttons' stamp: 'tg 8/31/2010 11:13'! tabLabelNormalFillStyleFor: aTabLabel ^ self buttonNormalFillStyleFor: aTabLabel ! ! !PharoTheme methodsFor: 'fill-styles-buttons' stamp: 'tg 8/31/2010 11:13'! tabLabelSelectedFillStyleFor: aTabLabel ^ self buttonSelectedFillStyleFor: aTabLabel ! ! !PharoTheme 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! ! !PharoTheme 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! ! !PharoTheme methodsFor: 'fill-styles-scrollbars' stamp: 'tg 9/13/2010 10:50'! 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])! ! !PharoTheme methodsFor: 'fill-styles-scrollbars' stamp: 'ThierryGoubier 5/22/2012 17:10'! scrollbarPressedThumbFillStyleFor: aScrollbar "Return the normal scrollbar fillStyle for the given scrollbar." ^ (self glamorousReverseFillStyleWithBaseColor: aScrollbar paneColor for: aScrollbar height: aScrollbar height) direction: (aScrollbar bounds isWide ifTrue: [0 @ aScrollbar height] ifFalse: [aScrollbar width @ 0])! ! !PharoTheme methodsFor: 'forms' stamp: 'FernandoOlivero 10/28/2010 09:08'! checkboxForm "Answer the form to use for a normal checkbox." ^self checkboxUnselectedForm! ! !PharoTheme methodsFor: 'forms' stamp: 'StephaneDucasse 4/11/2011 22:33'! checkboxSelectedForm "Answer the form to use for a selected checkbox." ^PharoUIThemeIcons checkboxSelectedForm! ! !PharoTheme methodsFor: 'forms' stamp: 'StephaneDucasse 4/11/2011 22:32'! checkboxUnselectedForm "Answer the form to use for a selected checkbox." ^ PharoUIThemeIcons checkboxUnselectedForm! ! !PharoTheme methodsFor: 'forms' stamp: 'StephaneDucasse 4/11/2011 22:32'! menuPinForm "Answer the form to use for the pin button of a menu." ^ PharoUIThemeIcons menuPinForm! ! !PharoTheme methodsFor: 'forms' stamp: 'StephaneDucasse 4/11/2011 22:32'! newCheckboxMarkerForm "Answer a new checkbox marker form." ^PharoUIThemeIcons checkboxMarkerForm! ! !PharoTheme methodsFor: 'forms' stamp: 'StephaneDucasse 4/11/2011 22:32'! 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." ^PharoUIThemeIcons radioButtonMarkerForm ! ! !PharoTheme methodsFor: 'forms' stamp: 'StephaneDucasse 4/11/2011 22:32'! newWindowCloseForm "Answer a new form for a window close box." ^ PharoUIThemeIcons windowCloseForm ! ! !PharoTheme methodsFor: 'forms' stamp: 'FernandoOlivero 10/28/2010 14:18'! newWindowCloseOverForm "Answer a new form for a window menu box." ^ self newWindowCloseForm! ! !PharoTheme methodsFor: 'forms' stamp: 'StephaneDucasse 4/11/2011 22:32'! newWindowMaximizeForm "Answer a new form for a window maximize box." ^ PharoUIThemeIcons windowMaximizeForm! ! !PharoTheme methodsFor: 'forms' stamp: 'FernandoOlivero 10/28/2010 14:18'! newWindowMaximizeOverForm "Answer a new form for a window menu box." ^ self newWindowMaximizeForm! ! !PharoTheme methodsFor: 'forms' stamp: 'StephaneDucasse 4/11/2011 22:32'! newWindowMenuForm "Answer a new form for a window menu box." ^ PharoUIThemeIcons windowMenuForm! ! !PharoTheme methodsFor: 'forms' stamp: 'StephaneDucasse 4/11/2011 22:32'! newWindowMenuPassiveForm "Answer a new form for a window menu box." ^ PharoUIThemeIcons windowMenuInactiveForm! ! !PharoTheme methodsFor: 'forms' stamp: 'StephaneDucasse 4/11/2011 22:32'! newWindowMinimizeForm "Answer a new form for a window minimize box." ^ PharoUIThemeIcons windowMinimizeForm! ! !PharoTheme methodsFor: 'forms' stamp: 'FernandoOlivero 10/28/2010 15:09'! newWindowMinimizeOverForm "Answer a new form for a window menu box." ^ self newWindowMinimizeForm! ! !PharoTheme methodsFor: 'forms' stamp: 'StephaneDucasse 4/11/2011 22:32'! radioButtonForm "Answer the form to use for a normal radio button." ^ PharoUIThemeIcons radioButtonUnselectedForm! ! !PharoTheme methodsFor: 'forms' stamp: 'StephaneDucasse 4/11/2011 22:32'! radioButtonSelectedForm "Answer the form to use for a selected radio button." ^ PharoUIThemeIcons radioButtonSelectedForm ! ! !PharoTheme methodsFor: 'forms' stamp: 'StephaneDucasse 4/11/2011 22:32'! windowClosePassiveForm "Answer the form to use for passive (background) window close buttons" ^PharoUIThemeIcons windowCloseInactiveForm! ! !PharoTheme methodsFor: 'forms' stamp: 'StephaneDucasse 4/11/2011 22:32'! windowMaximizePassiveForm "Answer the form to use for passive (background) window maximize/restore buttons" ^PharoUIThemeIcons windowMaximizeInactiveForm! ! !PharoTheme methodsFor: 'forms' stamp: 'StephaneDucasse 4/11/2011 22:32'! windowMinimizePassiveForm "Answer the form to use for passive (background) window minimize buttons" ^PharoUIThemeIcons windowMinimizeInactiveForm! ! !PharoTheme methodsFor: 'initialize-release' stamp: 'tg 8/31/2010 13:51'! initialize "self beCurrent" super initialize. self windowActiveDropShadowStyle: #nodiffuse! ! !PharoTheme methodsFor: 'initialize-release' stamp: 'tg 9/6/2010 14:38'! newRadioMarkerForm "Answer a new checkbox marker form." ^Form extent: 12@12 depth: 32! ! !PharoTheme 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]! ! !PharoTheme 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! ! !PharoTheme methodsFor: 'label-styles' stamp: 'tg 9/3/2010 10:52'! windowMenuPassiveForm "Answer the form to use for passive (background) window menu buttons" ^self newWindowMenuPassiveForm! ! !PharoTheme methodsFor: 'morph creation' stamp: 'BenjaminVanRyseghem 7/13/2012 14:45'! newFocusIndicatorMorphFor: aMorph "Answer a new focus indicator for the given morph." |radius| radius := aMorph focusIndicatorCornerRadius. ^ BorderedMorph new fillStyle: Color transparent; borderStyle: (SimpleBorder new width: 2; baseColor: (self glamorousBaseSelectionColorFor: aMorph)); bounds: aMorph focusBounds! ! !PharoTheme 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]"! ! !PharoTheme methodsFor: 'private' stamp: 'CamilloBruni 9/1/2012 20:06'! glamorousBasePassiveBackgroundColorFor: aButton ^ Color white! ! !PharoTheme methodsFor: 'private' stamp: 'tg 9/5/2010 20:40'! glamorousBaseSelectionColorFor: aButton ^ self class baseSelectionColor! ! !PharoTheme methodsFor: 'private' stamp: 'tg 9/9/2010 22:50'! glamorousDarkBaseColorFor: aButton ^ self class darkBaseColor! ! !PharoTheme methodsFor: 'private' stamp: 'tg 9/9/2010 22:02'! glamorousLightColorFor: aButton ^ self class lightBaseColor! ! !PharoTheme methodsFor: 'private' stamp: 'tg 9/5/2010 21:44'! glamorousLightSelectionColorFor: aMorph ^ self class lightSelectionColor! ! !PharoTheme methodsFor: 'private' stamp: 'tg 9/13/2010 10:49'! 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 ! ! !PharoTheme methodsFor: 'private' stamp: 'tg 9/13/2010 10:49'! glamorousNormalFillStyleWithBaseColor: aColor for: aMorph height: anInteger | top bottom | top := aColor twiceLighter. bottom := aColor. ^(GradientFillStyle ramp: { 0.0->top. 0.7->bottom.}) origin: aMorph bounds origin; direction: 0 @ anInteger; radial: false! ! !PharoTheme methodsFor: 'private' stamp: 'ThierryGoubier 5/22/2012 17:13'! glamorousReverseFillStyleFor: aMorph height: anInteger "Return the normal button fillStyle for the given button." | baseColor | baseColor := self glamorousBaseColorFor: aMorph. ^ self glamorousReverseFillStyleWithBaseColor: baseColor for: aMorph height: anInteger ! ! !PharoTheme methodsFor: 'private' stamp: 'ThierryGoubier 5/22/2012 17:09'! glamorousReverseFillStyleWithBaseColor: aColor for: aMorph height: anInteger | top bottom | top := aColor twiceLighter. bottom := aColor. ^(GradientFillStyle ramp: { 0.0->bottom. 0.7->top.}) origin: aMorph bounds origin; direction: 0 @ anInteger; radial: false! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PharoTheme class instanceVariableNames: ''! !PharoTheme class methodsFor: 'accessing' stamp: 'StephaneDucasse 6/10/2012 20:24'! baseColor ^ Color r: 199 g: 192 b: 181 range: 255! ! !PharoTheme class methodsFor: 'accessing' stamp: 'CamilloBruni 10/9/2012 20:14'! basePassiveBackgroundColor ^ self baseColor lighter! ! !PharoTheme class methodsFor: 'accessing' stamp: 'tg 9/5/2010 21:46'! baseSelectionColor ^ Color r: 97 g: 163 b: 225 range: 255! ! !PharoTheme class methodsFor: 'accessing' stamp: 'CamilloBruni 10/9/2012 20:15'! darkBaseColor ^ self baseColor darker! ! !PharoTheme class methodsFor: 'accessing' stamp: 'CamilloBruni 10/9/2012 20:15'! lightBaseColor ^ self baseColor lighter! ! !PharoTheme class methodsFor: 'accessing' stamp: 'CamilloBruni 10/9/2012 20:14'! lightSelectionColor ^ self baseSelectionColor lighter! ! !PharoTheme class methodsFor: 'accessing' stamp: 'StephaneDucasse 4/3/2011 22:39'! themeName ^ 'Pharo'! ! !PharoTheme class methodsFor: 'accessing' stamp: 'CamilloBruni 10/9/2012 20:13'! veryLightSelectionColor ^ self lightSelectionColor lighter! ! !PharoTheme class methodsFor: 'settings' stamp: 'AlainPlantec 2/11/2011 20:58'! newDefaultSettings BalloonMorph setBalloonColorTo: self lightSelectionColor. ^super newDefaultSettings unfocusedSelectionColor: nil; menuColor: self baseColor; menuTitleColor: self baseColor; windowColor: self baseColor; selectionColor: self lightSelectionColor; menuSelectionColor: self baseSelectionColor; progressBarColor: self baseColor; standardColorsOnly: true; autoSelectionColor: false; preferRoundCorner: false; flatMenu: true! ! !PharoTheme class methodsFor: 'settings' stamp: 'tg 9/13/2010 10:40'! setPreferredWorldBackground "self setPreferredWorldBackground" "World color: ( (GradientFillStyle ramp: { 0.0 -> Color white. 1.0 -> Color gray}) origin: 50 @ 50; direction: 800@0; normal: 0@800; radial: true)" World color: Color white! ! !PharoTheme class methodsFor: 'private' stamp: 'StephaneDucasse 4/11/2011 22:33'! 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: PharoUIThemeIcons category: '*glamour-morphic-theme'! ! !PharoTheme 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! ! Object subclass: #PharoTrackerLabels instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CI-Core'! !PharoTrackerLabels commentStamp: '' prior: 0! I contain the labels for the google issue tracker entries! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PharoTrackerLabels class instanceVariableNames: ''! !PharoTrackerLabels class methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/4/2012 16:38'! accepted ^ #Accepted! ! !PharoTrackerLabels class methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/30/2012 17:13'! issueChecked ^ #ValidatedByTheMonkey! ! !PharoTrackerLabels class methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/29/2012 15:17'! noSourcesAvailable ^ #NoSourcesAvailable! ! !PharoTrackerLabels class methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/29/2012 15:17'! reviewNeeded ^ #FixReviewNeeded! ! !PharoTrackerLabels class methodsFor: 'accessing' stamp: 'ClementBEra 1/30/2013 15:38'! testFailure ^ #'WorkNeeded-FailingTest'! ! !PharoTrackerLabels class methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/29/2012 15:17'! workNeeded ^ #WorkNeeded! ! ThemeIcons subclass: #PharoUIThemeIcons instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Themes'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PharoUIThemeIcons class instanceVariableNames: ''! !PharoUIThemeIcons class methodsFor: 'as yet unclassified' 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! ! !PharoUIThemeIcons class methodsFor: 'as yet unclassified' stamp: 'FernandoOlivero 10/28/2010 14:10'! checkboxSelectedForm ^ self form16x16FromContents: self checkboxSelectedFormContents ! ! !PharoUIThemeIcons class methodsFor: 'as yet unclassified' 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)! ! !PharoUIThemeIcons class methodsFor: 'as yet unclassified' stamp: 'FernandoOlivero 10/28/2010 13:40'! checkboxUnselectedForm ^ self form16x16FromContents: self checkboxUnselectedFormContents ! ! !PharoUIThemeIcons class methodsFor: 'as yet unclassified' 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)! ! !PharoUIThemeIcons class methodsFor: 'as yet unclassified' stamp: 'FernandoOlivero 10/28/2010 13:39'! form16x16FromContents: aByteArray ^ Form extent: 16@16 depth: 32 fromArray: aByteArray offset: 0@0! ! !PharoUIThemeIcons class methodsFor: 'as yet unclassified' stamp: 'FernandoOlivero 10/28/2010 13:40'! menuPinForm ^self form16x16FromContents: self menuPinFormContents ! ! !PharoUIThemeIcons class methodsFor: 'as yet unclassified' 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)! ! !PharoUIThemeIcons class methodsFor: 'as yet unclassified' 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! ! !PharoUIThemeIcons class methodsFor: 'as yet unclassified' stamp: 'FernandoOlivero 10/28/2010 13:40'! radioButtonSelectedForm ^ self form16x16FromContents: self radioButtonSelectedFormContents! ! !PharoUIThemeIcons class methodsFor: 'as yet unclassified' 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)! ! !PharoUIThemeIcons class methodsFor: 'as yet unclassified' stamp: 'FernandoOlivero 10/28/2010 13:40'! radioButtonUnselectedForm ^ self form16x16FromContents: self radioButtonUnselectedFormContents ! ! !PharoUIThemeIcons class methodsFor: 'as yet unclassified' 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)! ! !PharoUIThemeIcons class methodsFor: 'as yet unclassified' stamp: 'FernandoOlivero 10/27/2010 15:14'! radioSelectedForm ^ Form fromBinaryStream: ( Base64MimeConverter mimeDecodeToBytes: self radioSelectedFormContents readStream) ! ! !PharoUIThemeIcons class methodsFor: 'as yet unclassified' 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! ! !PharoUIThemeIcons class methodsFor: 'as yet unclassified' stamp: 'FernandoOlivero 10/27/2010 15:14'! radioUnselectedForm ^ Form fromBinaryStream: ( Base64MimeConverter mimeDecodeToBytes: self radioUnselectedFormContents readStream) ! ! !PharoUIThemeIcons class methodsFor: 'as yet unclassified' 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! ! !PharoUIThemeIcons class methodsFor: 'as yet unclassified' stamp: 'FernandoOlivero 10/28/2010 13:41'! windowCloseForm ^ self form16x16FromContents: self windowCloseFormContents ! ! !PharoUIThemeIcons class methodsFor: 'as yet unclassified' 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)! ! !PharoUIThemeIcons class methodsFor: 'as yet unclassified' stamp: 'FernandoOlivero 10/28/2010 13:41'! windowCloseInactiveForm ^ self form16x16FromContents: self windowCloseInactiveFromContents ! ! !PharoUIThemeIcons class methodsFor: 'as yet unclassified' 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)! ! !PharoUIThemeIcons class methodsFor: 'as yet unclassified' stamp: 'FernandoOlivero 10/28/2010 13:41'! windowMaximizeForm ^ self form16x16FromContents: self windowMaximizeFormContents ! ! !PharoUIThemeIcons class methodsFor: 'as yet unclassified' 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) ! ! !PharoUIThemeIcons class methodsFor: 'as yet unclassified' stamp: 'FernandoOlivero 10/28/2010 13:41'! windowMaximizeInactiveForm ^ self form16x16FromContents: self windowMaximizeInactiveFormContents ! ! !PharoUIThemeIcons class methodsFor: 'as yet unclassified' 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)! ! !PharoUIThemeIcons class methodsFor: 'as yet unclassified' stamp: 'FernandoOlivero 10/28/2010 13:52'! windowMenuForm ^self form16x16FromContents: self windowMenuFormContents ! ! !PharoUIThemeIcons class methodsFor: 'as yet unclassified' 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)! ! !PharoUIThemeIcons class methodsFor: 'as yet unclassified' stamp: 'FernandoOlivero 10/28/2010 13:41'! windowMenuInactiveForm ^self form16x16FromContents: self windowMenuInactiveFormContents ! ! !PharoUIThemeIcons class methodsFor: 'as yet unclassified' 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)! ! !PharoUIThemeIcons class methodsFor: 'as yet unclassified' stamp: 'FernandoOlivero 10/28/2010 13:41'! windowMinimizeForm ^self form16x16FromContents: self windowMinimizeFormContents ! ! !PharoUIThemeIcons class methodsFor: 'as yet unclassified' 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)! ! !PharoUIThemeIcons class methodsFor: 'as yet unclassified' stamp: 'FernandoOlivero 10/28/2010 13:42'! windowMinimizeInactiveForm ^self form16x16FromContents: self windowMinimizeInactiveFormContents ! ! !PharoUIThemeIcons class methodsFor: 'as yet unclassified' 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)! ! Object subclass: #PharoUser instanceVariableNames: 'avatar username keychain unlockedKeychain permissions' classVariableNames: '' poolDictionaries: '' category: 'KeyChain'! !PharoUser commentStamp: '' prior: 0! 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: 'accessing' stamp: 'BenjaminVanRyseghem 5/9/2012 13:55'! avatar ^ avatar! ! !PharoUser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/9/2012 16:27'! avatar: email self updateGravatarFor: email! ! !PharoUser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/9/2012 16:11'! keychain ^ keychain! ! !PharoUser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/16/2012 15:02'! permissions ^ permissions ifNil: [ permissions := PharoUserPermissions new ]! ! !PharoUser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/11/2012 16:40'! unlockedKeychain ^ unlockedKeychain! ! !PharoUser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/9/2012 13:55'! username ^ username! ! !PharoUser methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/9/2012 13:55'! username: anObject username := anObject! ! !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: '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 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: 'initialize' stamp: 'BenjaminVanRyseghem 5/16/2012 15:40'! defaultAvatar ^ ImageMorph new color: Color transparent; height: 1; width: 1; yourself ! ! !PharoUser methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 5/16/2012 15:55'! initialize "Initialization code for PharoUser" super initialize. avatar := self defaultAvatar. self updateGravatarFor: ''. keychain := KeyChain new. unlockedKeychain := UnlockedKeyChain new.! ! !PharoUser methodsFor: 'printing' stamp: 'BenjaminVanRyseghem 5/9/2012 14:03'! printOn: aStream super printOn: aStream. aStream nextPut: $(. username printOn: aStream. aStream nextPut: $)! ! !PharoUser methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/20/2012 03:25'! lock ^ keychain lock! ! !PharoUser methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 5/11/2012 16:37'! unlock ^ keychain unlock! ! !PharoUser methodsFor: 'protocol-forward' stamp: 'BenjaminVanRyseghem 5/9/2012 16:11'! setPassword: aString ^ self keychain setPassword: aString ! ! !PharoUser methodsFor: 'protocol-forward' stamp: 'BenjaminVanRyseghem 5/11/2012 16:40'! setUserName: user forGroup: group ^ self unlockedKeychain setUserName: user forGroup: group! ! !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: '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'! userNamePasswordFor: aGroup ^ self keychain userNamePasswordFor: aGroup ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PharoUser class instanceVariableNames: ''! !PharoUser class methodsFor: 'instance creation' stamp: 'EstebanLorenzano 12/12/2012 11:23'! username: username ^ UsersManager default users detect: [:e | e username = username ] ifNone: [ self new username: username; yourself ]! ! Object subclass: #PharoUserPermissions instanceVariableNames: 'canBrowse canDebug canDropOSFile canEditCode canEvaluateCode canInspect canRunStartupScript canShowMorphHalo canEditUser' classVariableNames: 'PharoUsers' poolDictionaries: '' category: 'KeyChain'! !PharoUserPermissions commentStamp: '' prior: 0! A PharoUserPermissions is a wrapper which stores the permissions of a PharoUser! !PharoUserPermissions methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 11:35'! canBrowse ^ canBrowse! ! !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 ^ canDebug! ! !PharoUserPermissions methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 11:35'! canDebug: anObject canDebug := anObject! ! !PharoUserPermissions methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 11:35'! canDropOSFile ^ canDropOSFile! ! !PharoUserPermissions methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 11:35'! canDropOSFile: anObject canDropOSFile := anObject! ! !PharoUserPermissions methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 11:35'! canEditCode ^ canEditCode! ! !PharoUserPermissions methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 11:35'! canEditCode: anObject canEditCode := anObject! ! !PharoUserPermissions methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 13:50'! canEditUser ^ canEditUser! ! !PharoUserPermissions methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 13:50'! canEditUser: anObject canEditUser := anObject! ! !PharoUserPermissions methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 11:35'! canEvaluateCode ^ canEvaluateCode! ! !PharoUserPermissions methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 11:35'! canEvaluateCode: anObject canEvaluateCode := anObject! ! !PharoUserPermissions methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 11:35'! canInspect ^ canInspect! ! !PharoUserPermissions methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 11:35'! canInspect: anObject canInspect := anObject! ! !PharoUserPermissions methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 5/21/2012 11:35'! canRunStartupScript ^ canRunStartupScript! ! !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'! canShowMorphHalo: anObject canShowMorphHalo := anObject! ! !PharoUserPermissions methodsFor: 'initialize' stamp: 'BenjaminVanRyseghem 5/21/2012 13:52'! initialize "Initialization code for PharoUserPermissions" super initialize. canBrowse := false. canDebug := false. canDropOSFile := false. canEditCode := false. canEvaluateCode := false. canInspect := false. canRunStartupScript := false. canShowMorphHalo := false. canEditUser := false.! ! !PharoUserPermissions methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 8/2/2012 16:02'! isRoot: aBoolean canBrowse := aBoolean. canDebug := aBoolean. canDropOSFile := aBoolean. canEditCode := aBoolean. canEvaluateCode := aBoolean. canInspect := aBoolean. canRunStartupScript := aBoolean. canShowMorphHalo := aBoolean. canEditUser := aBoolean.! ! ComposableModel subclass: #PickListModel instanceVariableNames: 'defaultValueHolder labelClickableHolder listModel pickedItemsHolder wrapHolder associationsItemToWrapper associationsWrapperToItem associationsIndexToWrapper blockToPerformOnWrappers' classVariableNames: '' poolDictionaries: '' category: 'Spec-Widgets-PolyWidgets'! !PickListModel commentStamp: '' prior: 0! A PickList is a tick list done using spec.! !PickListModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/22/2013 00:08'! blockToPerformOnWrappers ^ blockToPerformOnWrappers contents! ! !PickListModel methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 2/22/2013 00:08'! blockToPerformOnWrappers: aBlock blockToPerformOnWrappers contents: aBlock! ! !PickListModel methodsFor: 'accessing'! listModel ^ listModel! ! !PickListModel methodsFor: 'accessing'! wrapHolder ^ wrapHolder! ! !PickListModel methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 2/22/2013 00:07'! initialize "Initialization code for PickList" wrapHolder := [ :i | i printString ] asValueHolder. pickedItemsHolder := OrderedCollection new asValueHolder. associationsWrapperToItem := Dictionary new asValueHolder. associationsItemToWrapper := Dictionary new asValueHolder. associationsIndexToWrapper := Dictionary new asValueHolder. labelClickableHolder := true asValueHolder. defaultValueHolder := false asValueHolder. blockToPerformOnWrappers := [:wrapper | ] asValueHolder. super initialize.! ! !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: 'initialization' stamp: 'CamilloBruni 10/8/2012 22:15'! initializeWidgets self instantiateModels: #( listModel ListComposableModel ). listModel displayBlock: [ :item | item ]. self focusOrder add: listModel! ! !PickListModel methodsFor: 'protocol'! checkboxFor: anItem ^ associationsItemToWrapper at: anItem ifAbsent: [ nil ]! ! !PickListModel methodsFor: 'protocol'! defaultValue ^ defaultValueHolder contents! ! !PickListModel methodsFor: 'protocol'! defaultValue: aBoolean defaultValueHolder contents: aBoolean! ! !PickListModel methodsFor: 'protocol' stamp: 'bvr 6/2/2012 12:44'! displayBlock: aBlock wrapHolder contents: aBlock! ! !PickListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 2/22/2013 00:25'! indexFor: aCheckbox ^ listModel listItems indexOf: aCheckbox.! ! !PickListModel methodsFor: 'protocol'! itemFor: aCheckbox ^ associationsWrapperToItem at: aCheckbox ifAbsent: [ nil ]! ! !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: 'protocol'! labelClickable ^ labelClickableHolder contents! ! !PickListModel methodsFor: 'protocol'! labelClickable: aBoolean labelClickableHolder contents: aBoolean! ! !PickListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 2/6/2013 19:05'! pickedItems "Returns the selected items according to the order they have been picked" ^ pickedItemsHolder contents! ! !PickListModel methodsFor: 'protocol'! resetSelection listModel resetSelection! ! !PickListModel methodsFor: 'protocol'! selectedIndex ^ listModel selectedIndex! ! !PickListModel methodsFor: 'protocol'! selectedItem ^ associationsWrapperToItem at: listModel selectedItem ifAbsent: [ nil ]! ! !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: 'CamilloBruni 10/8/2012 21:56'! setSelectedIndex: anIndex listModel setSelectedIndex: anIndex! ! !PickListModel methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 2/21/2013 23:45'! wrappers ^ associationsWrapperToItem keys! ! !PickListModel methodsFor: 'protocol-events' stamp: 'bvr 5/31/2012 13:34'! whenListChanged: aBlock listModel whenListChanged: aBlock! ! !PickListModel methodsFor: 'protocol-events' stamp: 'bvr 5/31/2012 13:34'! whenPickedItemsChanged: aBlock pickedItemsHolder whenChangedDo: aBlock! ! !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: 'protocol-events' stamp: 'StephaneDucasse 5/17/2012 19:32'! whenSelectionChanged: aBlock listModel whenSelectionChanged: aBlock! ! !PickListModel methodsFor: 'protocol-events' stamp: 'bvr 5/31/2012 13:34'! whenSelectionIndexChanged: aBlock listModel whenSelectionIndexChanged: aBlock! ! !PickListModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 1/24/2013 14:18'! addPicked: item pickedItemsHolder add: item. pickedItemsHolder contentsChanged: true to: item.! ! !PickListModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 1/24/2013 14:18'! removePicked: item pickedItemsHolder remove: item ifAbsent: [ ^ self ].! ! !PickListModel methodsFor: 'private' stamp: 'BenjaminVanRyseghem 2/22/2013 00:19'! wrap: item at: index | checkBox | associationsIndexToWrapper at: index ifPresent: [:cb | ^ cb ]. checkBox := self instantiate: CheckBoxModel. blockToPerformOnWrappers contents value: checkBox. checkBox label: (wrapHolder contents 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 class instanceVariableNames: ''! !PickListModel class methodsFor: '*Spec-Builder' stamp: 'BenjaminVanRyseghem 2/28/2012 14:17'! possibleEvents ^ #(whenListChanges whenSelectionChanges whenSelectedItemChanges whenSelectedIndexChanges whenPickeItemsChanges)! ! !PickListModel class methodsFor: 'example'! example "self example" | instance | instance := self new. instance openWithSpec. instance items: { {1. 2. 4}. 'Foo'. 123}! ! !PickListModel class methodsFor: 'specs' stamp: 'BenjaminVanRyseghem 6/12/2012 18:32'! defaultSpec ^ SpecLayout composed add: #listModel; yourself! ! !PickListModel class methodsFor: 'specs'! title ^ 'Pick List Example'! ! MultipleSettingDeclaration subclass: #PickOneSettingDeclaration instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Settings-Core'! !PickOneSettingDeclaration commentStamp: 'AlainPlantec 1/3/2011 10:53' prior: 0! 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: '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: 'AlainPlantec 9/3/2010 11:19'! defaultValue ^ self default value ifNil: [self domainValues first realValue] ! ! !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: 'alain.plantec 10/17/2009 23:39'! index: anInteger self realValue: (self domainValues at: anInteger) realValue. ! ! !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! ! PanelMorph subclass: #PlainGroupboxMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !PlainGroupboxMorph commentStamp: 'gvc 5/18/2007 12:36' prior: 0! 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: 'as yet unclassified' stamp: 'gvc 1/17/2008 11:44'! initialize "Initialize the receiver." super initialize. self borderStyle: (self theme plainGroupPanelBorderStyleFor: self); changeTableLayout; layoutInset: (4@4 corner: 4@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]! ! FileSystemResolver subclass: #PlatformResolver instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Core-Implementation'! !PlatformResolver commentStamp: 'cwp 11/18/2009 11:56' prior: 0! I am an abstract superclass for platform-specific resolvers.! !PlatformResolver methodsFor: 'origins' stamp: 'lr 7/13/2010 15:35'! desktop ^ self subclassResponsibility! ! !PlatformResolver methodsFor: 'origins' stamp: 'lr 7/13/2010 15:35'! documents ^ self subclassResponsibility! ! !PlatformResolver methodsFor: 'origins' stamp: 'cwp 10/27/2009 21:01'! home ^ self subclassResponsibility! ! !PlatformResolver methodsFor: 'origins' stamp: 'CamilloBruni 5/24/2012 12:07'! preferences ^ self subclassResponsibility! ! !PlatformResolver methodsFor: 'resolving' stamp: 'CamilloBruni 5/24/2012 12:46'! supportedOrigins ^ #(home desktop documents preferences)! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PlatformResolver class instanceVariableNames: ''! !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! ! !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'.! ! FileSystemResolverTest subclass: #PlatformResolverTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Tests-Core'! !PlatformResolverTest methodsFor: 'running' stamp: 'EstebanLorenzano 4/2/2012 11:39'! createResolver ^ PlatformResolver forCurrentPlatform! ! !PlatformResolverTest methodsFor: 'tests' stamp: 'cwp 10/27/2009 10:57'! testHome self assertOriginResolves: #home! ! AlignmentMorph subclass: #PluggableButtonMorph instanceVariableNames: 'model label getStateSelector actionSelector getLabelSelector getMenuSelector shortcutCharacter askBeforeChanging triggerOnMouseDown offColor onColor feedbackColor showSelectionFeedback allButtons arguments argumentsProvider argumentsSelector gradientLook enabled actionBlock getColorSelector getEnabledSelector' classVariableNames: 'UseGradientLook' poolDictionaries: '' category: 'Morphic-Pluggable Widgets'! !PluggableButtonMorph commentStamp: '' prior: 0! 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: '*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 1/23/2007 11:25'! action "Answer the action selector." ^self actionSelector! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' 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: '*Polymorph-Widgets' stamp: 'gvc 7/24/2007 16:14'! adoptColor: aColor "Go through paneColorChanged instead." self paneColorChanged! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' 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 1/23/2007 11:27'! arguments "Answer the static arguments. SimpleButtonMorph cross-compatibility." ^arguments! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' 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: '*Polymorph-Widgets' 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: '*Polymorph-Widgets' 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: '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: '*Polymorph-Widgets' stamp: 'AlainPlantec 12/19/2009 23:58'! color: aColor "Check to avoid repeats of the same color." aColor ifNil: [^self]. ((self valueOfProperty: #lastColor) = aColor and: [ self getModelState = (self valueOfProperty: #lastState)]) ifTrue: [^self]. super color: aColor. self class gradientButtonLook ifTrue: [self adoptColor: aColor]! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' 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 1/19/2007 13:04'! contentHolder "Answer the alignment morph for extra control." ^self submorphs first! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 2/11/2009 16:42'! cornerStyle: aSymbol "Adjust the layout inset." super cornerStyle: aSymbol. self layoutInset: (self theme buttonLabelInsetFor: self)! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' 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:53'! disabledFillStyle "Return the disabled fillStyle of the receiver." ^self theme buttonDisabledFillStyleFor: self! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'StephaneDucasse 7/18/2010 13:15'! 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 enabled not and: [self label isMorph and: [(self label respondsTo: #enabled:) not]]) ifTrue: [aCanvas fillRectangle: self submorphBounds fillStyle: (Color white alpha: 0.5)]. self hasKeyboardFocus ifTrue: [self drawKeyboardFocusOn: aCanvas]! ! !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: '*Polymorph-Widgets' 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: '*Polymorph-Widgets' stamp: 'gvc 12/4/2007 16:23'! focusBounds "Answer the bounds for drawing the focus indication." ^self theme buttonFocusBoundsFor: self! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/11/2007 15:00'! focusColor "Answer the keyboard focus indication color." ^self color contrastingColor! ! !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: '*Polymorph-Widgets' stamp: 'gvc 4/13/2007 15:53'! getMenuSelector: aSymbol "Set the menu selector." getMenuSelector := aSymbol! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' 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: '*Polymorph-Widgets' 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: '*Polymorph-Widgets' stamp: 'gvc 5/8/2006 13:40'! handlesMouseOver: evt ^ true! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' 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: '*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: '*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: '*Polymorph-Widgets' 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: '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: '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: '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: '*Polymorph-Widgets' stamp: 'gvc 8/7/2007 13:21'! labelMorph "Answer the actual label morph." self hasSubmorphs ifFalse: [^nil]. self firstSubmorph hasSubmorphs ifFalse: [^nil]. ^self firstSubmorph firstSubmorph! ! !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: '*Polymorph-Widgets' stamp: 'gvc 12/3/2008 17:23'! minHeight "Consult the theme also." ^super minHeight max: self theme buttonMinHeight! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 12/3/2008 17:22'! minWidth "Consult the theme also." ^super minWidth max: self theme buttonMinWidth! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/24/2007 13:34'! model "Answer the receiver's model." ^model! ! !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: 'gvc 7/30/2007 15:53'! mouseOverBorderStyle "Return the mouse over borderStyle of the receiver." ^self theme buttonMouseOverBorderStyleFor: self! ! !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: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:54'! newLabel "Answer a new label for the receiver." ^self theme buttonLabelFor: 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: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:54'! normalBorderStyle "Return the normal borderStyle of the receiver." ^self theme buttonNormalBorderStyleFor: self! ! !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: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:54'! normalFillStyle "Return the normal fillStyle of the receiver." ^self theme buttonNormalFillStyleFor: self! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 4/25/2007 18:44'! onColor "Answer the on color." ^onColor ! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 3/2/2010 17:36'! paneColorChanged "Use changed to update the appearance." self changed! ! !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'! pressedFillStyle "Return the pressed fillStyle of the receiver." ^self theme buttonPressedFillStyleFor: self! ! !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: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:54'! selectedBorderStyle "Return the selected borderStyle of the receiver." ^self theme buttonSelectedBorderStyleFor: self! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:54'! selectedDisabledBorderStyle "Return the selected disabled borderStyle of the receiver." ^self theme buttonSelectedDisabledBorderStyleFor: self! ! !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 7/30/2007 15:54'! selectedFillStyle "Return the selected fillStyle of the receiver." ^self theme buttonSelectedFillStyleFor: self! ! !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: 'gvc 7/30/2007 15:54'! selectedMouseOverFillStyle "Return the selected mouse over fillStyle of the receiver." ^self theme buttonSelectedMouseOverFillStyleFor: 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: '*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 6/8/2009 14:26'! showSelectionFeedback "Answer whether the feedback should be shown for being pressed." ^showSelectionFeedback! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 6/15/2009 12:23'! showSelectionFeedback: aBoolean "Set the feedback." showSelectionFeedback := aBoolean! ! !PluggableButtonMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 1/11/2007 12:30'! takesKeyboardFocus "Answer whether the receiver can normally take keyboard focus." ^true! ! !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: '*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: '*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'! action: aSymbol "Set actionSelector to be the action defined by aSymbol." actionSelector := aSymbol. ! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 7/18/2010 13:17'! actionBlock ^ actionBlock ! ! !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: 'accessing' stamp: 'sw 12/28/2000 16:17'! actionSelector "Answer the receiver's actionSelector" ^ actionSelector! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 4/2/98 18:53'! askBeforeChanging ^ askBeforeChanging ! ! !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: 'accessing' stamp: 'StephaneDucasse 7/18/2010 13:11'! disable "Disable the button." self enabled: false! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 7/18/2010 13:11'! enable "Enable the button." self enabled: true! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 7/18/2010 13:11'! enabled ^ enabled ifNil: [enabled := true]! ! !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: '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: 'accessing' stamp: 'StephaneDucasse 7/18/2010 13:26'! getColorSelector ^getColorSelector! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 7/18/2010 13:26'! getColorSelector: aSymbol getColorSelector := aSymbol. self update: getColorSelector.! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 7/18/2010 13:29'! getEnabledSelector ^getEnabledSelector! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'StephaneDucasse 7/18/2010 13:29'! getEnabledSelector: aSymbol getEnabledSelector := aSymbol. self update: aSymbol.! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'FernandoOlivero 4/12/2011 10:12'! gradientLook ^ gradientLook ifNil: [gradientLook := self theme currentSettings preferGradientFill]! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'AlainPlantec 12/13/2009 13:24'! gradientLook: aBoolean gradientLook := aBoolean! ! !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: 'GaryChambers 12/7/2011 17:57'! label: aStringOrTextOrMorph "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. aStringOrTextOrMorph isMorph ifTrue: [ label := aStringOrTextOrMorph. r addMorph: aStringOrTextOrMorph] ifFalse: [ label := aStringOrTextOrMorph. r addMorph: self newLabel]. self addMorph: r. self updateLabelEnablement ! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'GaryChambers 12/7/2011 17:57'! 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. aStringOrTextOrMorph isMorph ifTrue: [ label := aStringOrTextOrMorph. r addMorph: aStringOrTextOrMorph] ifFalse: [ label := aStringOrTextOrMorph. r addMorph: (self newLabel: aFont)]. (self labelMorph respondsTo: #enabled:) ifTrue: [ self labelMorph enabled: self enabled]. self addMorph: r. self updateLabelEnablement ! ! !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: 'sw 10/25/1999 14:36'! offColor ^ offColor ! ! !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 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: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: 'BenjaminVanRyseghem 5/2/2012 11:40'! performAction "backward compatibility" self performAction: nil! ! !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 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: '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: 'accessing' stamp: 'MarcusDenker 2/29/2012 17:28'! target ^model! ! !PluggableButtonMorph methodsFor: 'accessing' stamp: 'jm 4/2/98 19:26'! triggerOnMouseDown ^ triggerOnMouseDown ! ! !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: '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: 'arguments' stamp: 'sw 2/17/2002 05:29'! argumentsProvider: anObject argumentsSelector: aSelector "Set the argument provider and selector" argumentsProvider := anObject. argumentsSelector := aSelector! ! !PluggableButtonMorph methodsFor: 'compatibility' stamp: 'BenjaminVanRyseghem 7/25/2012 11:55'! isMorphicModel ^ true! ! !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: '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: 'event handling' stamp: 'jm 5/4/1998 16:57'! handlesMouseDown: evt ^ true ! ! !PluggableButtonMorph methodsFor: 'event handling' stamp: 'gvc 5/8/2006 13:41'! handlesMouseOverDragging: evt ^ 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: '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: 'event handling' stamp: 'jrp 7/3/2005 18:13'! mouseLeaveDragging: evt self mouseLeave: evt! ! !PluggableButtonMorph methodsFor: 'event handling' stamp: 'jm 5/4/1998 17:30'! mouseMove: evt allButtons ifNil: [^ self]. allButtons do: [:m | m updateFeedbackForEvt: evt]. ! ! !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: 'initialization' stamp: 'dgd 2/14/2003 22:39'! defaultBorderWidth "answer the default border width for the receiver" ^ 1! ! !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: 'initialization' stamp: 'StephaneDucasse 7/18/2010 13:13'! initialize "Initialize the state of the receiver." super initialize. self rubberBandCells: false; listDirection: #topToBottom; hResizing: #shrinkWrap; vResizing: #shrinkWrap; wrapCentering: #center; cellPositioning: #center. enabled := true. model := nil. label := nil. getStateSelector := nil. actionSelector := nil. getLabelSelector := nil. getMenuSelector := nil. shortcutCharacter := nil. askBeforeChanging := false. triggerOnMouseDown := false. onColor := nil. offColor := nil. feedbackColor := nil. showSelectionFeedback := false. allButtons := nil. arguments := #(). argumentsProvider := nil. argumentsSelector := nil. self layoutInset: (self theme buttonLabelInsetFor: self); borderStyle: BorderStyle thinGray; extent: 20@15; setProperty: #lastState toValue: false; cornerStyle: (self theme buttonCornerStyleIn: nil)! ! !PluggableButtonMorph methodsFor: 'updating' stamp: 'StephaneDucasse 7/18/2010 13:32'! update: aParameter |state| aParameter ifNil: [^self]. getLabelSelector ifNotNil: [ aParameter == getLabelSelector ifTrue: [ (self labelMorph respondsTo: #font) ifTrue: [self label: (model perform: getLabelSelector) font: self labelMorph font] ifFalse: [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 ]].! ! !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: 'updating' stamp: 'GaryChambers 12/7/2011 17:57'! updateLabelEnablement "Set the enabled state of the label if possible." (self labelMorph respondsTo: #enabled:) ifTrue: [ self labelMorph enabled: self enabled]! ! !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: 'private' stamp: 'SeanDeNigris 2/8/2012 14:37'! browseAction | classDefiningAction | classDefiningAction := self model class whichClassIncludesSelector: self actionSelector. SystemBrowser default newOnClass: classDefiningAction selector: self actionSelector.! ! !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: '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 class instanceVariableNames: ''! !PluggableButtonMorph class methodsFor: 'as yet unclassified' stamp: 'GuillermoPolito 9/24/2012 21:56'! buildPluggableButtonShortcutsOn: aBuilder (aBuilder shortcut: #action1) category: #PluggableButtonMorph default: Character space asShortcut | Character cr asShortcut do: [ :target :morph :event | morph performAction ].! ! !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: 'AlainPlantec 12/10/2009 07:18'! gradientButtonLook: aBoolean UseGradientLook := aBoolean! ! !PluggableButtonMorph class methodsFor: 'instance creation'! 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 ^ self new on: anObject getState: getStateSel action: actionSel label: nil menu: nil ! ! !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 ! ! !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 ! ! Canvas subclass: #PluggableCanvas instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Support'! !PluggableCanvas commentStamp: '' prior: 0! 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: '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: 'accessing' stamp: 'RAA 8/13/2000 18:56'! extent self apply: [ :c | ^c extent ]. ! ! !PluggableCanvas methodsFor: 'accessing' stamp: 'RAA 8/13/2000 18:57'! origin self apply: [ :c | ^c origin ]. ! ! !PluggableCanvas methodsFor: 'accessing' stamp: 'ls 3/20/2000 21:14'! shadowColor: color self apply: [ :c | c shadowColor: color ]! ! !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: 'canvas methods' stamp: 'RAA 7/28/2000 06:52'! balloonFillRectangle: aRectangle fillStyle: aFillStyle self apply: [ :c | c balloonFillRectangle: aRectangle fillStyle: aFillStyle ]! ! !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: 'canvas methods' stamp: 'ls 3/25/2000 15:53'! showAt: pt invalidRects: updateRects self apply: [ :c | c showAt: pt invalidRects: updateRects ]! ! !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' 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' stamp: 'ls 3/20/2000 20:34'! render: anObject self apply: [ :c | c render: anObject ]! ! !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-images' stamp: 'ls 3/20/2000 20:32'! paintImage: aForm at: aPoint self apply: [ :c | c paintImage: aForm at: aPoint ]! ! !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: '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-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-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-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: '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: 'drawing-support' stamp: 'ls 3/20/2000 19:59'! clipBy: newClipRect during: aBlock self apply: [ :c | c clipBy: newClipRect during: aBlock ]! ! !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: 'drawing-support' stamp: 'ls 3/20/2000 20:37'! translateBy: delta during: aBlock self apply: [ :clippedCanvas | clippedCanvas translateBy: delta during: aBlock ]! ! !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: '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: 'initialization' stamp: 'ls 3/20/2000 21:16'! flush self apply: [ :c | c flush ]! ! !PluggableCanvas methodsFor: 'other' stamp: 'ls 3/20/2000 21:16'! flushDisplay self apply: [ :c | c flushDisplay ]! ! !PluggableCanvas methodsFor: 'other' stamp: 'RAA 7/20/2000 16:49'! forceToScreen: rect self apply: [ :c | c forceToScreen: rect ]! ! !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: '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: '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 ]! ! ModelDependentDialogWindow subclass: #PluggableDialogWindow instanceVariableNames: 'statusValue buttons contentMorph applyChangesSelector defaultFocusMorph' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Windows'! !PluggableDialogWindow commentStamp: 'gvc 8/8/2007 14:08' prior: 0! Pluggable form of dialog window supporting custom selector on model for applying changes along with configurable content and buttons.! !PluggableDialogWindow methodsFor: 'accessing' stamp: 'gvc 2/12/2007 12:56'! applyChangesSelector "Answer the value of applyChangesSelector" ^ applyChangesSelector! ! !PluggableDialogWindow methodsFor: 'accessing' stamp: 'gvc 2/12/2007 12:56'! applyChangesSelector: anObject "Set the value of applyChangesSelector" applyChangesSelector := anObject! ! !PluggableDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/8/2007 14:02'! buttons "Answer the value of buttons" ^ buttons! ! !PluggableDialogWindow methodsFor: 'accessing' stamp: 'gvc 8/8/2007 14:02'! buttons: anObject "Set the value of buttons" buttons := anObject! ! !PluggableDialogWindow methodsFor: 'accessing' stamp: 'gvc 2/9/2007 13:34'! contentMorph "Answer the value of contentMorph" ^ contentMorph! ! !PluggableDialogWindow methodsFor: 'accessing' stamp: 'gvc 2/9/2007 13:34'! contentMorph: anObject "Set the value of contentMorph" contentMorph := anObject! ! !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: 'as yet unclassified' stamp: 'AlainPlantec 10/9/2011 15:01'! defaultFocusMorph ^ defaultFocusMorph ifNil: [super defaultFocusMorph]! ! !PluggableDialogWindow methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 10/9/2011 15:01'! defaultFocusMorph: aMorph defaultFocusMorph := aMorph! ! !PluggableDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 8/8/2007 14:03'! initialize "Initialize the receiver." super initialize. self buttons: super newButtons! ! !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: '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: 'as yet unclassified' stamp: 'jrd 12/1/2008 23:56'! statusValue: val statusValue := val! ! !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: '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: '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}! ! Dictionary subclass: #PluggableDictionary instanceVariableNames: 'hashBlock equalBlock' classVariableNames: '' poolDictionaries: '' category: 'Collections-Unordered'! !PluggableDictionary commentStamp: '' prior: 0! 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'! equalBlock "Return the block used for comparing the elements in the receiver." ^equalBlock! ! !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: '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'! 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: 'copying' stamp: 'nice 10/5/2009 10:15'! copyEmpty ^super copyEmpty hashBlock: hashBlock; equalBlock: 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 instanceVariableNames: ''! !PluggableDictionary class methodsFor: 'as yet unclassified' stamp: 'dvf 6/10/2000 18:13'! integerDictionary ^ self new hashBlock: [:integer | integer hash \\ 1064164 * 1009]! ! DictionaryTest subclass: #PluggableDictionaryTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Unordered'! !PluggableDictionaryTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 6/29/2009 12:35'! classToBeTested ^ PluggableDictionary! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PluggableDictionaryTest class instanceVariableNames: ''! !PluggableDictionaryTest class methodsFor: 'building suites' stamp: 'cyrille.delaunay 6/29/2009 12:36'! classToBeTested ^ IdentitySet! ! !PluggableDictionaryTest class methodsFor: 'building suites' stamp: 'cyrille.delaunay 6/29/2009 13:28'! shouldInheritSelectors ^true! ! PluggableMorphListMorph subclass: #PluggableIconListMorph instanceVariableNames: 'getIconSelector' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !PluggableIconListMorph commentStamp: 'gvc 5/18/2007 12:31' prior: 0! 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 "Answer the value of getIconSelector" ^ getIconSelector! ! !PluggableIconListMorph methodsFor: 'accessing' stamp: 'gvc 1/8/2007 17:56'! getIconSelector: anObject "Set the value of getIconSelector" getIconSelector := anObject! ! !PluggableIconListMorph methodsFor: 'action' stamp: 'BenjaminVanRyseghem 8/23/2011 14:38'! interactWithSelectedItem self selection ifNotNil: [: sel | sel submorphs do: [:each | each update: #interact ]]! ! !PluggableIconListMorph methodsFor: 'display' stamp: 'BenjaminVanRyseghem 2/7/2012 14:12'! itemMorphFor: anObject index: anIndex "Answer a morph for the object with the appropriate icon." |item icon| item := IconicListItem new changeTableLayout; listDirection: #leftToRight; cellPositioning: #center; cellInset: 2; borderWidth: 0; color: Color transparent; hResizing: #shrinkWrap; vResizing: #shrinkWrap; originalObject: anObject; extent: 20@16. icon := self getIconSelector ifNotNil: [self model perform: self getIconSelector withEnoughArguments: {anObject. anIndex}]. icon ifNotNil: [ item addMorphBack: icon asMorph]. item addMorphBack: (self wrapItem: anObject index: anIndex) asMorph. ^item! ! !PluggableIconListMorph methodsFor: 'event' stamp: 'BenjaminVanRyseghem 8/23/2011 14:23'! basicKeyPressed: aChar aChar == Character space ifTrue: [ self interactWithSelectedItem ] ifFalse: [ super basicKeyPressed: aChar ]! ! !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: '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! ! ListItemWrapper subclass: #PluggableListItemWrapper instanceVariableNames: 'string getContentsSelector getStringSelector hasContentsSelector' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Explorer'! !PluggableListItemWrapper commentStamp: 'ar 10/14/2003 23:51' prior: 0! 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 23:39'! asString string ifNotNil:[^string]. getStringSelector ifNil:[^super asString]. ^self sendToModel: getStringSelector ! ! !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:49'! getContentsSelector ^getContentsSelector! ! !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'! getStringSelector ^getStringSelector! ! !PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 21:49'! getStringSelector: aSymbol self validateSelector: aSymbol. getStringSelector := aSymbol.! ! !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 21:49'! hasContentsSelector ^hasContentsSelector! ! !PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 21:49'! hasContentsSelector: aSymbol self validateSelector: aSymbol. hasContentsSelector := aSymbol.! ! !PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 23:39'! string ^string! ! !PluggableListItemWrapper methodsFor: 'accessing' stamp: 'ar 10/11/2003 23:39'! string: aString string := aString! ! !PluggableListItemWrapper methodsFor: 'printing' stamp: 'ar 10/11/2003 23:21'! printOn: aStream super printOn: aStream. aStream nextPut:$(; nextPutAll: self asString; nextPut:$).! ! !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: 'private' stamp: 'ar 10/11/2003 21:50'! validateSelector: aSymbol (aSymbol numArgs between: 0 and: 2) ifFalse:[^self error: 'Invalid pluggable selector'].! ! ScrollPane subclass: #PluggableListMorph instanceVariableNames: 'list getListSelector getListSizeSelector getListElementSelector getIndexSelector setIndexSelector keystrokeActionSelector autoDeselect lastKeystrokeTime lastKeystrokes doubleClickSelector handlesBasicKeys potentialDropRow listMorph hScrollRangeCache dragItemSelector dropItemSelector wantsDropSelector wrapSelector searchedElement multipleSelection dragOnOrOff setSelectionListSelector getSelectionListSelector resetListSelector keystrokeSelector backgroundColoringBlockOrSelector separatorBlockOrSelector separatorSize separatorColor lastNonZeroIndex canMove' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Pluggable Widgets'! !PluggableListMorph commentStamp: '' prior: 0! ... 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: '*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: '*Keymapping-Core' stamp: 'ThierryGoubier 9/15/2012 22:26'! initializeShortcuts: aKMDispatcher super initializeShortcuts: aKMDispatcher. aKMDispatcher attachCategory: #MorphFocusNavigation! ! !PluggableListMorph methodsFor: '*Nautilus' stamp: 'BenjaminVanRyseghem 5/9/2012 11:28'! getListElementSelector ^ getListElementSelector! ! !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: '*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 methodsFor: '*Polymorph-Widgets' stamp: 'gvc 8/2/2007 13:34'! disable "Disable the receiver." self enabled: false! ! !PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 8/2/2007 13:34'! enable "Enable the receiver." self enabled: true! ! !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: '*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: '*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: '*Polymorph-Widgets' stamp: 'gvc 6/1/2009 15:18'! focusBounds "Answer the bounds for drawing the focus indication." ^self theme listFocusBoundsFor: self! ! !PluggableListMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 8/7/2007 11:47'! getEnabledSelector "Answer the value of getEnabledSelector" ^self valueOfProperty: #getEnabledSelector! ! !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: '*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: '*Polymorph-Widgets' stamp: 'gvc 9/20/2006 10:24'! mouseDownRow "Answer the mouse down row or nil if none." ^self listMorph mouseDownRow! ! !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: '*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: '*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: '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: '*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: '*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: '*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: '*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: '*Spec-Core'! getIndexSelector: aSelector getIndexSelector := aSelector! ! !PluggableListMorph methodsFor: '*Spec-Core'! getSelectionListSelector: getListSel. getSelectionListSelector := getListSel! ! !PluggableListMorph methodsFor: '*Spec-Core'! initialize super initialize. self initForKeystrokes.! ! !PluggableListMorph methodsFor: '*Spec-Core'! setIndexSelector: aSelector setIndexSelector := aSelector! ! !PluggableListMorph methodsFor: '*Spec-Core'! setMultipleSelection: aBoolean multipleSelection := aBoolean! ! !PluggableListMorph methodsFor: '*Spec-Core'! setSelectionListSelector: getListSel. setSelectionListSelector := getListSel! ! !PluggableListMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 6/1/2011 12:00'! autoDeselect ^ self resetListSelector notNil or: [ autoDeselect ifNil: [ true ] ]! ! !PluggableListMorph methodsFor: 'accessing' stamp: 'EstebanLorenzano 9/21/2012 13:13'! basicWrapSelector: aSymbol wrapSelector := aSymbol.! ! !PluggableListMorph methodsFor: 'accessing' stamp: 'stephaneDucasse 7/17/2010 16:32'! dragItemSelector ^dragItemSelector! ! !PluggableListMorph methodsFor: 'accessing' stamp: 'stephaneDucasse 7/17/2010 16:32'! dragItemSelector: aSymbol dragItemSelector := aSymbol. aSymbol ifNotNil:[self dragEnabled: true].! ! !PluggableListMorph methodsFor: 'accessing' stamp: 'stephaneDucasse 7/17/2010 16:32'! dropItemSelector ^dropItemSelector! ! !PluggableListMorph methodsFor: 'accessing' stamp: 'stephaneDucasse 7/17/2010 16:33'! dropItemSelector: aSymbol dropItemSelector := aSymbol. aSymbol ifNotNil:[self dropEnabled: true].! ! !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: 'BenjaminVanRyseghem 2/23/2013 01:02'! lastNonZeroIndex ^ lastNonZeroIndex ifNil: [ lastNonZeroIndex := 0 ]! ! !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: '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: 'accessing' stamp: 'stephaneDucasse 7/17/2010 16:33'! wantsDropSelector ^wantsDropSelector! ! !PluggableListMorph methodsFor: 'accessing' stamp: 'stephaneDucasse 7/17/2010 16:33'! wantsDropSelector: aSymbol wantsDropSelector := aSymbol! ! !PluggableListMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 3/8/2011 15:14'! wrapSelector ^ wrapSelector! ! !PluggableListMorph methodsFor: 'accessing' stamp: 'EstebanLorenzano 9/21/2012 13:13'! wrapSelector: aSymbol self basicWrapSelector: aSymbol. self updateList.! ! !PluggableListMorph methodsFor: 'background coloring' stamp: 'BenjaminVanRyseghem 2/26/2013 19:18'! 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. (list indexOf: anItem)} ]] ifFalse: [ nil ]]]. ^ return isColor ifTrue: [ return ] ifFalse: [ nil ]! ! !PluggableListMorph methodsFor: 'background coloring' stamp: 'BenjaminVanRyseghem 9/16/2011 16:46'! backgroundColoringBlockOrSelector ^ backgroundColoringBlockOrSelector ! ! !PluggableListMorph methodsFor: 'background coloring' stamp: 'CamilloBruni 9/16/2011 16:34'! backgroundColoringBlockOrSelector: aSelector backgroundColoringBlockOrSelector := aSelector! ! !PluggableListMorph methodsFor: 'debug and other' stamp: 'bf 2/17/2006 17:25'! userString ^list! ! !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: '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: '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: 'drag and drop' stamp: 'ls 6/23/2001 00:01'! resetPotentialDropRow potentialDropRow ifNotNil: [ potentialDropRow ~= 0 ifTrue: [ potentialDropRow := 0. self changed. ] ]! ! !PluggableListMorph methodsFor: 'drag and drop' stamp: 'BenjaminVanRyseghem 2/23/2013 01:03'! 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 := TransferMorph withPassenger: 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: 'drag and drop' stamp: 'ThierryGoubier 10/24/2012 10:00'! 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 := TransferMorph withPassenger: 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: '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: 'drawing' stamp: 'ls 5/17/2001 20:53'! highlightSelection! ! !PluggableListMorph methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 6/1/2011 11:13'! unhighlightSelection self searchedElement: nil.! ! !PluggableListMorph methodsFor: 'event handling' stamp: 'BenjaminVanRyseghem 5/7/2012 14:39'! basicKeyPressed: aChar | nextSelection milliSeconds slowKeyStroke nextSelectionText 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: [ ^ self ]. "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]. "change scrollbarvalue" self searchedElement: nextSelection.! ! !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: 'event handling' stamp: 'ar 9/15/2000 22:57'! handlesKeyboard: evt ^true! ! !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 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: '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: 'event handling' stamp: 'BenjaminVanRyseghem 2/26/2013 18:54'! mouseDown: evt "Changed to only take focus if wanted." | selectors row | row := self rowAtLocation: evt position. evt yellowButtonPressed "First check for option (menu) click" 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. ]]]. 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: '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: '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: '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: 'event handling' stamp: 'BenjaminVanRyseghem 4/17/2012 16:44'! mouseMove: evt self isMultipleSelection ifTrue: [ self mouseMoveOnMultiple: evt ] ifFalse: [ self mouseMoveOnSingle:evt ]! ! !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: 'event handling' stamp: 'gvc 1/11/2007 14:06'! takesKeyboardFocus "Answer whether the receiver can normally take keyboard focus." ^true! ! !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: '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: '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: '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: '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: '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: '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: '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: 'initialization' stamp: 'di 4/10/98 16:20'! autoDeselect: trueOrFalse "Enable/disable autoDeselect (see class comment)" autoDeselect := trueOrFalse.! ! !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: 'initialization' stamp: 'sw 1/12/2000 16:22'! doubleClickSelector: aSymbol doubleClickSelector := aSymbol! ! !PluggableListMorph methodsFor: 'initialization' stamp: 'ls 5/15/2001 22:21'! font ^ self listMorph font ! ! !PluggableListMorph methodsFor: 'initialization' stamp: 'ls 5/15/2001 22:21'! font: aFontOrNil self listMorph font: aFontOrNil. ! ! !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: '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: '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: 'initialization' stamp: 'BenjaminVanRyseghem 4/17/2012 16:51'! initForKeystrokes canMove := true. lastKeystrokeTime := 0. lastKeystrokes := ''! ! !PluggableListMorph methodsFor: 'initialization' stamp: 'sw 1/18/2001 13:08'! keystrokeActionSelector: keyActionSel "Set the keystroke action selector as specified" keystrokeActionSelector := keyActionSel! ! !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: 'initialization' stamp: 'ls 5/17/2001 09:04'! listMorphClass ^LazyListMorph! ! !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: 'initialization' stamp: 'nk 5/16/2003 14:41'! textColor "Answer my default text color." ^self valueOfProperty: #textColor ifAbsent: [ Color black ] ! ! !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: '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: 'nk 5/16/2003 14:37'! textHighlightColor: aColor "Set my default text highlight color." self setProperty: #textHighlightColor toValue: aColor. ! ! !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: '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: '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: 'menus' stamp: 'sw 3/31/2002 02:38'! copySelectionToClipboard "Copy my selected item to the clipboard as a string" self selection ifNotNil: [Clipboard clipboardText: self selection asString] ifNil: [self flash]! ! !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: '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: '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: '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: '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: '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: '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: 'model access' stamp: 'BenjaminVanRyseghem 2/7/2012 10:26'! keystrokeAction: event | args returnValue | keystrokeSelector ifNil: [ ^ nil ]. returnValue := model perform: keystrokeSelector withEnoughArguments: { event. self }. ^ returnValue = true! ! !PluggableListMorph methodsFor: 'model access' stamp: 'CamilloBruni 8/11/2011 06:29'! keystrokeSelector: aSymbol keystrokeSelector := 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: 'multi-selection' stamp: 'BenjaminVanRyseghem 6/1/2011 11:17'! beMultipleSelection multipleSelection := true! ! !PluggableListMorph methodsFor: 'multi-selection' stamp: 'BenjaminVanRyseghem 6/1/2011 11:24'! beSingleSelection multipleSelection := false! ! !PluggableListMorph methodsFor: 'multi-selection' stamp: 'BenjaminVanRyseghem 6/1/2011 11:50'! defaultMultipleSelectionValue ^ false! ! !PluggableListMorph methodsFor: 'multi-selection' stamp: 'BenjaminVanRyseghem 6/1/2011 11:26'! isMultipleSelection ^ self multipleSelection! ! !PluggableListMorph methodsFor: 'multi-selection' stamp: 'BenjaminVanRyseghem 6/1/2011 11:26'! isSingleSelection ^ self multipleSelection not! ! !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: '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: '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: '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: '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: '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: 'multi-selection' stamp: 'BenjaminVanRyseghem 4/17/2012 16:18'! 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]. Cursor normal show! ! !PluggableListMorph methodsFor: 'multi-selection' stamp: 'BenjaminVanRyseghem 6/1/2011 11:50'! multipleSelection ^ multipleSelection ifNil: [ multipleSelection := self defaultMultipleSelectionValue ]! ! !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: 'multi-selection' stamp: 'BenjaminVanRyseghem 6/1/2011 11:47'! resetListSelector ^ resetListSelector! ! !PluggableListMorph methodsFor: 'multi-selection' stamp: 'BenjaminVanRyseghem 6/1/2011 11:47'! resetListSelector: aSelector resetListSelector := aSelector! ! !PluggableListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:19'! doubleClick: event onItem: aMorph self removeObsoleteEventHandlers.! ! !PluggableListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:19'! mouseDown: event onItem: aMorph self removeObsoleteEventHandlers.! ! !PluggableListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:20'! mouseEnterDragging: anEvent onItem: aMorph self removeObsoleteEventHandlers.! ! !PluggableListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:20'! mouseLeaveDragging: anEvent onItem: aMorph self removeObsoleteEventHandlers.! ! !PluggableListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:20'! mouseUp: event onItem: aMorph self removeObsoleteEventHandlers.! ! !PluggableListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:20'! removeObsoleteEventHandlers scroller submorphs do:[:m| m eventHandler: nil; highlightForMouseDown: false; resetExtension].! ! !PluggableListMorph methodsFor: 'obsolete' stamp: 'ar 3/17/2001 17:20'! startDrag: evt onItem: itemMorph self removeObsoleteEventHandlers.! ! !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: 'scroll cache' stamp: 'sps 4/3/2005 15:29'! resetHScrollRange hScrollRangeCache := nil. self deriveHScrollRange. ! ! !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: '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: 'scrolling' stamp: 'gvc 2/19/2009 12:26'! hUnadjustedScrollRange "Return the entire scrolling range." ^self listMorph hUnadjustedScrollRange! ! !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: '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: '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: '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: 'searching' stamp: 'BenjaminVanRyseghem 4/4/2011 16:59'! searchedElement ^ searchedElement! ! !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: 'searching' stamp: 'BenjaminVanRyseghem 4/4/2011 17:01'! secondarySelectionColor ^ self theme settings secondarySelectionColor! ! !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: 'selection' stamp: 'BenjaminVanRyseghem 2/9/2012 17:41'! deselectAll self isMultipleSelection ifFalse: [ ^ self ]. self resetListSelection! ! !PluggableListMorph methodsFor: 'selection' stamp: 'di 6/21/1998 22:19'! getListSelector ^ getListSelector! ! !PluggableListMorph methodsFor: 'selection' stamp: 'ls 5/17/2001 23:06'! maximumSelection ^ self getListSize! ! !PluggableListMorph methodsFor: 'selection' stamp: 'di 5/22/1998 00:20'! minimumSelection ^ 1! ! !PluggableListMorph methodsFor: 'selection' stamp: 'BenjaminVanRyseghem 6/4/2011 15:21'! resetListSelection self resetListSelectionSilently. self changed! ! !PluggableListMorph methodsFor: 'selection' stamp: 'BenjaminVanRyseghem 6/4/2011 15:21'! resetListSelectionSilently self resetListSelector ifNotNil: [:sel | self model perform: sel ]! ! !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: '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: '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: '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: 'selection' stamp: 'nk 7/30/2004 17:53'! selectedMorph: aMorph "this shouldn't be used any longer" "self isThisEverCalled ." Beeper beep. true ifTrue: [^self]! ! !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: '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: '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: '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: 'selection' stamp: 'di 5/6/1998 21:20'! setSelectedMorph: aMorph self changeModelSelection: (scroller submorphs indexOf: aMorph)! ! !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: 'separator' stamp: 'CamilloBruni 9/16/2011 16:24'! separatorBlockOrSelector ^ separatorBlockOrSelector! ! !PluggableListMorph methodsFor: 'separator' stamp: 'BenjaminVanRyseghem 9/16/2011 16:53'! separatorBlockOrSelector: aBlockOrSelector separatorBlockOrSelector := aBlockOrSelector! ! !PluggableListMorph methodsFor: 'separator' stamp: 'BenjaminVanRyseghem 9/16/2011 17:07'! separatorColor ^ separatorColor ifNil: [ separatorColor := Color gray ]! ! !PluggableListMorph methodsFor: 'separator' stamp: 'BenjaminVanRyseghem 9/16/2011 16:57'! separatorColor: aColor separatorColor := aColor! ! !PluggableListMorph methodsFor: 'separator' stamp: 'BenjaminVanRyseghem 9/16/2011 17:07'! separatorSize ^ separatorSize ifNil: [ separatorSize := 1 ]! ! !PluggableListMorph methodsFor: 'separator' stamp: 'BenjaminVanRyseghem 9/16/2011 16:57'! separatorSize: anInteger separatorSize := anInteger! ! !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: 'updating' stamp: 'BenjaminVanRyseghem 4/18/2012 00:49'! update: aSymbol "Refer to the comment in View|update:." (aSymbol == getListSelector or: [ aSymbol == getListElementSelector ]) ifTrue: [self updateList. ^ self]. aSymbol == getIndexSelector ifTrue: [self selectionIndex: self getCurrentSelectionIndex. ^ self]. aSymbol == #allSelections ifTrue: [self selectionIndex: self getCurrentSelectionIndex. ^ self changed].! ! !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: '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: '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 class instanceVariableNames: ''! !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"! ! !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 "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: '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: '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 ! ! MenuSpec subclass: #PluggableMenuItemSpec instanceVariableNames: 'label action checked enabled separator subMenu icon enabledBlock keyText' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Menus'! !PluggableMenuItemSpec methodsFor: '*Morphic-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: '*Morphic-Menus' stamp: 'StephaneDucasse 6/10/2011 22:14'! morphClass ^ ToggleMenuItemMorph! ! !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:23'! action: aMessageSend "Answer the action associated with the receiver" action := aMessageSend! ! !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:21'! checked: aBool "Indicate whether the receiver is checked" checked := aBool.! ! !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:21'! enabled: aBool "Indicate whether the receiver is enabled" enabled := aBool! ! !PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/13/2011 17:23'! enabledBlock ^ enabledBlock! ! !PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/13/2011 17:23'! enabledBlock: aBlock enabledBlock := aBlock! ! !PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'AlainPlantec 2/10/2010 08:19'! hasCheckBox ^ checked notNil! ! !PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'AlainPlantec 2/12/2010 22:22'! icon ^ icon! ! !PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'AlainPlantec 2/12/2010 22:22'! icon: aForm icon := aForm! ! !PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'EstebanLorenzano 1/30/2013 16:45'! keyText ^keyText! ! !PluggableMenuItemSpec methodsFor: 'accessing' stamp: 'EstebanLorenzano 1/30/2013 16:44'! keyText: aString keyText := aString.! ! !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'! label: aString "Set the receiver's label" label := aString! ! !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: '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 "Answer the receiver's subMenu" ^subMenu! ! !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. ]] ! ! Object subclass: #PluggableMenuSpec instanceVariableNames: 'label model items parentMenu' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Menus'! !PluggableMenuSpec commentStamp: 'StephaneDucasse 6/6/2011 22:13' prior: 0! 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: '*Morphic-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-Menus' stamp: 'BenjaminVanRyseghem 4/17/2011 15:06'! buildWith: aBuilder ^ self asMenuMorph! ! !PluggableMenuSpec methodsFor: '*Morphic-Menus' stamp: 'BenjaminVanRyseghem 4/11/2011 19:34'! morphClass ^ MenuMorph! ! !PluggableMenuSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:27'! items ^ items ifNil: [items := OrderedCollection new]! ! !PluggableMenuSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:12'! label ^label! ! !PluggableMenuSpec methodsFor: 'accessing' stamp: 'ar 2/28/2006 17:12'! label: aString label := aString.! ! !PluggableMenuSpec methodsFor: 'accessing' stamp: 'cwp 6/8/2005 23:36'! model ^ model! ! !PluggableMenuSpec methodsFor: 'accessing' stamp: 'cwp 6/8/2005 23:36'! model: anObject model := anObject! ! !PluggableMenuSpec methodsFor: 'construction' stamp: 'AlainPlantec 2/8/2010 11:23'! add: aString ^ self add: aString action: nil ! ! !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: '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: '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: '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: 'construction' stamp: 'ar 2/28/2006 17:27'! addMenuItem | item | item := self newMenuItem. self items add: item. ^item! ! !PluggableMenuSpec methodsFor: 'construction' stamp: 'ar 2/28/2006 17:25'! addSeparator self items isEmpty ifTrue:[^nil]. self items last separator: true.! ! !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:27'! newMenuItem ^PluggableMenuItemSpec new! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PluggableMenuSpec class instanceVariableNames: ''! !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: '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! ! !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: 'instance creation' stamp: 'cwp 6/9/2005 00:22'! withModel: aModel ^ self new model: aModel! ! PluggableListMorph subclass: #PluggableMorphListMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !PluggableMorphListMorph commentStamp: 'gvc 5/18/2007 12:30' prior: 0! 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: '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! ! !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! ! PluggableListMorph subclass: #PluggableMultiColumnListMorph instanceVariableNames: 'gapSize' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Pluggable Widgets'! !PluggableMultiColumnListMorph commentStamp: '' prior: 0! 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: 'accessing' stamp: 'BenjaminVanRyseghem 9/8/2011 13:01'! gapSize ^ gapSize ifNil: [ gapSize := 10 ]! ! !PluggableMultiColumnListMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 9/8/2011 13:09'! gapSize: anInteger gapSize := anInteger.! ! !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: '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: '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: 'ls 5/17/2001 20:01'! listMorphClass ^MulticolumnLazyListMorph! ! !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: '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 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: 'searching' stamp: 'BenjaminVanRyseghem 2/13/2012 17:38'! listForSearching ^ super listForSearching collect: #first! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PluggableMultiColumnListMorph class instanceVariableNames: ''! !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! ! !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! ! AlignmentMorph subclass: #PluggablePanelMorph instanceVariableNames: 'model getChildrenSelector' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !PluggablePanelMorph commentStamp: 'ar 2/11/2005 20:13' prior: 0! A pluggable panel morph which deals with changing children.! !PluggablePanelMorph methodsFor: 'accessing' stamp: 'ar 2/11/2005 19:47'! getChildrenSelector ^getChildrenSelector! ! !PluggablePanelMorph methodsFor: 'accessing' stamp: 'ar 2/11/2005 19:47'! getChildrenSelector: aSymbol getChildrenSelector := aSymbol.! ! !PluggablePanelMorph methodsFor: 'accessing' stamp: 'ar 2/11/2005 19:48'! model ^model! ! !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: '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]. ].! ! Set subclass: #PluggableSet instanceVariableNames: 'hashBlock equalBlock' classVariableNames: '' poolDictionaries: '' category: 'Collections-Unordered'! !PluggableSet commentStamp: 'MarcusDenker 3/23/2010 18:47' prior: 0! 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 18:43'! equalBlock "Return the block used for comparing the elements in the receiver." ^equalBlock! ! !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: '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 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: 'copying' stamp: 'nice 10/5/2009 10:15'! copyEmpty ^super copyEmpty hashBlock: hashBlock; equalBlock: 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 instanceVariableNames: ''! !PluggableSet class methodsFor: 'as yet unclassified' stamp: 'dvf 6/10/2000 18:13'! integerSet ^self new hashBlock: [:integer | integer hash \\ 1064164 * 1009]! ! SetTest subclass: #PluggableSetTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'CollectionsTests-Unordered'! !PluggableSetTest methodsFor: 'requirements' stamp: 'cyrille.delaunay 6/29/2009 12:34'! classToBeTested ^ PluggableSet! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PluggableSetTest class instanceVariableNames: ''! !PluggableSetTest class methodsFor: 'building suites' stamp: 'cyrille.delaunay 6/29/2009 12:34'! classToBeTested ^ IdentitySet! ! Slider subclass: #PluggableSliderMorph instanceVariableNames: 'getValueSelector getEnabledSelector enabled min max quantum getLabelSelector label' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !PluggableSliderMorph commentStamp: 'gvc 7/16/2007 13:57' prior: 0! A pluggable slider (rather than one that auto-generates access selectors). Needs to be themed...! !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 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 8/3/2007 15:19'! enabled "Answer the value of enabled" ^ enabled! ! !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/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: 'accessing' stamp: 'gvc 9/8/2009 13:03'! getEnabledSelector "Answer the value of getEnabledSelector" ^ getEnabledSelector! ! !PluggableSliderMorph methodsFor: 'accessing' stamp: 'gvc 9/10/2009 13:32'! getEnabledSelector: aSymbol "Set the value of getEnabledSelector" getEnabledSelector := aSymbol. self updateEnabled! ! !PluggableSliderMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/18/2012 16:05'! getLabelSelector ^ getLabelSelector! ! !PluggableSliderMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/18/2012 16:13'! getLabelSelector: aSymbol getLabelSelector := aSymbol. self updateLabel! ! !PluggableSliderMorph methodsFor: 'accessing' stamp: 'gvc 6/20/2007 14:31'! getValueSelector "Answer the value of getValueSelector" ^ getValueSelector! ! !PluggableSliderMorph methodsFor: 'accessing' stamp: 'gvc 6/20/2007 14:31'! getValueSelector: anObject "Set the value of getValueSelector" getValueSelector := anObject! ! !PluggableSliderMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/18/2012 16:07'! label ^ label! ! !PluggableSliderMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 7/18/2012 16:07'! label: aLabel label := aLabel! ! !PluggableSliderMorph methodsFor: 'accessing' stamp: 'gvc 8/9/2007 10:43'! max "Answer the value of max" ^ max! ! !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 8/9/2007 10:43'! min "Answer the value of min" ^ min! ! !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 11:14'! quantum "Answer the value of quantum" ^ quantum! ! !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: '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: '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: 'gvc 8/9/2007 11:18'! setValueSelector "Answer the set selector." ^setValueSelector! ! !PluggableSliderMorph methodsFor: 'accessing' stamp: 'gvc 6/20/2007 14:31'! setValueSelector: aSymbol "Directly set the selector to make more flexible." setValueSelector := aSymbol! ! !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: 'drawing' stamp: 'BenjaminVanRyseghem 7/18/2012 16:18'! font ^ StandardFonts defaultFont! ! !PluggableSliderMorph methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 7/18/2012 16:18'! fontColor ^ Color black! ! !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: 'drawing' stamp: 'BenjaminVanRyseghem 7/18/2012 16:34'! labelGap ^ 2! ! !PluggableSliderMorph methodsFor: 'event handling' stamp: 'gvc 6/20/2007 14:27'! handlesMouseDown: evt "Answer true." ^true! ! !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: '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: 'initialization' stamp: 'gvc 6/20/2007 15:02'! defaultColor "Answer the default color/fill style for the receiver." ^Color white! ! !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: '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: '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: '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: '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: '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 methodsFor: 'other events' stamp: 'gvc 8/7/2007 10:36'! mouseDownInSlider: event "Ignore if disabled." self enabled ifFalse: [^self]. ^super mouseDownInSlider: event! ! !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: 'protocol' stamp: 'gvc 8/3/2007 15:19'! disable "Disable the receiver." self enabled: false! ! !PluggableSliderMorph methodsFor: 'protocol' stamp: 'gvc 8/3/2007 15:19'! enable "Enable the receiver." self enabled: true! ! !PluggableSliderMorph methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 7/18/2012 16:13'! update: aSymbol aSymbol = getEnabledSelector ifTrue: [ ^ self updateEnabled ]. aSymbol = getValueSelector ifTrue: [ ^ self updateValue ]. aSymbol = getLabelSelector ifTrue: [ ^ self updateLabel ].! ! !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: '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: '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: 'scrolling' stamp: 'gvc 8/7/2007 10:37'! scrollAbsolute: event "Ignore if disabled." self enabled ifFalse: [^self]. ^super scrollAbsolute: event! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PluggableSliderMorph class instanceVariableNames: ''! !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! ! SystemWindow subclass: #PluggableSystemWindow instanceVariableNames: 'getLabelSelector getChildrenSelector children closeWindowSelector' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Windows'! !PluggableSystemWindow commentStamp: 'ar 2/11/2005 20:14' prior: 0! A pluggable system window. Fixes the issues with label retrieval and adds support for changing children.! !PluggableSystemWindow methodsFor: 'accessing' stamp: 'md 8/31/2005 07:59'! addPaneMorph: aMorph self addMorph: aMorph fullFrame: aMorph layoutFrame! ! !PluggableSystemWindow methodsFor: 'accessing' stamp: 'ar 9/17/2005 21:05'! closeWindowSelector ^closeWindowSelector! ! !PluggableSystemWindow methodsFor: 'accessing' stamp: 'ar 9/17/2005 21:05'! closeWindowSelector: aSymbol closeWindowSelector := aSymbol! ! !PluggableSystemWindow methodsFor: 'accessing' stamp: 'ar 2/11/2005 19:57'! getChildrenSelector ^getChildrenSelector! ! !PluggableSystemWindow methodsFor: 'accessing' stamp: 'ar 2/11/2005 19:57'! getChildrenSelector: aSymbol getChildrenSelector := aSymbol! ! !PluggableSystemWindow methodsFor: 'accessing' stamp: 'ar 2/11/2005 19:57'! getLabelSelector ^getLabelSelector! ! !PluggableSystemWindow methodsFor: 'accessing' stamp: 'ar 2/13/2005 13:53'! getLabelSelector: aSymbol getLabelSelector := aSymbol. self update: aSymbol.! ! !PluggableSystemWindow methodsFor: 'accessing' stamp: 'ar 2/13/2005 13:52'! label ^label contents! ! !PluggableSystemWindow methodsFor: 'accessing' stamp: 'ar 2/13/2005 13:51'! label: aString self setLabel: aString.! ! !PluggableSystemWindow methodsFor: 'initialization' stamp: 'ar 9/17/2005 21:08'! delete closeWindowSelector ifNotNil:[model perform: closeWindowSelector]. super delete. ! ! !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! ! Morph subclass: #PluggableTabBarMorph instanceVariableNames: 'target tabs activeTab' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Pluggable Widgets'! !PluggableTabBarMorph commentStamp: 'KLC 9/17/2004 11:26' prior: 0! 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: '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: '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 methodsFor: 'actions' stamp: 'KLC 2/2/2004 16:22'! handlesMouseDown: anEvent ^ true! ! !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: '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: '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: '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 class instanceVariableNames: ''! !PluggableTabBarMorph class methodsFor: 'instance creation' stamp: 'KLC 2/2/2004 10:38'! on: anObject ^ super new target: anObject! ! Morph subclass: #PluggableTabButtonMorph instanceVariableNames: 'active model textSelector arcLengths subMorph' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Pluggable Widgets'! !PluggableTabButtonMorph commentStamp: 'KLC 9/17/2004 11:27' prior: 0! 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: '*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:25'! active active ifNil: [ active := false ]. ^ active! ! !PluggableTabButtonMorph methodsFor: 'access' stamp: 'KLC 1/22/2004 14:26'! active: aBoolean active := aBoolean. self changed.! ! !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 ^ model ! ! !PluggableTabButtonMorph methodsFor: 'access' stamp: 'KLC 1/22/2004 14:39'! model: anObject model := anObject! ! !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: 'access' stamp: 'KLC 1/22/2004 14:39'! textSelector ^ textSelector ! ! !PluggableTabButtonMorph methodsFor: 'access' stamp: 'KLC 1/22/2004 14:39'! textSelector: aSymbol textSelector := aSymbol! ! !PluggableTabButtonMorph methodsFor: 'actions' stamp: 'KLC 1/23/2004 15:38'! toggle self active: self active not! ! !PluggableTabButtonMorph methodsFor: 'drawing' stamp: 'KLC 1/23/2004 15:49'! drawOn: aCanvas self drawTabOn: aCanvas. self drawSubMorphOn: aCanvas! ! !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: '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: 'event' stamp: 'BenjaminVanRyseghem 1/9/2012 18:23'! handlesKeyboard: evt "Yes, we do it here." ^true! ! !PluggableTabButtonMorph methodsFor: 'event' stamp: 'BenjaminVanRyseghem 1/9/2012 18:25'! keyStroke: event (self navigationKey: event) ifTrue: [^self]. super keyStroke: event! ! !PluggableTabButtonMorph methodsFor: 'event' stamp: 'BenjaminVanRyseghem 1/9/2012 18:04'! takesKeyboardFocus "Answer whether the receiver can normally take keyboard focus." ^true! ! !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: 'stepping' stamp: 'KLC 2/2/2004 10:15'! step self subMorph step. self changed. ! ! !PluggableTabButtonMorph methodsFor: 'stepping' stamp: 'KLC 1/23/2004 17:31'! stepTime ^ self subMorph stepTime ! ! !PluggableTabButtonMorph methodsFor: 'stepping' stamp: 'KLC 1/23/2004 17:31'! wantsSteps ^ self subMorph wantsSteps! ! !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: 'private - access' stamp: 'KLC 1/23/2004 14:36'! arcLengths arcLengths ifNil: [ self calculateArcLengths ]. ^ arcLengths! ! !PluggableTabButtonMorph methodsFor: 'private - access' stamp: 'KLC 1/23/2004 14:37'! arcLengths: anArrayOfIntegers arcLengths := anArrayOfIntegers ! ! !PluggableTabButtonMorph methodsFor: 'private - access' stamp: 'KLC 1/23/2004 11:30'! cornerRadius ^ 5 ! ! !PluggableTabButtonMorph methodsFor: 'private - access' stamp: 'KLC 1/23/2004 16:40'! subMorph subMorph ifNil: [ self update: self textSelector ]. ^ subMorph! ! !PluggableTabButtonMorph methodsFor: 'private - access' stamp: 'KLC 1/23/2004 16:40'! subMorph: aMorph subMorph := aMorph ! ! !PluggableTabButtonMorph methodsFor: 'private - access' stamp: 'KLC 1/23/2004 11:30'! topInactiveGap ^ 5! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PluggableTabButtonMorph class instanceVariableNames: ''! !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 ! ! TextAction subclass: #PluggableTextAttribute instanceVariableNames: 'evalBlock' classVariableNames: '' poolDictionaries: '' category: 'Text-Core'! !PluggableTextAttribute commentStamp: '' prior: 0! An attribute which evaluates an arbitrary block when it is selected.! !PluggableTextAttribute methodsFor: 'initialization' stamp: 'ls 6/21/2001 18:06'! evalBlock: aBlock evalBlock := aBlock! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PluggableTextAttribute class instanceVariableNames: ''! !PluggableTextAttribute class methodsFor: 'instance creation' stamp: 'ls 6/21/2001 18:09'! evalBlock: aBlock ^super new evalBlock: aBlock! ! PluggableTextMorph subclass: #PluggableTextEditorMorph uses: TEnableOnHaloMenu - {#enabled:. #enabled} instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !PluggableTextEditorMorph commentStamp: 'GaryChambers 4/24/2012 13:52' prior: 0! 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'! addToggleItemsToHaloMenu: aCustomMenu "Add toggle-items to the halo menu" super addToggleItemsToHaloMenu: aCustomMenu. aCustomMenu addUpdating: #enabledString target: self action: #toggleEnabled! ! !PluggableTextEditorMorph methodsFor: 'as yet unclassified'! 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: 'GaryChambers 12/21/2011 11:15'! textMorphClass "Answer the class used to create the receiver's textMorph" ^TextMorphForEditorView! ! !PluggableTextEditorMorph methodsFor: 'as yet unclassified'! toggleEnabled "Toggle the enabled state." self enabled: self enabled not! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PluggableTextEditorMorph class uses: TEnableOnHaloMenu classTrait instanceVariableNames: ''! !PluggableTextEditorMorph class methodsFor: 'as yet unclassified' stamp: 'GaryChambers 1/20/2012 14:37'! stylingClass "No styling for plain text..." ^nil! ! PluggableTextMorph subclass: #PluggableTextFieldMorph instanceVariableNames: 'converter ghostText default entryCompletion endRow textMorphClass' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !PluggableTextFieldMorph commentStamp: 'gvc 5/18/2007 12:39' prior: 0! 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: '*Polymorph-Widgets' stamp: 'AlainPlantec 11/25/2010 22:12'! focusChanged | outerMorph | (self hasFocus or: [self chooserHasFocus]) ifFalse: [self closeChooser]. super focusChanged ! ! !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: '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' stamp: 'GuillermoPolito 5/23/2012 11:40'! keyboardFocusChange: aBoolean self closeChooser. super keyboardFocusChange: aBoolean. ! ! !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 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]! ! !PluggableTextFieldMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/23/2010 22:18'! closeChooser entryCompletion ifNotNil: [entryCompletion closeChooser]! ! !PluggableTextFieldMorph methodsFor: 'accessing' stamp: 'gvc 9/18/2006 12:21'! converter "Answer the value of converter" ^ converter! ! !PluggableTextFieldMorph methodsFor: 'accessing' stamp: 'gvc 9/18/2006 12:21'! converter: anObject "Set the value of converter" converter := anObject! ! !PluggableTextFieldMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/14/2009 11:29'! default ^ default! ! !PluggableTextFieldMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/14/2009 11:29'! default: anObject default := anObject! ! !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: '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: 'accessing' stamp: 'AlainPlantec 11/14/2009 11:29'! ghostText "Answer the value of helpText" ^ ghostText ifNil: [ghostText := '']! ! !PluggableTextFieldMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/14/2009 11:29'! ghostText: aText "Set the value of helpText" ghostText := aText ifNotNil: [aText asString] ! ! !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: '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: '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:30'! textMarginsWidth | tm | "hack to get the margins width because textMorph margins can be an integer, a point or a rectangle" tm := self textMorph margins. ^ tm isRectangle ifTrue: [tm left] ifFalse: [tm isPoint ifTrue: [tm x] ifFalse: [tm]]! ! !PluggableTextFieldMorph methodsFor: 'drawing' stamp: 'FernandoOlivero 4/12/2011 10:12'! 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 closeIfNotOver: self]. ! ! !PluggableTextFieldMorph methodsFor: 'editor access' stamp: 'GaryChambers 3/2/2012 14:35'! 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 | 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: 'encryption' stamp: 'BenjaminVanRyseghem 1/25/2013 15:24'! beDecrypted self textMorph font: TextStyle defaultFont.! ! !PluggableTextFieldMorph methodsFor: 'encryption' stamp: 'BenjaminVanRyseghem 1/25/2013 15:24'! beEncrypted self textMorph font: (StrikeFont passwordFontSize: self theme textFont pointSize).! ! !PluggableTextFieldMorph methodsFor: 'encryption' stamp: 'BenjaminVanRyseghem 10/25/2012 14:23'! encrypted: aBoolean aBoolean ifTrue: [ self beEncrypted ] ifFalse: [ self beDecrypted ]! ! !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: 'event handling' stamp: 'AlainPlantec 11/24/2010 20:46'! mouseDownFromTextMorph: anEvent super mouseDownFromTextMorph: anEvent. entryCompletion ifNotNil: [entryCompletion mouseDownFromTextMorph: anEvent]! ! !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: 'event handling' stamp: 'AlainPlantec 11/25/2010 18:34'! textChanged super textChanged. self openChooser! ! !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: 'initialization' stamp: 'EstebanLorenzano 12/6/2012 13:37'! initialize "Initialization code for PluggableEncryptedTextFieldMorph" super initialize. textMorphClass := TextMorphForFieldView. self beDecrypted! ! !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: 'initialization' stamp: 'AlainPlantec 11/26/2010 18:09'! outOfWorld: aWorld self closeChooser. super outOfWorld: aWorld! ! !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: '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: '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: '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: 'styling' stamp: 'AlainPlantec 8/27/2011 16:03'! okToStyle ^ false! ! !PluggableTextFieldMorph methodsFor: 'testing' stamp: 'AlainPlantec 11/25/2010 21:07'! chooserHasFocus ^ entryCompletion notNil and: [entryCompletion chooser notNil and: [entryCompletion chooser hasFocus]] ! ! !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: 'private' stamp: 'BenjaminVanRyseghem 5/4/2012 17:07'! textMorphClass "Answer the class used to create the receiver's textMorph" ^ textMorphClass! ! ScrollPane subclass: #PluggableTextMorph instanceVariableNames: 'textMorph getTextSelector setTextSelector getSelectionSelector hasUnacceptedEdits askBeforeDiscardingEdits selectionInterval hasEditingConflicts acceptAction getColorSelector unstyledAcceptText styler autoAccept enabled getEnabledSelector highlights acceptOnFocusChange selectionColor alwaysAccept changedAction' classVariableNames: 'ShowTextEditingState StylingClass' poolDictionaries: '' category: 'Morphic-Pluggable Widgets'! !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: '*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: '*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: '*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: '*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: '*Polymorph-Widgets' stamp: 'GaryChambers 3/8/2011 12:00'! hasValidText "Return true if the text is valid for acceptance." ^true! ! !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: '*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: '*Polymorph-Widgets' stamp: 'AlainPlantec 11/8/2010 22:10'! minHeight "Implemented here since extent: overriden." ^super minHeight max: 16! ! !PluggableTextMorph methodsFor: '*Polymorph-Widgets' stamp: 'AlainPlantec 11/8/2010 22:10'! minWidth "Implemented here since extent: overriden." ^super minWidth max: 36! ! !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: '*Polymorph-Widgets' stamp: 'AlainPlantec 11/8/2010 22:10'! takesKeyboardFocus "Answer whether the receiver can normally take keyboard focus." ^true! ! !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: '*Shout'! 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: '*Shout'! stylerStyledInBackground: styledCopyOfText textMorph contents string = styledCopyOfText string ifTrue: [self stylerStyled: styledCopyOfText]! ! !PluggableTextMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/8/2010 22:10'! acceptAction ^acceptAction! ! !PluggableTextMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/8/2010 22:10'! acceptAction: anAction acceptAction := anAction! ! !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: '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 2/21/2011 18:57'! alwaysAccept ^ alwaysAccept ifNil: [false]! ! !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: 'accessing' stamp: 'AlainPlantec 2/21/2011 18:13'! autoAccept "Answer whether the editor accepts its contents on each change." ^autoAccept ifNil: [false]! ! !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: '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 methodsFor: 'accessing' stamp: 'CamilloBruni 8/11/2011 04:28'! changedAction ^ changedAction! ! !PluggableTextMorph methodsFor: 'accessing' stamp: 'CamilloBruni 8/11/2011 04:28'! changedAction: aBlock changedAction := aBlock! ! !PluggableTextMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/28/2010 10:02'! crAction: anAction self textMorph crAction: anAction! ! !PluggableTextMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/21/2011 18:29'! enabled "Answer whether the receiver is enabled." ^enabled ifNil: [true]! ! !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: 'accessing' stamp: 'AlainPlantec 11/8/2010 22:10'! getColorSelector ^getColorSelector! ! !PluggableTextMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/8/2010 22:10'! getColorSelector: aSymbol getColorSelector := aSymbol. self update: getColorSelector.! ! !PluggableTextMorph methodsFor: 'accessing' stamp: 'AlainPlantec 11/8/2010 22:10'! getTextSelector ^getTextSelector! ! !PluggableTextMorph methodsFor: 'accessing' stamp: 'AlainPlantec 2/21/2011 18:38'! selectionColor "Answer the color to use for the text selection." ^ selectionColor ! ! !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: 'accessing' stamp: 'AlainPlantec 2/21/2011 18:51'! wrapFlag: aBoolean self textMorph ifNil: [self setText: '']. textMorph wrapFlag: aBoolean! ! !PluggableTextMorph methodsFor: 'actions' stamp: 'BenjaminVanRyseghem 10/25/2012 15:05'! accept UsersManager default currentUser canEditCode ifFalse: [ ^ self hasUnacceptedEdits: false ]. self acceptBasic. acceptAction ifNotNil: [acceptAction value: textMorph contents asText].! ! !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: '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: 'actions' stamp: 'AlainPlantec 2/21/2011 18:23'! disable "Disable the receiver." self enabled: false! ! !PluggableTextMorph methodsFor: 'actions' stamp: 'AlainPlantec 2/21/2011 18:29'! enable "Enable the receiver." self enabled: true! ! !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: 'actions' stamp: 'AlainPlantec 2/21/2011 18:32'! getEnabledSelector "Answer the value of getEnabledSelector" ^ getEnabledSelector! ! !PluggableTextMorph methodsFor: 'actions' stamp: 'AlainPlantec 2/21/2011 18:32'! getEnabledSelector: anObject "Set the value of getEnabledSelector" getEnabledSelector := anObject. self updateEnabled! ! !PluggableTextMorph methodsFor: 'actions' stamp: 'AlainPlantec 2/22/2011 17:20'! highlights "Answer the value of highlights" ^ highlights ifNil: [#()]! ! !PluggableTextMorph methodsFor: 'actions' stamp: 'AlainPlantec 2/21/2011 18:33'! highlights: aCollectionOfHighlight "Set the value of highlights" highlights := aCollectionOfHighlight! ! !PluggableTextMorph methodsFor: 'actions' stamp: 'AlainPlantec 2/21/2011 18:34'! scrollToTop "Scroll to the top." self vScrollBarValue: 0; setScrollDeltas! ! !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: 'actions' stamp: 'AlainPlantec 2/21/2011 18:48'! textExtent "Answer the text morph extent." ^(textMorph ifNil: [^0@0]) extent! ! !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: '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: '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: 'actions' stamp: 'MarianoMartinezPeck 9/5/2012 14:08'! wrapFlag "Answer the wrap flag on the text morph." ^self textMorph wrapFlag! ! !PluggableTextMorph methodsFor: 'as yet unclassified' stamp: 'GaryChambers 4/24/2012 15:10'! font "Answer the probable font" ^self textMorph ifNil: [TextStyle defaultFont] ifNotNil: [:m | m font]! ! !PluggableTextMorph methodsFor: 'as yet unclassified' stamp: 'StephaneDucasse 5/13/2012 21:26'! methodCaseSensitiveStringsContainingit self handleEdit: [textMorph editor methodCaseSensitiveStringsContainingit]! ! !PluggableTextMorph methodsFor: 'as yet unclassified' stamp: 'FernandoOlivero 5/30/2011 09:26'! scrollToBottom "Scroll to the bottom." self vScrollBarValue: self vTotalScrollRange; setScrollDeltas! ! !PluggableTextMorph methodsFor: 'as yet unclassified' stamp: 'AlainPlantec 9/19/2011 19:39'! stylerClass ^ self class stylingClass ifNil: [NullTextStyler]! ! !PluggableTextMorph methodsFor: 'dependents access' stamp: 'AlainPlantec 11/8/2010 22:10'! canDiscardEdits "Return true if this view either has no text changes or does not care." ^ (hasUnacceptedEdits & askBeforeDiscardingEdits) not ! ! !PluggableTextMorph methodsFor: 'dependents access' stamp: 'AlainPlantec 11/8/2010 22:10'! hasUnacceptedEdits "Return true if this view has unaccepted edits." ^ hasUnacceptedEdits! ! !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: 'drawing' stamp: 'AlainPlantec 11/8/2010 22:10'! wantsFrameAdornments: aBoolean self setProperty: #wantsFrameAdornments toValue: aBoolean! ! !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: 'editor access' stamp: 'AlainPlantec 11/8/2010 22:10'! 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. ^ result! ! !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: 'editor access' stamp: 'AlainPlantec 11/19/2010 17:47'! 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. 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: 'AlainPlantec 2/21/2011 18:36'! selectAll "Tell my textMorph's editor to select all" textMorph editor selectAll. selectionInterval := self textMorph editor selectionInterval! ! !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: 'editor access' stamp: 'EstebanLorenzano 8/1/2012 11:19'! textMorph ^ textMorph ifNil: [ self textMorph: self textMorphClass new. textMorph ]! ! !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: 'event handling' stamp: 'SeanDeNigris 2/2/2013 09:45'! cursorEnd: aKeyboardEvent ^ textMorph editor cursorEnd: aKeyboardEvent.! ! !PluggableTextMorph methodsFor: 'event handling' stamp: 'SeanDeNigris 2/2/2013 09:45'! cursorHome: aKeyboardEvent ^ textMorph editor cursorHome: aKeyboardEvent.! ! !PluggableTextMorph methodsFor: 'event handling' stamp: 'AlainPlantec 11/8/2010 22:10'! handlesKeyboard: evt ^true! ! !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: 'event handling' stamp: 'CamilloBruni 9/2/2011 13:12'! keystrokeFromTextMorph: anEvent self eventHandler ifNotNil: [^ self eventHandler keyStroke: anEvent fromMorph: self]. ^ false! ! !PluggableTextMorph methodsFor: 'event handling' stamp: 'AlainPlantec 11/24/2010 21:03'! mouseDownFromTextMorph: anEvent "Nothing to do here normally"! ! !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: '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: 'event handling' stamp: 'AlainPlantec 11/8/2010 22:10'! onKeyStrokeSend: sel to: recipient textMorph on: #keyStroke send: sel to: recipient.! ! !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: '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: 'geometry' stamp: 'AlainPlantec 11/8/2010 22:10'! extraScrollRange ^ self height // 4! ! !PluggableTextMorph methodsFor: 'geometry' stamp: 'BenjaminVanRyseghem 8/5/2012 22:39'! innerExtent ^ self innerBounds extent - 6! ! !PluggableTextMorph methodsFor: 'geometry' stamp: 'AlainPlantec 11/8/2010 22:10'! 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. "don't reset it if it's not active" tempSelection = (Interval from: 1 to: 0) ifTrue: [retractableScrollBar ifTrue:[ ^ self]]. super resetExtent. "adjust scroller" self extent: self extent. self setSelection: tempSelection]! ! !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: 'initialization' stamp: 'AlainPlantec 11/8/2010 22:10'! acceptOnCR: trueOrFalse textMorph acceptOnCR: trueOrFalse! ! !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: '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: 'initialization' stamp: 'FernandoOlivero 5/10/2011 06:51'! model: aModel "Update the enablement state too." super model: aModel. self updateEnabled! ! !PluggableTextMorph methodsFor: 'initialization' stamp: 'AlainPlantec 11/8/2010 22:10'! on: anObject text: getTextSel accept: setTextSel readSelection: getSelectionSel menu: getMenuSel self model: anObject. getTextSelector := getTextSel. setTextSelector := setTextSel. getSelectionSelector := getSelectionSel. getMenuSelector := getMenuSel. self borderWidth: 1. self setText: self getText. self setSelection: self getSelection.! ! !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: '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: 'interactive error protocol' stamp: 'AlainPlantec 11/8/2010 22:10'! deselect ^ textMorph editor deselect! ! !PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'AlainPlantec 1/2/2011 10:33'! nextTokenFrom: start direction: dir ^ textMorph nextTokenFrom: start direction: dir! ! !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: 'interactive error protocol' stamp: 'AlainPlantec 11/8/2010 22:10'! select ^ textMorph editor select! ! !PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'AlainPlantec 2/21/2011 18:37'! selectFrom: start to: stop self textMorph editor selectFrom: start to: stop. ^selectionInterval := self textMorph editor selectionInterval! ! !PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'AlainPlantec 11/8/2010 22:10'! selectInvisiblyFrom: start to: stop ^ textMorph editor selectInvisiblyFrom: start to: stop! ! !PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'FernandoOlivero 5/30/2011 09:47'! selectedContents ^ textMorph editor selection! ! !PluggableTextMorph methodsFor: 'interactive error protocol' stamp: 'AlainPlantec 11/8/2010 22:10'! selectionInterval ^ textMorph editor selectionInterval! ! !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: '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: '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'! browseIt self handleEdit: [textMorph editor browseIt]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! cancel self setText: self getText. self setSelection: self getSelection! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! changeStyle self handleEdit: [textMorph editor changeStyle]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! chooseAlignment self handleEdit: [textMorph editor changeAlignment]! ! !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'! classNamesContainingIt self handleEdit: [textMorph editor classNamesContainingIt]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! copySelection self handleEdit: [textMorph editor copySelection]! ! !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: 'AlainPlantec 11/8/2010 22:10'! debugIt self handleEdit: [textMorph editor debugIt]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'BenjaminVanRyseghem 10/25/2012 16:13'! doIt UsersManager default currentUser canEvaluateCode ifFalse: [ ^ false ]. self handleEdit: [textMorph editor evaluateSelection]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'MarcusDenker 4/14/2011 10:55'! exploreIt self handleEdit: [textMorph editor evaluateSelectionAndDo: [:result | result explore]].! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! fileItIn self handleEdit: [textMorph editor fileItIn]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! find self handleEdit: [textMorph editor find]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! findAgain self handleEdit: [textMorph editor findAgain]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! implementorsOfIt self handleEdit: [textMorph editor implementorsOfIt]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'nice 3/31/2011 22:43'! inspectIt self handleEdit: [textMorph editor evaluateSelectionAndDo: [:result | result inspect]]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! methodNamesContainingIt self handleEdit: [textMorph editor methodNamesContainingIt]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! methodSourceContainingIt self handleEdit: [textMorph editor methodSourceContainingIt]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! methodStringsContainingit self handleEdit: [textMorph editor methodStringsContainingit]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! offerFontMenu self handleEdit: [textMorph editor changeTextFont]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'SeanDeNigris 2/5/2013 14:45'! paste self handleEdit: [textMorph editor paste]. self autoAccept ifTrue: [ self accept ].! ! !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: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! prettyPrint self handleEdit: [textMorph editor prettyPrint]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! printerSetup self handleEdit: [textMorph editor printerSetup]! ! !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: 'BenjaminVanRyseghem 2/8/2013 23:52'! redo self handleEdit: [ textMorph editor redo ]. self autoAccept ifTrue: [ self accept ].! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! referencesToIt self handleEdit: [textMorph editor referencesToIt]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! sendersOfIt self handleEdit: [textMorph editor sendersOfIt]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! setSearchString self handleEdit: [textMorph editor setSearchString]! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'AlainPlantec 11/8/2010 22:10'! tallyIt self handleEdit: [textMorph editor tallyIt]! ! !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: 'CamilloBruni 2/4/2012 14:48'! yellowButtonActivity "Called when the shifted-menu's 'more' item is chosen" ^ self yellowButtonActivity: false! ! !PluggableTextMorph methodsFor: 'menu commands' stamp: 'CamilloBruni 2/4/2012 14:59'! yellowButtonActivity: shiftKeyState "Called when the shifted-menu's 'more' item is chosen" (self getMenu: shiftKeyState) ifNotNilDo: [ :menu| menu setInvokingView: self. menu invokeModal. ^ true]. ^ false! ! !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: '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: '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: 'model access' stamp: 'AlainPlantec 11/8/2010 22:10'! selectionInterval: sel selectionInterval := sel! ! !PluggableTextMorph methodsFor: 'model access' stamp: 'AlainPlantec 11/8/2010 22:10'! setSelection: sel selectionInterval := sel. textMorph editor selectFrom: sel first to: sel last. self scrollSelectionIntoView ifFalse: [scroller changed].! ! !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: '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: 'model access' stamp: 'AlainPlantec 11/8/2010 22:10'! text ^ textMorph contents! ! !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: 'scroll bar events' stamp: 'AlainPlantec 11/8/2010 22:10'! showTextEditingState ^ self class showTextEditingState! ! !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: 'scrolling' stamp: 'AlainPlantec 9/19/2011 19:39'! defaultStyler ^ self stylerClass new view: self! ! !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: 'scrolling' stamp: 'AlainPlantec 8/26/2011 17:18'! shoutEnabled ^ self class shoutEnabled! ! !PluggableTextMorph methodsFor: 'scrolling' stamp: 'AlainPlantec 9/19/2011 19:34'! styled: aBoolean self styler stylingEnabled: aBoolean ! ! !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 10/19/2011 13:29'! styler: aStyler "Set the styler responsible for highlighting text in the receiver" styler := aStyler! ! !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: 'settings' stamp: 'AlainPlantec 11/8/2010 22:10'! bsText self changeText: (self text copyFrom: 1 to: (self text size - 1 max: 0))! ! !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: 'settings' stamp: 'AlainPlantec 11/8/2010 22:10'! replaceSelectionWith: aText ^ textMorph editor replaceSelectionWith: aText! ! !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: '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: 'styling' stamp: 'BenjaminVanRyseghem 6/19/2012 21:08'! hasEditingConflicts: aBoolean hasEditingConflicts := aBoolean. self changed! ! !PluggableTextMorph methodsFor: 'styling' stamp: 'BenjaminVanRyseghem 10/25/2012 15:05'! hasUnacceptedEdits: aBoolean "Set the hasUnacceptedEdits flag to the given value. " UsersManager default currentUser 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: '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: '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: '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: 'unaccepted edits' stamp: 'AlainPlantec 11/8/2010 22:15'! textMorphClass "Answer the class used to create the receiver's textMorph" ^TextMorphForEditView ! ! !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: 'private' stamp: 'BenjaminVanRyseghem 8/5/2012 21:09'! hScrollBarValue: scrollValue super hScrollBarValue: scrollValue. textMorph ifNotNil: [textMorph selectionChanged]. self triggerEvent: #hScroll with: scrollValue! ! !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: '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: 'private' stamp: 'AlainPlantec 2/21/2011 18:50'! vScrollBarValue: scrollValue super vScrollBarValue: scrollValue. textMorph ifNotNil: [textMorph selectionChanged]. self triggerEvent: #vScroll with: scrollValue! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PluggableTextMorph class instanceVariableNames: ''! !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: 'accessing' stamp: 'AlainPlantec 8/27/2011 15:54'! stylingClass: aClass StylingClass := aClass! ! !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: 'AlainPlantec 11/8/2010 22:10'! on: anObject text: getTextSel accept: setTextSel readSelection: getSelectionSel menu: getMenuSel ^ self new on: anObject text: getTextSel accept: setTextSel readSelection: getSelectionSel menu: getMenuSel! ! !PluggableTextMorph class methodsFor: 'settings' stamp: 'AlainPlantec 11/8/2010 22:10'! showTextEditingState ^ ShowTextEditingState ifNil: [ShowTextEditingState := true]! ! !PluggableTextMorph class methodsFor: 'settings' stamp: 'AlainPlantec 11/8/2010 22:10'! showTextEditingState: aBoolean ShowTextEditingState := aBoolean! ! PluggableTextMorph subclass: #PluggableTextMorphWithLimits instanceVariableNames: 'alertLimit locked warningLimit method lockIcon canLockChangeSelector lockSelector' classVariableNames: 'DefaultWarningLimit' poolDictionaries: '' category: 'Morphic-Pluggable Widgets'! !PluggableTextMorphWithLimits commentStamp: '' prior: 0! 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 ^ alertLimit ifNil: [ alertLimit := 2 * (self warningLimit) ]! ! !PluggableTextMorphWithLimits methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/6/2012 01:26'! alertLimit: anObject alertLimit := anObject! ! !PluggableTextMorphWithLimits methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/6/2012 00:24'! canLockChangeSelector: aSelector canLockChangeSelector := aSelector! ! !PluggableTextMorphWithLimits methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/3/2012 17:53'! locked ^ locked! ! !PluggableTextMorphWithLimits methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/3/2012 17:53'! locked: anObject locked := anObject! ! !PluggableTextMorphWithLimits methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/6/2012 01:27'! warningLimit ^ warningLimit ifNil: [ warningLimit := self class defaultWarningLimit ]! ! !PluggableTextMorphWithLimits methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 8/6/2012 01:27'! warningLimit: anObject warningLimit := anObject! ! !PluggableTextMorphWithLimits methodsFor: 'actions' stamp: 'BenjaminVanRyseghem 8/6/2012 01:27'! acceptBasic "should be refactored with accept that comes from PluggableTextMorphPlus " "Inform the model of text to be accepted, and return true if OK." | 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" 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: []! ! !PluggableTextMorphWithLimits methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 8/6/2012 01:38'! backgroundColorFor: rect "Return the current fillStyle of the receiver." | basicColor | basicColor := self basicColor. self warningLimit negative ifTrue: [ ^ basicColor ]. textMorph ifNotNil: [ | size | size := self textSize. ( size >= self warningLimit ) ifTrue: [ | returnedColor 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 -> Color white. 0.3->(Color white 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: 'drawing' stamp: 'CamilloBruni 10/9/2012 17:58'! basicColor ^ extension ifNil: [ color] ifNotNil: [ extension fillStyle ifNil: [ color ] ifNotNil: [ :fillStyle | fillStyle asColor ]].! ! !PluggableTextMorphWithLimits methodsFor: 'drawing' stamp: 'BenjaminVanRyseghem 3/20/2012 16:46'! basicWidth ^ StandardFonts defaultFont widthOf: $2! ! !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: '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: '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: 'icon' stamp: 'BenjaminVanRyseghem 8/5/2012 23:56'! canLockChangeSelector ^ canLockChangeSelector! ! !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/6/2012 01:27'! lockSelector ^ lockSelector! ! !PluggableTextMorphWithLimits methodsFor: 'icon' stamp: 'BenjaminVanRyseghem 8/5/2012 23:46'! lockSelector: aSelector lockSelector := aSelector! ! !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: '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: '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: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: 'BenjaminVanRyseghem 8/6/2012 00:45'! initialize "Initialization code for PluggableTextMorphWithLimits" 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: '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: 'protocol' stamp: 'BenjaminVanRyseghem 8/6/2012 01:30'! forceRedraw self fullDrawOn: World canvas! ! !PluggableTextMorphWithLimits methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 8/4/2012 01:10'! ifLocked: aBlock self ifLocked: aBlock ifUnlocked: []! ! !PluggableTextMorphWithLimits methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 8/4/2012 01:08'! ifLocked: aBlock ifUnlocked: anotherBlock self locked ifTrue: aBlock ifFalse: anotherBlock! ! !PluggableTextMorphWithLimits methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 8/4/2012 00:52'! lock self locked: true! ! !PluggableTextMorphWithLimits methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 8/5/2012 22:15'! lockFrom: aMethod self lock. method := aMethod. self setBalloonTextFrom: aMethod ! ! !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: 'protocol' stamp: 'BenjaminVanRyseghem 8/4/2012 00:52'! unlock self locked: false! ! !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: '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: '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: 'private'! textSize ^ self class textSizeOf: self text! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PluggableTextMorphWithLimits class instanceVariableNames: ''! !PluggableTextMorphWithLimits class methodsFor: 'accessing'! defaultWarningLimit ^ DefaultWarningLimit ifNil: [ DefaultWarningLimit := 350 ]! ! !PluggableTextMorphWithLimits class methodsFor: 'accessing'! defaultWarningLimit: anInteger " self defaultWarningLimit:nil " DefaultWarningLimit := anInteger! ! !PluggableTextMorphWithLimits class methodsFor: 'accessing'! resetDefaultWarningLimit " self resetDefaultWarningLimit " self defaultWarningLimit: nil! ! !PluggableTextMorphWithLimits class methodsFor: 'example'! 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'! 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: 'text'! ignoredCharacters ^ { Character space. Character tab. Character cr. $.. $;. $:. $'. $(. $) }! ! !PluggableTextMorphWithLimits class methodsFor: 'text'! 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.! ! ThreePhaseButtonMorph subclass: #PluggableThreePhaseButtonMorph instanceVariableNames: 'offImageSelector onImageSelector pressedImageSelector stateSelector helpText' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon'! !PluggableThreePhaseButtonMorph commentStamp: '' prior: 0! 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: 'accessing' stamp: 'BenjaminVanRyseghem 1/21/2012 23:25'! balloonText ^ self helpText! ! !PluggableThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/21/2012 23:25'! helpText ^ 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'! offImageSelector ^ offImageSelector! ! !PluggableThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/21/2012 23:07'! offImageSelector: anObject offImageSelector := anObject! ! !PluggableThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/21/2012 23:08'! onImageSelector ^ onImageSelector! ! !PluggableThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/21/2012 23:08'! onImageSelector: anObject onImageSelector := anObject! ! !PluggableThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/21/2012 23:08'! pressedImageSelector ^ pressedImageSelector! ! !PluggableThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/21/2012 23:08'! pressedImageSelector: anObject pressedImageSelector := anObject! ! !PluggableThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/21/2012 23:08'! stateSelector ^ stateSelector! ! !PluggableThreePhaseButtonMorph methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 1/21/2012 23:08'! stateSelector: anObject stateSelector := anObject! ! !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 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: 'updating' stamp: 'BenjaminVanRyseghem 1/21/2012 23:01'! updateOffImage self offImage: ( target perform: offImageSelector )! ! !PluggableThreePhaseButtonMorph methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 1/21/2012 23:01'! updateOnImage self onImage: ( target perform: onImageSelector )! ! !PluggableThreePhaseButtonMorph methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 1/21/2012 23:01'! updatePressedImage self pressedImage: ( target perform: pressedImageSelector )! ! !PluggableThreePhaseButtonMorph methodsFor: 'updating' stamp: 'BenjaminVanRyseghem 1/21/2012 23:15'! updateState ( target perform: stateSelector ) ifTrue: [ self state: #on ] ifFalse:[ self state: #off ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PluggableThreePhaseButtonMorph class instanceVariableNames: ''! !PluggableThreePhaseButtonMorph class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 1/21/2012 22:53'! on: aModel ^ self new target: aModel; yourself! ! ListItemWrapper subclass: #PluggableTreeItemNode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !PluggableTreeItemNode commentStamp: 'ar 2/12/2005 04:37' prior: 0! Tree item for PluggableTreeMorph.! !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: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:02'! canBeDragged ^model isDraggableNode: self! ! !PluggableTreeItemNode methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:03'! contents ^model contentsOfNode: self! ! !PluggableTreeItemNode methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:16'! hasContents ^model hasNodeContents: self! ! !PluggableTreeItemNode methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:04'! icon ^model iconOfNode: self! ! !PluggableTreeItemNode methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:16'! wantsDroppedObject: anotherItem ^model wantsDroppedNode: anotherItem on: self! ! SimpleHierarchicalListMorph subclass: #PluggableTreeMorph instanceVariableNames: 'roots selectedWrapper getRootsSelector getChildrenSelector hasChildrenSelector getLabelSelector getIconSelector getSelectedPathSelector getHelpSelector dropItemSelector wantsDropSelector dragItemSelector' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets'! !PluggableTreeMorph commentStamp: 'ar 2/12/2005 04:38' prior: 0! A pluggable tree morph.! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'mvdg 2/11/2007 13:53'! dragItemSelector ^dragItemSelector! ! !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 00:26'! dropItemSelector ^dropItemSelector! ! !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:24'! getChildrenSelector ^getChildrenSelector! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:24'! getChildrenSelector: aSymbol getChildrenSelector := aSymbol.! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:26'! getHelpSelector ^getHelpSelector! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:26'! getHelpSelector: aSymbol getHelpSelector := aSymbol! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:25'! getIconSelector ^getIconSelector! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:25'! getIconSelector: aSymbol getIconSelector := aSymbol! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:25'! getLabelSelector ^getLabelSelector! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:25'! getLabelSelector: aSymbol getLabelSelector := aSymbol! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:57'! getMenuSelector ^getMenuSelector! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:24'! getRootsSelector ^getRootsSelector! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:24'! getRootsSelector: aSelector getRootsSelector := aSelector. self update: getRootsSelector.! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 03:33'! getSelectedPathSelector ^getSelectedPathSelector! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 03:33'! getSelectedPathSelector: aSymbol getSelectedPathSelector := aSymbol.! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:24'! hasChildrenSelector ^hasChildrenSelector! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:25'! hasChildrenSelector: aSymbol hasChildrenSelector := 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: 'accessing' stamp: 'ar 2/12/2005 00:22'! roots ^roots! ! !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: 'LaurentLaffont 3/17/2010 21:42'! setSelectedSelector ^setSelectionSelector! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'LaurentLaffont 3/17/2010 21:42'! setSelectedSelector: aSymbol setSelectionSelector := aSymbol! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:26'! wantsDropSelector ^wantsDropSelector! ! !PluggableTreeMorph methodsFor: 'accessing' stamp: 'ar 2/12/2005 00:27'! wantsDropSelector: aSymbol wantsDropSelector := aSymbol! ! !PluggableTreeMorph methodsFor: 'morphic' stamp: 'mvdg 2/14/2007 14:58'! acceptDroppingMorph: aMorph event: evt | item dropTarget | dropItemSelector ifNil:[^self]. 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: 'morphic' stamp: 'ThierryGoubier 10/24/2012 17:32'! 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 := self model perform: dragItemSelector with: itemMorph withoutListWrapper. passenger ifNotNil: [aTransferMorph := TransferMorph withPassenger: passenger from: self. aTransferMorph dragTransferType: #dragTransfer. aTransferMorph align: aTransferMorph draggedMorph center with: anEvent position. anEvent hand grabMorph: aTransferMorph]. anEvent hand releaseMouseFocus: self! ! !PluggableTreeMorph methodsFor: 'morphic' stamp: 'stephaneDucasse 7/17/2010 16:39'! wantsDroppedMorph: aMorph event: anEvent aMorph dragTransferType == #dragTransfer ifFalse: [^false]. dropItemSelector ifNil: [^false]. wantsDropSelector ifNil: [^true]. ^ (model perform: wantsDropSelector with: aMorph passenger)! ! !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: '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: '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: '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 7/15/2005 12:11'! wantsDroppedNode: srcNode on: dstNode dropItemSelector ifNil:[^false]. wantsDropSelector ifNil:[^true]. ^(model perform: wantsDropSelector with: srcNode with: dstNode) == true! ! !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: '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: '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! ! ImageReadWriter subclass: #PluginBasedJPEGReadWriter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Files'! !PluginBasedJPEGReadWriter commentStamp: '' prior: 0! 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: 'jm 11/20/2001 10:34'! primImageHeight: aJPEGCompressStruct self primitiveFailed ! ! !PluginBasedJPEGReadWriter methodsFor: 'primitives' stamp: 'jm 11/20/2001 10:35'! primImageWidth: aJPEGCompressStruct self primitiveFailed ! ! !PluginBasedJPEGReadWriter methodsFor: 'primitives' stamp: 'jm 11/20/2001 10:35'! primJPEGCompressStructSize self primitiveFailed ! ! !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: 'primitives' stamp: 'ar 11/27/2001 00:39'! primJPEGPluginIsPresent ^false! ! !PluginBasedJPEGReadWriter methodsFor: 'primitives' stamp: 'jm 11/20/2001 10:35'! primJPEGReadHeader: aJPEGDecompressStruct fromByteArray: source errorMgr: aJPEGErrorMgr2Struct self primitiveFailed ! ! !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: 'jm 11/20/2001 10:35'! primJPEGWriteImage: aJPEGCompressStruct onByteArray: destination form: form quality: quality progressiveJPEG: progressiveFlag errorMgr: aJPEGErrorMgr2Struct self primitiveFailed ! ! !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'! 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: 'public access' stamp: 'jm 11/20/2001 10:23'! nextImage "Decode and answer a Form from my stream." ^ self nextImageSuggestedDepth: Display depth ! ! !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: '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: '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: '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 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: 'testing' stamp: 'ar 11/27/2001 00:40'! isPluginPresent ^self primJPEGPluginIsPresent! ! !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 class instanceVariableNames: ''! !PluginBasedJPEGReadWriter class methodsFor: 'image reading/writing' stamp: 'ar 6/16/2002 18:54'! primJPEGPluginIsPresent ^false! ! !PluginBasedJPEGReadWriter class methodsFor: 'image reading/writing' stamp: 'SeanDeNigris 7/12/2012 08:44'! 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 delete. 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: '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')! ! MorphTreeNodeModel subclass: #PluginTreeNode instanceVariableNames: 'selectedPosition' classVariableNames: '' poolDictionaries: '' category: 'NautilusCommon-Plugin-Manager'! !PluginTreeNode commentStamp: '' prior: 0! A PluginTreeNode is a node of a NautilusPluginManagerTree! !PluginTreeNode methodsFor: 'morphs' stamp: 'BenjaminVanRyseghem 8/25/2011 14:17'! firstMorph ^ self item ifNotNil: [:it | it first pluginName asStringMorph ]! ! !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 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: 'private' stamp: 'BenjaminVanRyseghem 8/25/2011 15:04'! getPositionsList ^ self item ifNil: [ {} ] ifNotNil: [:it | it first possiblePositions ]! ! !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:59'! setSelectedPosition: anIndex | position | selectedPosition := anIndex. position := self getPositionsList at: anIndex. self item at: 2 put: position. self changed: #getSelectedPosition! ! Object subclass: #Point instanceVariableNames: 'x y' classVariableNames: '' poolDictionaries: '' category: 'Kernel-BasicObjects'! !Point commentStamp: '' prior: 0! I represent an x-y pair of numbers usually designating a location on the screen.! !Point methodsFor: '*Fuel' stamp: 'MartinDias 3/29/2012 03:05'! fuelAccept: aGeneralMapper ^ aGeneralMapper visitPoint: self ! ! !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: '*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: '*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: '*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: '*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: '*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: 'accessing'! x "Answer the x coordinate." ^x! ! !Point methodsFor: 'accessing'! y "Answer the y coordinate." ^y! ! !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: '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: '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: '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: '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: '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: 'arithmetic'! 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: '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: 'comparing'! < aPoint "Answer whether the receiver is above and to the left of aPoint." ^x < aPoint x and: [y < aPoint y]! ! !Point methodsFor: 'comparing'! <= aPoint "Answer whether the receiver is neither below nor to the right of aPoint." ^x <= aPoint x and: [y <= aPoint y]! ! !Point methodsFor: 'comparing'! = aPoint self species = aPoint species ifTrue: [^x = aPoint "Refer to the comment in Object|=." x and: [y = aPoint y]] ifFalse: [^false]! ! !Point methodsFor: 'comparing'! > aPoint "Answer whether the receiver is below and to the right of aPoint." ^x > aPoint x and: [y > aPoint y]! ! !Point methodsFor: 'comparing'! >= aPoint "Answer whether the receiver is neither above nor to the left of aPoint." ^x >= aPoint x and: [y >= aPoint y]! ! !Point methodsFor: 'comparing' stamp: 'Alexandre Bergel 8/2/2010 12:20'! closeTo: aPoint ^ (x closeTo: aPoint x) and: [ y closeTo: aPoint 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'! 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: 'comparing'! 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: 'comparing'! min: aMin max: aMax ^ (self min: aMin) max: aMax! ! !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: '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: '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: 'converting'! asFloatPoint ^ x asFloat @ y asFloat! ! !Point methodsFor: 'converting'! asIntegerPoint ^ x asInteger @ y asInteger! ! !Point methodsFor: 'converting' stamp: 'wiz 11/25/2004 12:48'! asNonFractionalPoint (x isFraction or: [y isFraction]) ifTrue:[^ x asFloat @ y asFloat]! ! !Point methodsFor: 'converting'! asPoint "Answer the receiver itself." ^self! ! !Point methodsFor: 'converting'! 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'! 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: 'converting' stamp: 'di 11/6/1998 07:45'! isPoint ^ true! ! !Point methodsFor: 'converting' stamp: 'di 12/3/97 19:00'! rect: 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'! deepCopy "Implemented here for better performance." ^x deepCopy @ y deepCopy! ! !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: 'extent functions' stamp: 'wiz 8/9/2005 02:44'! guarded "Return a positive nonzero extent." self max: 1@1 .! ! !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: '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: '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: '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: '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: '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: '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: '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 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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: 'point functions' stamp: 'di 12/1/97 12:40'! nearestPointOnLineFrom: p1 to: p2 "This will not give points beyond the endpoints" ^ (self nearestPointAlongLineFrom: p1 to: p2) adhereTo: (p1 rect: p2)! ! !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: '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: '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: 'point functions' stamp: 'di 12/1/97 12:12'! onLineFrom: p1 to: p2 ^ self onLineFrom: p1 to: p2 within: 2! ! !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: '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: '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: '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: 'point functions' stamp: 'StephaneDucasse 7/7/2010 23:38'! sign ^ (x sign @ y sign)! ! !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'! squaredDistanceTo: aPoint "Answer the distance between aPoint and the receiver." | delta | delta := aPoint - self. ^ delta dotProduct: delta! ! !Point methodsFor: 'point functions' stamp: 'ar 11/12/1998 01:44'! transposed ^y@x! ! !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: 'polar coordinates'! r "Answer the receiver's radius in polar coordinate system." ^(self dotProduct: self) sqrt! ! !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: '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: '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: 'self evaluating' stamp: 'sd 7/31/2005 21:48'! isSelfEvaluating ^ self class == Point! ! !Point methodsFor: 'testing' stamp: 'ar 10/29/2000 19:02'! isZero ^x isZero and:[y isZero]! ! !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: '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: '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: 'transforming'! scaleBy: factor "Answer a Point scaled by factor (an instance of Point)." ^(factor x * x) @ (factor y * 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: 'transforming'! translateBy: delta "Answer a Point translated by delta (an instance of Point)." ^(delta x + x) @ (delta y + y)! ! !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: '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: '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: '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: '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: '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: 'truncation and roundoff' stamp: 'wiz 1/11/2006 18:32'! isIntegerPoint ^ x isInteger and: [ y isInteger ] ! ! !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: '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: 'private' stamp: 'lr 7/4/2009 10:42'! bitShiftPoint: bits x := x bitShift: bits. y := y bitShift: bits! ! !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: 'private' stamp: 'lr 7/4/2009 10:42'! setX: xValue setY: yValue x := xValue. y := yValue! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Point class instanceVariableNames: ''! !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'! r: rho degrees: degrees "Answer an instance of me with polar coordinates rho and theta." ^self basicNew setR: rho degrees: degrees! ! !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! ! IntegerArray variableWordSubclass: #PointArray uses: TPointAccess instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Balloon-Collections'! !PointArray commentStamp: '' prior: 0! 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: 'accessing'! at: index ^(super at: index * 2 - 1) @ (super at: index * 2)! ! !PointArray methodsFor: 'accessing'! 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'! 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'! 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 methodsFor: 'converting' stamp: 'NS 5/30/2001 20:54'! asPointArray ^ self! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PointArray class uses: TPointAccess classTrait instanceVariableNames: ''! !PointArray class methodsFor: 'instance creation' stamp: 'ar 10/16/1998 00:04'! new: n ^super new: n*2! ! TestCase subclass: #PointArrayTest instanceVariableNames: 'pointArray' classVariableNames: '' poolDictionaries: '' category: 'BalloonTests-Collections'! !PointArrayTest commentStamp: 'tbn 3/25/2011 15:06' prior: 0! SUnit Test for PointArray! !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 10:13'! testAt self assert: 0@0 equals: (pointArray at: 1). self assert: 10@3 equals: (pointArray at: 2) ! ! !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 11:54'! testAtPutFloat pointArray at: 2 put: 1.2 @ 5.5. self assert: 1 @ 5 equals: (pointArray at: 2) ! ! !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 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'! testBounds self assert: (0@0 corner: 10@3) equals: pointArray bounds ! ! !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:16'! testSize self assert: 2 equals: pointArray size ! ! ClassTestCase subclass: #PointTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Tests-Primitives'! !PointTest commentStamp: 'StephaneDucasse 7/7/2010 23:43' prior: 0! This is the unit test for the class Point. ! !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: '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: '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: '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/8/2010 00:09'! testLeftRotated self assert: (10 @ 20) leftRotated = (20@ -10)! ! !PointTest methodsFor: 'tests - testing' stamp: 'StephaneDucasse 7/8/2010 00:10'! testRightRotated self assert: (10 @ 20) rightRotated = (-20@10)! ! !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: '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. ! ! ObjectExplorer subclass: #PointerExplorer instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tools-Explorer'! !PointerExplorer commentStamp: 'avi 8/21/2004 20:01' prior: 0! 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 instanceVariableNames: ''! !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 ! ! ObjectExplorerWrapper subclass: #PointerExplorerWrapper instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tools-Explorer'! !PointerExplorerWrapper commentStamp: 'avi 8/21/2004 19:58' prior: 0! 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: '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]! ! !PointerExplorerWrapper methodsFor: 'testing' stamp: 'ab 8/22/2003 18:39'! hasContents ^true! ! TestCase subclass: #PointerFinderTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'ToolsTest-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'! 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}. "! ! !PointerFinderTest methodsFor: 'as yet unclassified' stamp: 'AndyKellens 6/11/2010 14:17'! testNoPointingObject | myObject | myObject := Object new. self assert: (myObject pointersTo) isEmpty! ! PathShape subclass: #Polygon instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Geometry'! !Polygon commentStamp: 'LaurentLaffont 3/31/2011 21:05' prior: 0! I'm a Polygon PathShape (see PathShape).! !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! ! !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! ! BorderedMorph subclass: #PolygonMorph uses: TAbleToRotate instanceVariableNames: 'vertices closed filledForm arrows arrowForms smoothCurve curveState borderDashSpec handles borderForm' classVariableNames: 'CurvierByDefault' poolDictionaries: '' category: 'Morphic-Basic'! !PolygonMorph commentStamp: 'md 2/24/2006 20:34' prior: 0! 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: 'access' stamp: 'aoy 2/15/2003 20:51'! borderColor: aColor super borderColor: aColor. (borderColor isColor and: [borderColor isTranslucentColor]) == (aColor isColor and: [aColor isTranslucentColor]) ifFalse: ["Need to recompute fillForm and borderForm if translucency of border changes." self releaseCachedState]! ! !PolygonMorph methodsFor: 'access' stamp: 'sw 8/25/2000 22:37'! isClosed ^ closed! ! !PolygonMorph methodsFor: 'access' stamp: 'di 9/7/2000 16:18'! isCurve ^ smoothCurve! ! !PolygonMorph methodsFor: 'access' stamp: 'jm 11/19/97 18:55'! isOpen ^ closed not! ! !PolygonMorph methodsFor: 'access' stamp: 'sw 8/23/2000 16:16'! makeOpenOrClosed "toggle the open/closed status of the receiver" closed ifTrue: [self makeOpen] ifFalse: [self makeClosed]! ! !PolygonMorph methodsFor: 'access' stamp: 'CamilloBruni 8/1/2012 16:11'! 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: 'access' 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: 'access' stamp: 'wiz 6/6/2004 21:56'! 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: 'access' stamp: 'sw 9/14/97 18:22'! vertices ^ vertices! ! !PolygonMorph methodsFor: 'accessing' stamp: 'nk 9/4/2004 17:23'! borderWidth: anInteger borderColor ifNil: [borderColor := Color black]. borderWidth := anInteger max: 0. self computeBounds! ! !PolygonMorph methodsFor: 'accessing' stamp: 'sw 11/24/1999 14:57'! couldHaveRoundedCorners ^ false! ! !PolygonMorph methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 7/18/2011 18:30'! drawDropShadowOn: 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 shadowColor. ].! ! !PolygonMorph methodsFor: 'attachments' stamp: 'nk 8/14/2004 13:58'! boundsSignatureHash ^(vertices - (self positionInWorld)) hash ! ! !PolygonMorph methodsFor: 'attachments' stamp: 'nk 2/25/2001 17:21'! defaultAttachmentPointSpecs ^{ { #firstVertex } . { #midpoint } . { #lastVertex } }! ! !PolygonMorph methodsFor: 'attachments' stamp: 'nk 4/18/2001 11:43'! endShapeColor: aColor self borderColor: aColor. self isClosed ifTrue: [ self color: aColor ].! ! !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: 'attachments' stamp: 'nk 2/25/2001 17:19'! firstVertex ^vertices first! ! !PolygonMorph methodsFor: 'attachments' stamp: 'nk 2/25/2001 17:19'! lastVertex ^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: 'attachments' stamp: 'nice 3/5/2010 22:40'! 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: 'attachments' stamp: 'nk 7/3/2003 14:42'! 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: 'caching' stamp: 'di 9/4/2000 13:36'! releaseCachedState super releaseCachedState. filledForm := nil. arrowForms := nil. borderForm := nil. curveState := nil. (self hasProperty: #flex) ifTrue: [self removeProperty: #unflexedVertices; removeProperty: #flex]. ! ! !PolygonMorph methodsFor: 'dashes' stamp: 'dgd 2/22/2003 18:55'! borderDashOffset borderDashSpec size < 4 ifTrue: [^0.0]. ^(borderDashSpec fourth) asFloat! ! !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: '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: '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: 'dashes' stamp: 'nk 2/25/2001 17:05'! vertexAt: n ^vertices at: (n min: vertices size).! ! !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: '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: 'drawing' stamp: 'ar 11/26/2001 23:15'! drawBorderOn: aCanvas self drawClippedBorderOn: aCanvas usingEnds: (Array with: vertices first with: vertices last)! ! !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: '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: 'drawing' stamp: 'nk 10/4/2000 12:23'! drawDashedBorderOn: aCanvas self drawDashedBorderOn: aCanvas usingEnds: (Array with: vertices first with: vertices last)! ! !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: 'drawing'! 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 isTranslucentColor]) 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: '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: 'dropping/grabbing' stamp: 'di 9/8/2000 09:56'! justDroppedInto: newOwner event: evt | delta | (newOwner isKindOf: PasteUpMorph) ifTrue: ["Compensate for border width so that gridded drop is consistent with gridded drag of handles." delta := borderWidth+1//2. self position: (newOwner gridPoint: self position + delta) - delta]. ^ super justDroppedInto: newOwner event: evt! ! !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: 'editing' stamp: 'wiz 2/7/2006 23:35'! clickVertex: ix event: evt fromHandle: handle "Backstop for MixedCurveMorph"! ! !PolygonMorph methodsFor: 'editing' stamp: 'wiz 2/8/2006 18:20'! deleteVertexAt: anIndex "This acts as a backstop for MixedCurveMorph." self setVertices: (vertices copyReplaceFrom: anIndex to: anIndex with: Array new). ! ! !PolygonMorph methodsFor: 'editing' stamp: 'ar 3/17/2001 14:30'! dragVertex: ix event: evt fromHandle: handle | p | p := self isCurve ifTrue: [evt cursorPoint] ifFalse: [self griddedPoint: evt cursorPoint]. handle position: p - (handle extent//2). self verticesAt: ix put: p. ! ! !PolygonMorph methodsFor: 'editing' stamp: 'wiz 2/8/2006 18:35'! 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 -wiz" | 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: 'editing' stamp: 'wiz 2/8/2006 18:37'! handleColorAt: vertIndex "This is a backstop for MixedCurveMorph" ^ Color yellow ! ! !PolygonMorph methodsFor: 'editing' stamp: 'wiz 2/8/2006 18:19'! 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: '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: '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: 'editing' stamp: 'di 9/8/2000 10:39'! verticesAt: ix put: newPoint vertices at: ix put: newPoint. self computeBounds! ! !PolygonMorph methodsFor: 'event handling' stamp: 'di 8/20/2000 14:29'! handlesMouseDown: evt ^ (super handlesMouseDown: evt) or: [evt shiftPressed]! ! !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: 'geometry' stamp: 'nk 2/15/2001 09:09'! 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: '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: '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: '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: '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: 'geometry' stamp: 'edc 3/20/2002 14:24'! flipHAroundX: centerX "Flip me horizontally around the center. If centerX is nil, compute my center of gravity." | cent | cent := centerX ifNil: [bounds center x "cent := 0. vertices do: [:each | cent := cent + each x]. cent asFloat / vertices size"] "average is the center" ifNotNil: [centerX]. self setVertices: (vertices collect: [:vv | ((vv x - cent) * -1 + cent) @ vv y]) reversed.! ! !PolygonMorph methodsFor: 'geometry' stamp: 'sw 9/14/97 18:22'! flipVAroundY: centerY "Flip me vertically around the center. If centerY is nil, compute my center of gravity." | cent | cent := centerY ifNil: [bounds center y "cent := 0. vertices do: [:each | cent := cent + each y]. cent asFloat / vertices size"] "average is the center" ifNotNil: [centerY]. self setVertices: (vertices collect: [:vv | vv x @ ((vv y - cent) * -1 + cent)]) reversed.! ! !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: 'geometry' stamp: 'nk 2/15/2001 15:45'! intersectionWithLineSegmentFromCenterTo: aPoint ^self closestPointTo: aPoint! ! !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: 'geometry' stamp: 'nk 7/18/2003 17:38'! isBordered ^false! ! !PolygonMorph methodsFor: 'geometry' stamp: 'nk 7/18/2003 17:06'! lineBorderColor ^self borderColor! ! !PolygonMorph methodsFor: 'geometry' stamp: 'nk 7/18/2003 17:06'! lineBorderColor: aColor self borderColor: aColor! ! !PolygonMorph methodsFor: 'geometry' stamp: 'nk 7/18/2003 17:07'! lineBorderWidth ^self borderWidth! ! !PolygonMorph methodsFor: 'geometry' stamp: 'nk 7/18/2003 17:46'! lineBorderWidth: anInteger self borderWidth: anInteger! ! !PolygonMorph methodsFor: 'geometry' stamp: 'nk 7/18/2003 16:48'! lineColor ^self borderColor! ! !PolygonMorph methodsFor: 'geometry' stamp: 'nk 7/18/2003 16:48'! lineColor: aColor self borderColor: aColor! ! !PolygonMorph methodsFor: 'geometry' stamp: 'nk 7/18/2003 16:47'! lineWidth ^self borderWidth! ! !PolygonMorph methodsFor: 'geometry' stamp: 'nk 7/18/2003 17:48'! lineWidth: anInteger self borderWidth: (anInteger rounded max: 1)! ! !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: '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: '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: '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: 'geometry' stamp: 'nk 9/4/2004 11:57'! 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: 'geometry' stamp: 'nk 3/6/2001 16:36'! straighten self setVertices: { vertices first . vertices last }! ! !PolygonMorph methodsFor: 'geometry' stamp: 'ar 10/6/2000 15:40'! transformedBy: aTransform self setVertices: (self vertices collect:[:v| aTransform localPointToGlobal: v])! ! !PolygonMorph methodsFor: 'geometry etoy' stamp: 'di 9/24/2000 08:38'! referencePosition "Return the current reference position of the receiver" ^ self valueOfProperty: #referencePosition ifAbsent: [super referencePosition] ! ! !PolygonMorph methodsFor: 'geometry etoy' stamp: 'di 9/24/2000 09:21'! 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: 'geometry etoy' stamp: 'di 9/24/2000 09:31'! 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: 'geometry testing' stamp: 'di 8/20/2000 14:33'! containsPoint: aPoint (super containsPoint: aPoint) ifFalse: [^ false]. closed & 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: 'halo control' 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: 'initialization' stamp: 'di 9/8/2000 09:44'! beSmoothCurve smoothCurve == true ifFalse: [smoothCurve := true. self computeBounds]! ! !PolygonMorph methodsFor: 'initialization' stamp: 'di 9/8/2000 09:45'! beStraightSegments smoothCurve == false ifFalse: [smoothCurve := false. self computeBounds]! ! !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: 'initialization' stamp: 'dgd 2/14/2003 22:30'! defaultColor "answer the default color/fill style for the receiver" ^ Color orange! ! !PolygonMorph methodsFor: 'initialization' stamp: 'AlainPlantec 1/12/2010 12:52'! initialize "initialize the state of the receiver" 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: 'initialization' stamp: 'dgd 2/14/2003 20:09'! 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: '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: '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: 'menu' stamp: 'wiz 4/1/2006 19:05'! addPolyLIneCurveMenuItems: aMenu hand: aHandMorph aMenu addLine; addUpdating: #openOrClosePhrase target: self action: #makeOpenOrClosed. aMenu addUpdating: #smoothOrSegmentedPhrase target: self action: #toggleSmoothing.! ! !PolygonMorph methodsFor: 'menu' stamp: 'wiz 12/29/2004 13:50'! 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: #rectOval. ! ! !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: '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: 'menu' stamp: 'nk 2/26/2001 20:11'! arrows ^arrows! ! !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: 'dgd 8/30/2003 21:57'! handlesShowingPhrase ^ (self showingHandles ifTrue: ['hide handles'] ifFalse: ['show handles']) translated! ! !PolygonMorph methodsFor: 'menu' stamp: '6/9/97 21:32 di'! makeBackArrow arrows := #back. self computeBounds! ! !PolygonMorph methodsFor: 'menu' stamp: '6/9/97 21:32 di'! makeBothArrows arrows := #both. self computeBounds! ! !PolygonMorph methodsFor: 'menu' stamp: 'di 8/20/2000 14:27'! makeClosed closed := true. handles ifNotNil: [self removeHandles; addHandles]. self computeBounds! ! !PolygonMorph methodsFor: 'menu' stamp: '6/9/97 21:32 di'! makeForwardArrow arrows := #forward. self computeBounds! ! !PolygonMorph methodsFor: 'menu' stamp: '6/9/97 21:32 di'! makeNoArrows arrows := #none. self computeBounds! ! !PolygonMorph methodsFor: 'menu' stamp: 'di 8/20/2000 14:27'! makeOpen closed := false. handles ifNotNil: [self removeHandles; addHandles]. self computeBounds! ! !PolygonMorph methodsFor: 'menu' stamp: 'di 9/7/2000 13:10'! quickFill: ignored! ! !PolygonMorph methodsFor: 'menu' stamp: 'CamilloBruni 8/1/2012 16:15'! removeHandles handles ifNotNil: [ handles do: [:h | h delete]. handles := nil].! ! !PolygonMorph methodsFor: 'menu' stamp: 'di 9/24/2000 09:25'! setRotationCenterFrom: aPoint "Polygons store their referencePosition." self setProperty: #referencePosition toValue: aPoint! ! !PolygonMorph methodsFor: 'menu' stamp: 'sw 8/19/2000 15:17'! showingHandles ^ handles notNil! ! !PolygonMorph methodsFor: 'menu' stamp: 'sw 8/19/2000 15:16'! showOrHideHandles self showingHandles ifTrue: [self removeHandles] ifFalse: [self addHandles]! ! !PolygonMorph methodsFor: 'menu' stamp: 'jb 7/1/2011 10:53'! 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 evaluatorClass evaluate: executableSpec] ifError: [^ self stopStepping; dashedBorder: nil]. newSpec first isNumber & newSpec second isNumber & newSpec third isColor ifFalse: [^ self stopStepping; dashedBorder: nil]. newSpec size = 3 ifTrue: [^ self stopStepping; dashedBorder: newSpec]. (newSpec size = 5 and: [newSpec fourth isNumber & newSpec fifth isNumber]) ifTrue: [^ self dashedBorder: newSpec; startStepping]. ! ! !PolygonMorph methodsFor: 'menu' stamp: 'di 10/3/2000 07:12'! standardArrows self removeProperty: #arrowSpec. self computeBounds! ! !PolygonMorph methodsFor: 'menu' stamp: 'di 8/20/2000 14:31'! toggleHandles handles ifNil: [self addHandles] ifNotNil: [self removeHandles]. ! ! !PolygonMorph methodsFor: 'menu' stamp: 'di 9/7/2000 15:43'! toggleSmoothing smoothCurve := smoothCurve not. handles ifNotNil: [self removeHandles; addHandles]. self computeBounds! ! !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: '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: '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: '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: '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: '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: 'rotate scale and flex' stamp: 'AlainPlantec 5/7/2010 23:53'! rotationDegrees ^ self forwardDirection! ! !PolygonMorph 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! ! !PolygonMorph methodsFor: 'shaping' stamp: 'wiz 1/8/2005 19:27'! diamondOval "Set my vertices to an array of edge midpoint vertices. Order of vertices is in the tradion of warpblt quads." | b r | b := self bounds. r := {b leftCenter. b bottomCenter. b rightCenter. b topCenter}. self setVertices: r! ! !PolygonMorph methodsFor: 'shaping' stamp: 'wiz 1/8/2005 19:20'! rectOval "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: 'smoothing' stamp: 'wiz 1/7/2005 19:53'! coefficients "Compute an array for the coefficients." | verts vertXs vertYs slopeXs slopeYs coefficients | curveState ifNotNil: [^ curveState at: 1]. verts := self vertices. verts size < 1 ifTrue: [^ self]. "Less than three points handled as segments by our lineSegmentsDo:" (self isCurvier) ifFalse: [closed ifTrue: [verts := verts , verts first asOrderedCollection]]. coefficients := {vertXs := verts collect: [:p | p x asFloat]. slopeXs := self slopes: vertXs. vertXs changeInSlopes: slopeXs. vertXs changeOfChangesInSlopes: slopeXs. vertYs := verts collect: [:p | p y asFloat]. slopeYs := self slopes: vertYs. vertYs changeInSlopes: slopeYs. vertYs changeOfChangesInSlopes: slopeYs. Array new: verts size withAll: 12}. coefficients at: 9 put: ((1 to: verts size) collect: [:i | (coefficients cubicPointPolynomialAt: i) bestSegments]). (self isCurvier) ifFalse: [closed ifTrue: [coefficients := coefficients collect: [:each | each allButLast]]]. curveState := {coefficients. nil. nil}. self computeNextToEndPoints. ^ coefficients! ! !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: '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: '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: '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: '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: 'smoothing' stamp: 'AlainPlantec 1/7/2010 22:33'! slopes: knots "Choose slopes according to state of polygon" self isCurvy ifFalse: [^ knots segmentedSlopes]. ^ (closed and: [self isCurvier]) ifTrue: [knots closedCubicSlopes] ifFalse: [knots naturalCubicSlopes]! ! !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: 'stepping and presenter' stamp: 'StephaneDucasse 12/19/2011 18:45'! isAnimated borderDashSpec ifNil: [^false]. ^ borderDashSpec size = 5 and: [(borderDashSpec fifth) > 0]! ! !PolygonMorph methodsFor: 'stepping and presenter' stamp: 'dgd 2/22/2003 18:58'! 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: 't-rotating'! forwardDirection "Return the receiver's forward direction (in eToy terms)" ^self valueOfProperty: #forwardDirection ifAbsent:[0.0]! ! !PolygonMorph methodsFor: 't-rotating'! forwardDirection: newDirection "Set the receiver's forward direction (in eToy terms)" self setProperty: #forwardDirection toValue: newDirection.! ! !PolygonMorph methodsFor: 't-rotating'! heading "Return the receiver's heading" ^ self owner ifNil: [self forwardDirection] ifNotNil: [self forwardDirection + self owner degreesOfFlex]! ! !PolygonMorph methodsFor: 't-rotating'! 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: 'wiz 7/18/2004 23:00'! hasArrows "Are all the conditions meet for having arrows?" ^ (closed or: [arrows == #none or: [vertices size < 2]]) not! ! !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: '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: 'testing' stamp: 'nk 10/13/2003 18:36'! isLineMorph ^closed not! ! !PolygonMorph methodsFor: 'testing' stamp: 'di 9/9/2000 09:24'! stepTime ^ 100! ! !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: 'visual properties' stamp: 'di 9/19/2000 22:00'! fillStyle self isOpen ifTrue: [^ self borderColor "easy access to line color from halo"] ifFalse: [^ super fillStyle]! ! !PolygonMorph methodsFor: 'visual properties' stamp: 'wiz 1/7/2005 20:39'! fillStyle: newColor self isOpen ifTrue: [^ self borderColor: newColor asColor "easy access to line color from halo"] ifFalse: [^ super fillStyle: newColor]! ! !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: '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: '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: 'dgd 2/22/2003 18:56'! 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 rect: pts last) encompass: (pts second)) expandBy: 1. arrowForm := Form extent: box extent asIntegerPoint. bb := (BitBlt current 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: '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: '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: 'private' stamp: 'di 9/7/2000 13:30'! 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 current 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 isTranslucentColor]) 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: '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: 'private' stamp: 'di 8/31/2000 13:46'! includesHandle: aMorph handles ifNil: [^ false]. ^ handles includes: aMorph! ! !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: '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: 'private' stamp: 'di 9/8/2000 10:36'! setVertices: newVertices vertices := newVertices. handles ifNotNil: [self removeHandles; addHandles]. self computeBounds! ! !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 class uses: TAbleToRotate classTrait instanceVariableNames: ''! !PolygonMorph class methodsFor: 'instance creation' stamp: 'wiz 7/13/2005 00:43'! arrowPrototype "Answer an instance of the receiver that will serve as a prototypical arrow" | aa | aa := self new. aa vertices: (Array with: 0@0 with: 40@40) color: Color black borderWidth: 2 borderColor: Color black. "aa setProperty: #noNewVertices toValue: true." "Revert to expected behavior. Remove vestigial code." aa makeForwardArrow. "is already open" aa computeBounds. ^ aa! ! !PolygonMorph class methodsFor: 'instance creation' stamp: 'StephaneDucasse 5/13/2012 17:13'! 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 stop | "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: 'instance creation' stamp: 'StephaneDucasse 5/13/2012 17:14'! 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 oldVerts pN opposite stop | "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: '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: 'settings' stamp: 'AlainPlantec 12/10/2009 08:22'! curvierByDefault ^ CurvierByDefault ifNil: [CurvierByDefault := true]! ! !PolygonMorph class methodsFor: 'settings' stamp: 'AlainPlantec 12/10/2009 08:21'! curvierByDefault: aBoolean CurvierByDefault := aBoolean! ! !PolygonMorph class methodsFor: 'settings' stamp: 'AlainPlantec 12/19/2009 23:38'! defaultArrowSpec ^ 5@4! ! MorphTest subclass: #PolygonMorphTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'MorphicTests-Basic'! !PolygonMorphTest commentStamp: 'nice 2/16/2008 02:13' prior: 0! This class holds tests for PolygonMorph! !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). ! ! Object subclass: #PolymorphSystemSettings instanceVariableNames: '' classVariableNames: 'DesktopColor DesktopGradientDirection DesktopGradientFillColor DesktopGradientOrigin DesktopImageFileName DesktopLogo DesktopLogoFileName ShowDesktopLogo UseDesktopGradientFill' poolDictionaries: '' category: 'Settings-Polymorph'! !PolymorphSystemSettings commentStamp: 'LaurentLaffont 3/15/2011 20:46' prior: 0! I provide settings for Morphic appearance (theme, fonts, colors, ...) that can be found and changed in the Settings browser.! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PolymorphSystemSettings class instanceVariableNames: 'usePolymorphDiffMorph'! !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: 'AlainPlantec 1/10/2010 09:37'! desktopColor ^ DesktopColor ifNil: [DesktopColor := World defaultWorldColor] ! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'AlainPlantec 11/28/2009 15:50'! desktopColor: aColor DesktopColor := aColor. 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 11/30/2009 06:33'! desktopGradientDirection "#Radial #Vertical or #Horizontal" ^ DesktopGradientDirection ifNil: [DesktopGradientDirection := #Vertical]! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'AlainPlantec 11/28/2009 15:50'! desktopGradientDirection: aSymbol "#Radial #Vertical or #Horizontal" DesktopGradientDirection := aSymbol. self desktopBackgroundChanged ! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'AlainPlantec 11/30/2009 06:32'! desktopGradientFillColor ^ DesktopGradientFillColor ifNil: [DesktopGradientFillColor := self desktopColor]! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'AlainPlantec 11/28/2009 15:50'! desktopGradientFillColor: aColor DesktopGradientFillColor := aColor. self desktopBackgroundChanged! ! !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/28/2009 16:10'! desktopGradientOrigin: aSymbol "#Radial #Vertical or #Horizontal" DesktopGradientOrigin := aSymbol. self desktopBackgroundChanged ! ! !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:47'! desktopImageFileName: aFileName DesktopImageFileName := aFileName. self desktopBackgroundChanged! ! !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:16'! desktopLogo: anImageMorph DesktopLogo := anImageMorph! ! !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 9/11/2011 07:40'! desktopLogoFileName ^ DesktopLogoFileName ifNil: [DesktopLogoFileName := '']! ! !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 9/14/2011 08:24'! 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: #FilePath; 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: #FilePath; 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'] ! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'AlainPlantec 9/11/2011 07:15'! pharoLogo ^ ImageMorph withForm: self pharoLogoForm! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'AlainPlantec 9/11/2011 07:03'! pharoLogoContents ^ 'iVBORw0KGgoAAAANSUhEUgAAAXcAAACHCAYAAADtJRlTAAC8WUlEQVR4XuWddUAcSdP/d3D3 EAged3d317uc5C7JWdzd3UiIAEHj7u7uDgR3J0AICSGhLyePvL/3V9UzA73D7LJLSJ48L3/U LQeb3ZGeT1d/q7pKwdUZ91GmGBZc+U1Lg+vGaWKV/1pVfqv8ViFmBWb2hbLgk9nHf0DlHzgf BXAwHYlVfuhXfqv8VrFmAOZa+eFe+eFe0UDXUWO6ElP33soP+cpvld8pKocpem/UUwwJdFAM 8jP+0p6byg/3/74BqRLiin5b7MBsFX03Wyv6+zgohgS0AGsF1hKstWJo0FCwEdSGBf0Ig7KB OshX/utf+e3/KMR1KtIUA7daIuC/tNVw5Yf7f88gVQI6DKb68J5NEgsCCxQsGGw/2AHGTlst vxdlteJepMWye9EA+XEqPPvKD/jKb/8XYK7JilY0PQ2t1L9V9NxgrBjsX/VLWxFXfrj/d4G9 eCAqBge0NZx09kG1gKhcB7+oXEewatvi86sFx+U7bY9/VW17Qr7L7qS3rnuTC533psBrSqH7 wTTidiiNuB9OJ7ZeTxIA7pPhs/Qlg7byA77y2/8VmbIEwB2XGyl6eZnDqtYGPG1XgHETxdDA wcJKdhx85np4XVuGjQUbDY5VX/j3zRQDfJ1AlrEFs6Cr5p4bzMqQQj8r6Cs/3P+7wC56D/ow uFobTjpz3+1gKnHZk0JcdycTN2pJxHVXEnHbmUTcdyZSc9shGv97t70pxH5reDoM1MVcq/nG DOD15ABf+WFS+e2/TKLUU3ReZQzwdQYtvD7AuCuM9WnwGd5gR+zGH75Wb9HZuz/ueBg293hY 1NbrcfGhGa+zHyTnZT1I4u0+/Hwv6WXWnUSwBP513aXouNmnnsf023r7We2FZ+9a/nLgCnze MbpqBkeJQh+/b4BvNa7dYkMVTtNnA33lh/uXPYilYNcXzBAGUSvDiafvue1PBbADsAHo7mgI bwC5O7UE3rYnELdtaPH83/YmA9wj0mBALuGazEC4GzKfXfkBX/ntvxPo3deZg9PTHCDbD8b2 dJQm3aeduN19043H2x8mJ6a8fP/yr3/+692//vkv8uff/ySFH/4i+b//RXKK/iSZ7z+QjHcf SHrhB5KGBj+nvP2dpBT8TpLR4Gf8fQa8ZsN7X5E/SMEff5I3f/z5/n56fu6cC9EJnTbdfOY8 +dgt+F5/+P5JEOfqRz38jsuNVThPnxT0/6fh/tGR8C8P7AYCiI1g0PQznXXlqfu+FOK+m4c6 66mrhDu8uu8BuPuGp1HPvfE0U/w8CeArP9wrv33JUGd1clzFNoWxPAZsBfzbo0O23n0WADDP ffsh/3//93/IP//xL/L2w98kh/xJXgDIX7z7g2QgqMHS334gqfCaDK9JAHG0RLCEN4TEg8W9 JiT2dRGJBovJLyJRYJGvSiwCX+F3OAG8eP8Hyf/zL3L/xZtX8y/FxPfaePMZrhTQiQIJ6Gf0 6tXIoBUOeQlLDcH0/ivgriWotY2A/8cmAhVwVwI7GARwAr41X3gz3A288PLDPXAJ12iqOX6e BPClvPfKD5zKb//pJAIloPfysobxO4xq4cOC9y05HRl7NiY782/wzP/fv/9N3v/xN8kr+gu8 7D9JFkA3E02AerF3XsiA/S0DdjAR7DEC2KPzeYgjzJ+j5b0nYWChguHPYS/hZ7DwV+9JAvyb LPDwo9+Sd5vuJaf/tudJDBznbjjelfS4u601U+PNVwhbGI5agDl/0XAvJ7h1P9LKPRlUANxZ r70Y7GCmikH+35ovuPHcfV+yAPZywH1I4FKu4RRL/DwG8AYygK/8cK/89p+HeuNpBop+3tWo 5IGgHBZ88lJ0TlYu+aPgH//kvfOX4Jkj0F9QE6H+gZoI9nQB6ilvVYM9nnrspBTYwync31Ov PfY1/JvC30lE/vv3YXnvCgHwhaF5796F5717Hwufg/82Kp/AKgA8e3jftfTXb4IepGbicYPt hPP4VdFrg5UmSQ3leQYFhtqAuaDn/kXKMuqADtFvY4h+OxTbAB/HCreBWx1p7jhEw2Ui4roV uTFIcn6sHFMMdq75bFvQ82bZrH2ciKD+CLgv4xpMtoHPRO/dRAJ4JbhXfsBXfvsPQL0kgWCA j5uQ1XJqydmImJdvP7x59+c/it6ihw5yS3aRCHQe6lkM2IslmFJg/10l2Hmvnffc48AS4Of4 AkJS3xKSC98XX/h7YdD9lPTZR8Pi4JiOgx2mEgxvx8fuehLreTU+dd2V+NStAPSzKXn5CQD4 GAD9k5fviq6nvno9YNuDCPpvhwZ+j8HfCoY8vs8ezAl//iI197JmdLjhw4VZ/FPaPjBP+K4F YAvhZnwDYOyN6Yig99XGNKiKiIyr8NqVwY4gbr3AAb5/eZVNoWlu5YX71oh0+IyVIMtUgc9E 792MAbyhRHuv/HCv/Pa5NHVl+WWAbw143n7CPRprrsTG/evf/yp698c/AOh8IPQF46lnCVCX gj1dIsUUg71AGewJb34HeH+g//4VAPzNhz8J+fsfAPM/3t5Me/3ySsqr3C0Pk1N+3vEoksJ8 SMBq0NGnKvp7DwPnr6ei75aewIJewIRxYOPh+VoCthiYsVoxLGj7V/73IzY+SsmIff9HUQxM FLgCuJ2Z/+brXY8jeW0+8GsZyJdHrsG/OaDH/sUGVDWY1fXhBNbaLrnzwn7tkzdV1z9547Dh GViIxELpq6NgDl5ooW8cN4aBPS+xTWjhbxw3g20psWrekQVV1j3Ntll6P9V6+YNU0xmXw40m nXtqMObkA/j+vXgMQv7rANwZWt7IuAzcRTnGWAAvethWXPul6MX4VwuMySsv3O22hCbBAFzI 1ZuAcLcGs5DIM+IAq/y6e+W3z7qHgz7XXVabw/OEjtv2cUdCo3//6+/CD3/+E3T0P0lOsXcu 8dJFKyztrYv6ekphSeBUNPz769//JH//+5/kTtqr7MAnqanjTzyPGRp4P7TB3LP3AcwH4Vj8 wbbCM7McADwWNP++cJwIYiewamCOYLiRqSqs7lvCKzp8tmC4MraG9zeBf/sjPLercKLq6HUz 9EBsTl5I3jsSCpA/npyX38P79nP4mw98z0A12WtlycC6ggzj8CVny5Q9ADqvxGpsW22W3stz DoglHhBcrHEwldQ4kkZqHE5nDP7/EGMHeat+CC2dVD8A76EG/4+2P5VU38ebO7UUCkRXACea CxpA0yU4njhujSywXfvkhfncGzEmUy+E0FzaoUHz4QZ10iYyLnOuoiTDeu0WdKB0XlkHl3Mu e5PeuRUHUzWEO/4/nI+N5+N48Dqmw+fZC4OQ9d5lpZnKD6bKb5/QWy+WIAGC7eEZWv/jtgfP k9+S/P/9n38DfP+i2S4ov2RJgc5o6nJAR29cyVvHFEeQSDD98d0ffxVdic/J6u9/95n9uCM3 wBv3hediDchA08Eb/1nRw7M/TDTduHaLW3FtF7UAGbMmHKM7mBuYK5hLKch3XF5P0W1NU/i5 ihTy8DlO4N23g+8Yhpk9vxwNjX36+j2586KQhIMk5BeW+bK95/UQmmEz0K+Bmj0opR3Fwf7m 8O88gD1VZK71Fwl3VbneBqCFN8Mt9vZrnhR4ANTrnMkm9S7kknoXc0i987nU6tLXHFL3bA6p I1jds9mkLry3tmB1T74gdU6hZZHaaCczSe0TvNUS7VgGqXkUJoBj/ISBE4PHgVSCnrPrXoR9 InEKiiNVvEJfWi+/nyJocFtAuumAgSBNb5AKSabEa4eBoui8qpHuqINXcTOS265ywB0mL2se 7rPg8xyEAWgt0d5LSTOVH1CV3z6lt44b6gBOE+D9h85GZGX87//+P5JVQF6HpL3OzS36s+gl 4bNfMOtFFdClmTBK2vpb3kvPAS89Kb/oTcDtxCT0ogGKmxS9N/7EdVjWjWsxpwXXZHoTru74 enBMdQSrDVYLDMFeQzAPlZBvMt1V0WdTf+HZqioLeXiWFd09a8NkMrvBqish+yKyX97KLiR3 we7lvSeTz0QmUTl4aOBIkE4Ny3IU4RzM4NrVgc+zLiOz74uDu6pc76/x5oCMUlTreCaFeL0L OcUwL7FsCv46p0XjYV5bsDonsoqNQv14idUqtoxiq4mvR+EVgX8EYI92AD39FAp7F4Cpo1/M O7t1TzAyfoIutQb7N1EDeVXpj4ZSrx0HCgycvkZTzj2gaZBawx3+DqsTi6WwBOzv87PgbdgL g46VZio/3Cu/fY4d17yjNsC3Acgf3qO2PQj94+9/FD5IfpUVfAfhG4Tpgz74HGWDVp1bxMM9 XQJ0OainMJkwKMe8/uMvkvSGvBm161E4fOZ+cG7WKTqt6AfeOHrZDQVrIBjmpNcTrK4KyFcX AO+uBPgGk13B4+8Mnn5dBvD2spBvNNUWnNShcH57Bu18FH0w5mX+rZxCcjX7LTmWkl/QyvN6 KBzrUnhWXWWkGvpswnnYwXsawecYaZi6/R+Fu2a53kMCp5pPvxTvtDWKwrqe4KV/NrizBt48 Gso+1WEV4b4bIQ/efGBckc2qhyn6vx67C7Pwj6DH2ZYxC+vKSDJmgmxiSzW9Ab6/YI67a3nh vj/1PU3H6rv5O2E5WVUizVR+uFd++3xgHxLQH1e6x0MyEs/FZKd/tfXOM4CVJ/x+HgDre3jO Padejs/CVMdsCdjTZHLWkyWZMOjhv//H32TDjYRk+NwDAMqF4Gi1gu9uIlhjwRoJ1lACeBbu tSVwl/XgFR2XN1H09urN6PFqIa/ossodznMuBl5/ORYWfw90+IsZBeQ6gH7E4ZA4qgQM8msl SVXWg985YXVXWHkYabFP54uBu3yud5MZFgDLpRZzr6W7bI8XJJmc/zjciw21f/Dm3fekUMhX 848uMJ19LZJGzgf41pbJJ2dNX4UkYwcBUEdYBay03xiSirVktIY7/N15T3IBHeQ9PHsJS0lR mrFi4G5U+eFe+e0Tpjjqcw2nGGF6Y3fP68+e5rzN6b/hxlNMzwWgD1P03dINxvnU9utuhF2K zcnCPHaUZJS0dCFAmsLuMGWzYODnfJBgwnMLXvX0uhkCn7sGPPUh8N3NwJoK1kQC+bLgXksT uIPXXo9KM42mOssAXhnyjadVheOqTiHfc319ZETbdddDN4Zm5l3MLCBnAfKzrsenOU47eQ+u z9cCBw0A7LVA9m2saZZeRQL+Y+GuNtdb0W2tB1yErbZL7750359C6p4rAfsXAXfw4GtCIBdf Ua7BYl4o11gtvRdPy/EO8mstnYXZvF5VkgxXf5IzLimddyYWYE0ZreCOr/A+p52J+TAx7uI6 LG0jwN2Rgbs5E1St/HCv/PZpvPU+mxxhHM8bue1+6PWonFRagGvg1oEAt8YQSPwJPNgDm67H x//P//ufotcf/iLp4LGnFYP892KTZr4kCq9YDuDD3/8gvg+Tk+kqtZfXBPjeFmDNBWsmgXvF gR2t/kQXOJcuiu7r2jJwlwO8Pdd6gRs4Wk2KPfl2S5zhWqDkvH/pncS0i1lvyam0N2RPXG5+ w5VXQ2iRskF+jcBJrF5GPE/nS4O7Rrneiv7e3VCHc9wU9h4DnHUv5H55cGes+oEUWuDLGbx4 u7WP02h9dR7wbE0XfZmJTJRkbOiAaL+kAW7kcN2dXOReDri77komjkEx2bDk9REGqYsw6KpI gqrSdMjKD/fKbxUFdgcA1LrZJ59HL7ocg6WnvUEibE/zw4cGBf6663FEfEHR63d//l0itxSX CSidysjmqqPnjgXA3v751/tRO0BbH+zvDxLJV/C9KGm0ZADPwl0V2LWHOi9z0swZRdc1LUEu 6SkBu4ME8FUhkFsbJoFmUrkGVi+dYJLb+d2BkPiT4MEfSXtNTkKEudvOJ/FwnbxgQrATvfhy ZOb9x+GupyrXG7U4o7Gnwly2RpNaAGVWkvkS4U5TLzGlEnRy1x3FgA9S9POuxdwgAyauYFxK koFBAToe6pOnXMoJd8ywqRoQlQWDfrMwWF0Fz6Lyw73y26cH+0C/FrhynXMqPPrXg8+iwcmY QcE+NMh37MHQmPCct68K/vqbbkoSoZ5UKEBdsEQB5onsBiRBhnlJ/iAHQ9PTAYonwLNdD55t Z/je1gzcVYFdFdQ1BXq1Uh56q/keMJH15tovra0Ec9YaTXWCOFx7ruVct2JPnoG8ortnQ7g2 m3r63484DoDfn5JPTmS+Je1876HEuxxWJA7lBPx/DO6qvHbei6030VYxyH+K2ZQLcagj1wZY f/lwTy3OqHHfk0Rz5a2W3YunN6jjcmvhHFkr2ZHKQxdvNpZCmGS17G6M6x6hYJg2cIefsUSw zbrHcYoBPnM1hHvll2Uqv1UQ2Lc2xZoqPg9TeBlmsP+vAOAhuAI/+jwj9c0ffOldKdQTqZWG eXG5ALBU+Lnwz7/IrCNhUTBh7FR0XvUDfCdKIm1kwC5KMSzURfmF9dKlQHeWAbpjKU+8BNL2 MHH1VfQCeDO/U3pvizmuin5bBqr49zzk2y5yBU4EjL8U/+IoAH5HwityEGSabsEPoqjE23ND NQ0A/8XBXZQoWC/WGpYx1SGwsMlqwZ1st92JNHedBbvGcD/NW50TL4rBTnPaBaBTuBfnulcM 3CngQaJx28tLNKazr8LSMWCUcI6smUgkGXu61BsS6O2wNSoHm3No77knEpf9Ke+pV9Nrw/eV H+6V3z4b2Pt510Cwe91PSqIlPQb49sIgIqYyh714k5tb9AcFeqKSh/6hNMwp0H8vrv+Cr5jn ngfe/rj9zyJA6gzgms/uyYC9tQzYGwsSjAh1qZcuAt1FLcwbTa3GQFj0tpUM5JbGcO69uWaz xLiW+F4e/l3XNAHvu5MKz55/T7e1jcEZGwpxsg1dfe6En3xRQILjXpE9qa9J120PozGFVNFj vYOKwn+qAP9FwJ0NLFLQwQXDpd3hqp7PCjH1sO557eFe+8wLCm3cvVr9YDoYv2PVAw1AjBuU cKcq/j/mstNNTMfTebif+Di4U8BDENgVgFwtILZA76fDN2GGbyhAVTRTduMSvdnNZmIQebdj UFw+3ZmqDdzR4Hcu+5LfwmccgqBNJ4nmzgZUK3+2TOW3CutBALpzNQDQxvGnI+LhdRdIFS3p czwkcNWkY2HR+eQvBuYfAOIfSkAOFof2RjS+WmOsAHcsNZD2/sPbPv73n1MZpsn07vDZ7QS4 s2BvynjrLNRrMrKLFOhyaYwlHnXLuc4A53qC88WadfHPTWfa0+Bol1W1hOfYjoW8or/P11y7 xTUZoCvp8gD+LvCeoSAvOdDvGxq0ecDOxzEHMgqIb3we2Q2A74IePJYS7uXlpKay638c7lK9 XTYdEE6iq97IQ3edtkRQD5vfkaoF3AHsNQ6lEyfQ66vBZ1TbHFFEzQctsqiaN5hvFPwM5htd 5BQQS1zQ8wWQegCUq8OEULyJqZxwR8NyCSjP2Kx6iEGlDcI5mglmLkxm1sV6e88NEEQOOuy8 M7HQXVu44/Fj7v3e5DeYbcPVm1BfGNRSuFf+PPfKbxXXXKbdYtwSv2rC0TD0MINgDDekYB/k N/mrgPsh78HjTgKYxyuZMtRjRSuu1MjDPRWDp+TPIpoN02fTfK7B5K4qwC566w0ETZ2FurtE cmHrxNhLPHJ2h6k1yMM2ii6rPWAV3JhrPd9eeF5FsxIN4NwLjq8NA30e8u0WuwH4R0qkGh7s 9SdVA4dvAJVsWsxxE4+Hlh4ZGrhu2N4nsfvT3xC/OAB8+mvSKQg8+KGBM0HCsfgcgK8ovV2U KEp2aPb3/s5ozMlQZ79oCmup3q4W7md4uCMYHTaEEZPpV3GZeEqNnTaZcSXKeum9VAfP0HwH 76hClFM8QPOucSi1BPDlgDt6726gvzvvSHhPd7L229JOOE8LBuy2ws1HvX0iHo/rHqH7klae eyJxxWCqz/M03Jkn6IvV1eS5V364V34rrxxTnPGF6Y4Dg8CrHha0TdHDsy4Few/P5vD/eyNf vn+TUfgH9dTjBMM66LEM0GNe/14M9BhaX50vw5sIHnzS298L2268Farou2UZfG4HBuythKyY ZhJvXdTURai7qAB6qVIBglkyz6e5aCAvIYibghfvyv5efC8oDTXhmRvONZlhx3r1ij6bu4Bk 05+RaXjAN5nhDBPCN7gTHX52kWTaVIV4QgO4rlumXIvP2J6cT7wB8DtS84sorwYHjCijN4PO lwB3OUnGFvQ0FziB5Razr6W6BsdReNc7rx3ca53KJK7b44n1wjtpsJTbBBLFd1zbxd/ATCra cGptFw2HYOePsKycB+/bAIEa3Ap9zHr5g3RH8Ogxb706gloKdi3gjgXJXADMtmufpGIZX/QG hIEkDgI74aZXg/NeW2VjSHpxMFVLuLvtTyMWS249h0EzTvBePITBze5QrfzlByq/fazObkA3 KA0J+K6v7x0spncIPHYR7C3gGdq29mpcApYSSKBAB3vzQQnqvKf+uxLUqeUXUbi//vAnabfx ZgiM5YVc3fEdZcDelNHWRW+9hsRTryYAkwW6tQTk5syK2pQxEyVrPtsCGNEKHM9mXOsFNpIV uDktFNZtbXUK+FbzMJOmGt19221tI0amsadpkQN8kTnduLoT2OwbpTx5WmJ4WNCBaTcSM/0g wLoJAO8Vlf2a1soZ5NeDeYZlm+98LOArAu5slgyfDth+aR08KftVjwtQ1qh/MVc7uIOhbu4S GEPA+3+s6LoaQddVsC4S68wY/R3M0j/BTdmMS0G7tY+znYLjice+FGHTknZwrwFwx3NA793R LzofBv0umOUbCYNM1Oeo1w4PiyvAf0tVn4jsYr1dU7hjlgz+DaQovV+PXIdr2E0Y7O4M3KW1 ZQzYNMjKD/fKb1oEULGBeyehrtIRAF5HOr6azHAE4K9aeDoqofCvv6j0EgNgj36Dhp2LfidR pYyQSLR8QiKwG1I+gv0vMmbfk3AIMq5nPHYxK6a5jLdeU3BkVEHdhgG6FOYmTDG9Mg3Y0AbO vaei53pX4d9TwMPve8K5TwQHbQo8x4voTtyhgWtBYm4twh1A3wTeN1oIsDoIMK8mMRbwvdFb X/U8K39LbB7ZBDbtdvIL+N1B+FtNiZNWod57RevtvCTTaUVjnW93X3XwCqMec71L2nruOaCZ ZxBn3yiiN+rQbfDav5eAvXMZxkO+21osxr/PavHtBCdYQaAXXi647xO99wR+WcVrcGxE3YF6 7d3WdgD473HaFvdaa7ij574LJpFD6e9gYjwOE0VjYXnqJmQBsIXDTCRwr/wNOyq/aVOy11DR 28sRxllAa9+7uIloZPGzO3DruP6B98MK//6bBkxFmEcC2KPAIl/zFlFshIS/LoE6trjLI3+Q TbcSEgGSu7hGU7upAbvUW3cRxjoLddFLFz10UxmQGzH9hdVZcQozSCp14fiGgwfegu6mH+BL NyN1WnksXrfNb/GK2oNSOswKTOuy5lQS3cw4cOsP4Km3h9cfMVmE0d4dVQC+GPLw2SNrrrwa 4p/ymqyLfkm8Yl+RAQdCMMV6E9dmoWVZvZHLC/iKgDu7/Z7u0IRl2ECDn488wkBorZPZWnvu tQHuHvuSSdUNIRBYDDwIy6NhErB3EqyjxMTfFwOeawOyDQC+yvqQl1jfHTNutIU75r1T7x1A bb3qITbQWMBE5x2EG+kM2twoXm9PKnLXEu60WNieVOLoH5WpGOS/CQJPjQRvxpWpCmktA3f9 MnJlP0vT8E8ApY+2/4OgLm/DeWnFVtTZF/bf/hgzOLzg+aLBegDXGFztRr0hbzG9MUoJ4hKg 54smNKMWDHerHorMfoHyKDhlwxmwt2T09YZCJoyorbsyJTaqSjx1C4mHLoW5AfMcqDODUkUN e21wgWdtEPBhHM3pr9E3vffao8R2wCyi8OhHft5zizSb6ksULt3zPX7ZGo7F0UCzbywTXFUF 9xLAD/af2THwcVxA8muyIuIlSDSvSLONt8PgOv1aVm/kzwl3Ob2drYjooBjoN8t8+sV4F/9o Uu9cjvZwP/kCvNh4YrXodiYMOB+u8fTeDNQ7Csu89jLWQQJ6CnlFd8+pMCufdPSLeY+7TzFt Umu4Y6lgAHUVr9AsuCEbQJOrwdxAHJguMENPtlx6NwY3QJUH7u4H0ojVinuREHyaJng16nLc 1S3nPmvD8AoGl04FWYWe26eYfMoJam1MVxbsg/37Nlh3/SnuOFV0WV2Tgr3vln7V5p9/CGAv wMyYcID4c4mF5cNrPr4S3l6hFZFQwVCayfr9T9yjcQpWsWNVgL2BAHZRhmG99SoCQ1iom0g8 dEMJzPUkdVt0JeetJ1eKvFiiGeDb1nX8nnuTT4a8a/PrQjJuyhhy//Bmcmb5NyQrK4ysnPY9 mb7emwz3O8cnVPT3HlgquKoK8I2nuXDtl9QDibUuXOcmcL2Dfr0an7kRPPcVEblkZeTLQtqf deDWjjKA/2jvvSLhzuvtEGCAGc7HbundHOyChPnt2sIdSxW4gIxiOvVSFCyFMBjTWQB2eyYo 00bG2grGgr4z/PsuMKCD7dY9y8Z0yXJ57rQsAeju/lR33w0zeFsmNcsFbmRN+I5Vdl7PUt3K A3f828F0Yjjh1B2ItA8SHoDqMnVlpK32DGjHeWwMjg3CB/m5weTTFKy5YE1pydG+m23gWpp+ bA/ZTyQZlO6722U1SAcbLehx99tiK2v8OVlCANAU31+RzdA/4eRTXpjz16TPJjOQFGxKm7eV 5P7qSRvnULB3XmmLG5RabLjxDKAymMK06UwnBM/e0MyspMI/KNjDGAtFy0cjxRYCMC+2vCKA fRGCnQzyvRsC92Y5PHPtJWAX0xzrMDKMqK1XZSQYS0Z+MZaBnr4MzLWZ3Erg3miaGXrtrl1+ jIu/vol8eHWF/BW/jfxvUhD53xhv8r8vzpJ/R2wg/wpfRV6vr0uG9uqSDUrCZkWXVfVhtePG tV3kAdezIfx/YxiD7TD9G+5PP/i5I1h7uF8t4dq6wSrcmXKxz+Y+KOt6p7wuQu99ddRL8v3Z mHSsMAlBWpuK1t/LC3e2lrmS3g4RaQ+cjaquffoeW+DRFMiLWmjuZ17QtEUnPwimjj/zDC7S JAHW0m3KLSQV5FoIv28l5M+KkKdePOrvRhPPPnEKiqe13LWFe3UB7lgMjEa7e23oL3jVrlQX 77CsDdz47Y5B0a/K47njblaPw+lU04dB04VJg5SDO02FxC3N4HnUh+9FOcgLl5YQjL1mNOXs PaNp5+4ZgxlNPXtX7+dDV4WU0bW0h+xg/xqa1rf4DFAvfgCxiTlMRHXhGLvBgJ8E/zYQvSX9 0fsvlrKf9l+k92FY8A6wVfT9QwI70n8/0K+aNs3QtQRtsWcIY8qITjB9NlkJE6szmCt9hWsM Vg+OqS61oYGt4f+rlsfrpp83JKCNcE18jH85eNFEYlRWGBa8Hr5nOLy/PhyTnWx/haGBs/pv f4iNMDwF6aMKvH/GV0EPwlLefyj20ENLGQCdQr0E7M/yeEO4p777QOaejYyHCWOL8NxJwV6f AbsbI8PYMxkwUm9dDuq6Wq5S5eDOTxqNppqD7v4bPhv/Hmta9K8DP5L/idpD/p1wkvwr7jjY CYD7NvKvC2PJ/96eTl4+XIWO3Q4YX6NpVcyBW3+G5+87uNY9qQ7fdlFNIXuGtZKaNk1mYBbh kqHHo1I3xOWThWE5ZDXIM/XX3giFsTEMJgETNfr7J4W7umCqqLfb85t4gk85rg8pqnlU2Lyk Bdyx1ADuaHXc/LwQLuRRRcfl3zFQbyFTBlRqzQTYs5DvABcOgXGiml/MO+xPSqWZ8sAdQG08 5fxj8JKGMx1ePBQ91g+kevu+FGWwawp3kIscg6Oz4Sb7wQTZWpIGKcIdr7ElLKGbwyD5Ebc0 G4w7cct67cMop53x2dVPZr6vDpKWx7Es4nE0i7gfh1dYBXlA3KPGmZwipz0JLyyW3g6hUBwa hIPTXZPWgp+oXrhuSTMD/0YAna9wgjKdduaW4/o7T5oci0sYHvb61ejE34t+Svyd/JrM23i0 lA9kQsrvZHLKH2RCzNv84Q+yszqfToh3W3frodXMszdpsTe+GXoX8JaqlKNHbimoA1xrwWf2 BxtJr93QoB/ApsF3rYHXFXz3/OBdWAJWaMh+utr8C7fQXBZcuOWw6uYDBLSMdFBq0ii+LnB/ KKyHBe9ptOH2g/k30+Jvpb97mfLH/5BksNQP/0PSwNLxtehf7y8mFmT/eCQivNrCi7fh3H8o JUH092mCn2Ux5tA1gFFdKsf03NABxtG+Z3nvCjAbJiRf2Z4BzEusiDzNK7En1N6TSHjf5ntJ KVRnb71gkAqw11YDdiuJt26kJkVQmx7HymBvOddY0WmFFTyrWAjMDayWYoBPT3RGi7b++v5P 3x/IX7c8yd8Rx8jfzw+DHSF/P91N/vEE7H4g2bt2WTyM1am01EDnlXW4ehPsNZRoigEPE0Ev zE5aHpVXuCg8lywKzyFTH6bl0T0G3dY4VaQ88zGbl0rnt2MwFaLtOLCdfCNo71MqyVzQBu7Z VAKxXXY/B0AXwDWb1V2i2TWWlP0UrYHw+0bC+5oKk0ErCvj6EzvB4Nvj4B2ejyUFaB33w9rB HYO8uAPWZMYlzN0dyfRqrIn/bzLr8jPaVk9buOP/w3dZr3kYB8vreTBoGkrgXo2fONej3DId AWK56l6k856El9UB4O6HM2h+PObWYzVLZ1idOAfEUXMJiqVNwl13pxK3QxmkOsC++qnsQusN T2KoZzwkoKsmdS4+AdT1AUA9aaNyOB+3rU+ed76dnf1tHCFfRxaSYaGvSf/7L0n/ezmk390c MvB+DhkANvBBDhkCNvRhDhn26CX55kke+TH0FRkbWUCmJRSReem/k3HRBfltD0VFu6+780jw ZkfCdbUvh/dX4j0PDRrX2P9JyJDj0dFDT8XFDDwWHTXmRlriiuevspaEvsxcGpaX6Z/x4fXx l3++vZD7R8GNgn8W3Xz7D3Ln7T9JzO//Ji0233sE59tZRW8AqTasD8c8GO/PoAMR4ZdzPuQn FP2bPCn4m9x49Qe5kvc7uZr7O7kGrzfAbr36ndzN/0Cewt/zPvybjD8VEwn3daRSDaTmsy3h M5f02fk4Ep6rycLuy5pY/2n9jcTkVJBjSoDOQ/1pHgF4EwHivD1m7NHL9/D6njbFdp595i7X cfm3TB67nBTjJuesSOJIRloW1+KK+5MODsBzdIVzx45J6DC0wGsO/98W/gbmj81FegGjutO0 x/4+PWDVMhJXh0W7Fxb9vu438tfNYAD6UfL3EwT7MfLX7WDywf8n8n5oNbKkW78w8NRHSGrV VJFkzskBvrjEMDYGgePx/P5sbOaK6DwyMzSHAOhJK78HUXBsP4GMYy7Jfy+3916xejsGU4cE brRZcOuF6/Y4HuIXc7SCey0aTE0klnOvJ8OFXAfaXSuZzQ5suU/Ragu/rysMKBHyvBdfd3w7 eMBXWi25m4AArC7x2jWGO8DaZPqlZwLc+e9uNLUBHOtCq9UPE1ylkoymcD+YRkzmXnkC3sRP wvHXLg444YAYuHUs5tjbbnwa73o4tcDjaDpxA9kLN1chvF0Q5FiCISCalmwQDdNJnXyjefNH 0GNJ4VQEPKm2JzELu7vDPRuiyVboCkjD46E+yK8xrbMxLPhk05PJKX3DCt4OCH1Dej/II91u vCBdL6WRLheSSOdzSaTLuUTSFV67n08i3c4nku6XEknPi4mkL7z2uZxE+oH1v5xMBl1PJV/d zSTfPsomPz/PJ1PjCsnCrD/IyCe52W32RWBlPl/4zl/BYzVX0V1L5cpCgO3oIcdioo/n/012 ZH8g2zMJCcxAKyLbBdsJ5p9aSHyT3xLfpAISmFJAdsHvbhb8gzTzfvAY4VJGdodYR31+u23P Qk5mFL2KfP9PcjPvD3I+u4icynhLTqQXkFPpb8hpeEU7k1FAzmcWkAtZb8mNHEISi/5JugU+ fgrXuC+zmQd1+o40n31Y8AEI8rkLrSB/7b/tUWQ6+YOEwiTxBKD+BF6f4s8A9cfUpEAX7T15 CIabljxvJybSxIcSsDdngqdSsDtIwG4mSRBQGodwjOa0/+hgf6zZUgPAaEtfsdH00ED8HXZF QtnLBcwJ/l6bwn2wfzVBIquFDTNgtesOqzgP0MVBJ19VDYKcTlyLuVVhBY65/sfymlu/+zB/ GPnnvQPk3yFnyb/u7Cf/vneI/ONiAPl7/xLyzwNryIqhP2JtnB9VlD2wk/HiZQFPdflhwYeX hecWzgnLJTNCcsic59kFNLjaba0LUxTQUFLSWyvAV8TmJbaWuSNc4G22S+9R3bnuBe3gjq81 wRN1CYwl5tMvx4IGu1DiAdRlKsN5MLKIu/D/1YUofG1hEmhYDPi641uDLrrQYv7NWBcK99SP g3vvjaOLS5C2XoB6+w7HoJj88sE9CeCeyleC7LxyMAP36hC47YhVJs0W3wpzOZCc7wHxCPwO 3HmLQWcX/xiJSeC+Vfn/cUXlBBOAM3ynx7FM4nok7RVf2jWg78cAXpPO+SCxmcKDiCuPg42O JyT3iXhf1PtJPukKQG9/PoW0P5VI2p9MJB1OJRCQWUin04mk89lECngEezcAfHeAfg+wPheT KNz7CHAfcAUAD6+DryaTYTdSybd3M8iPz3LJpNgCMj/9A5kY8Tqv9c7QcKx6CA9/X9BHjTX0 oqlOC/dgdL8j0dFBLz6Q5aCXLovIJUvAlkJgbHlkLlkTnQsBshyyJiKHrI3KJeticohXzEsS kPSGXHnzN2m6+f5jWNJ3U5OTbQTjHeNV2789GRsVRv4HPPI/ycmsQnIcYH44JR/sNTmW+poc BzuR9pp2/kE7DX9HyF/OKSLJv/+TtNh49yFAqFvxZp8Wc+yw92eH4AfhxXVSOi7HZteHHr0s fBORjxD/nTwqNlJsDwHo1F6yBmDPfU+ews/x7/+gMSiA5VeCDNpcku6oOdgxMYCPu2DswgVj FBTs/X2wOTduujKGv+vTVzT+dybFv++9UQ/GmJ7a1p/8d4plUrAGFk56x7J/7PGu6PI+krlu Don4dRiJnPANiZs7hry5uJ/E9mhK4r7pTg6tWJUAxzQXvGtXAd6yVSYlkC8N+LoTsKfq5gEH QuMXR+SRaSHZZD6Mo5YBD7EU8pRSCROSXeifEu6qNi9haUzctryvyqqHBTUAQnVRktHSc69x NI04bYngm0P3XP+bxAOoqaIyXEnWCg/66sIkULcY8HXHt8DJwmLBzbiPgvsuEe5ePxU3Duiw rLvez0duuArw1xbubiCnOATH8DJUy7md6fk2nNwAJiMMlJ6osiUk0Q3iF6jLuyLU0UtHLzwg Rnu4b40k2Kxc9OQxQ8flQEouQkXRz7umBtF6rhybZrCXZHMMfrr4PA7r+aygsOvDfNLuYjpp A0BvczyBtDkWB6/xpO2JBAA8gj2BdBQAL8K9K3ruAtx7Idwv8XDvSwGfRAYC2AeBDb6WQoZd SyJf3Ughw++kke/uZZIxka/JAoD85PDXubV8HmJz53UAjerqvGh24ws8jL8OOhEbszWNkHnP c8i8kCwIiL0gC8KyycLn2WQp/G4F6KcrAe6rwdZFgkXnkC0J+eTi678EuPt1V7WTEsCEpXV3 zbySFPeg8J8A9XfkQPIbsi/pNbwC2JNfU7ijHWUAf1IA/Cnw4i9lvyMxhX+/o6uxvpvbiCUy wFNs7TLz1G36+x6eLYUaSBNGHAqNxhrsjynAfwcjjPEgvy9armjvyT0wfE1484HMPB8dD8/V Mq7exHaCDCpuUBLTHd1VSDFmsh5q89l6XKv5uqIBrHU+Mref7TVR0kioy+raNBg6NNB7SfdB yRk7t5CHY78jvlXNyZMR/cnxbq1JkKMlSQnwJM/nTSCrjRTE09aiECZEXOn6UHmmw7LaXINJ bFkEdte6HOBF791J0WUVPg/HFkXmvVsQ/pIsAMjPfZ6LqZGHuDYL7cpId9YI8BW7eanfFuwp eNxxY+j72qewWJigt2sBd4/9qcR+7eN8uIB7uLaLe0kGinR7Mlusx5HJOXcV3lsC+Lrjm8Lx LQC4x3403FFz7+X1izBxNISl1FeGk848cJXT28uCO/6MMYaNIYkwYFbQh6P1gg7w8C0ynX89 1GVPYp47HJcrvM8lCKAeKMovHwN3MB8w70jiDJ/ncfwFsfcJxR1zS7h2SyxV6H2aBiCV08/a LjaFeznKZPaFu41PJqV2f/aWtLuaRVoC0FseiSOtjsST1sfAAOwI93YC3DuC944efKczAPez CSDNJFITvXeEe28J4NF7Hwg2AAA/5Foy+fp6CvkaAD8M7BuA/MjH2WRSTAFZ8eIP0u90fDzd Aj44YAAG2tTtZsQHDc5h1ujraYkbU96ROQD0OaEvyDwwBPxC+P9FAPhlDOBXIeDBg98McD8H sgqFO+i8kvondNs8wLcOTnzTLifF3QaN/kjWe7I7MZ/sAdublA+Az6eAP8gA/kiqAPk03lCu uZZLyKVM8grTGotLZDSYXAWchulDT0RgMHAGV3+SE9domht67ZH5RW9RegE1jNwXXot/BqA/ kMAdoX4v5z25C4ayTNz7D/yO7c4rRzBxMXHnaS1JQoB9mWDXLuCteSBVph0mQH1Tr6aDw7xa t8lJ3rKc3P1xEPG00CNbqlmR5+C5H29TnyzRU5BLg7uSnKPbyNHmtckaK0OywsqkcIG9Qw5c 471YChgm0R5YD54pYmYjA3gHWcAP8pvcxPtexELQ3ic8y3m3IDKPz8Qb7P+zpAl+ubz3iisW hnAf5L/AfMblRGf/KFLn3Avw2rWA+7lsWr8dQWi75F4u9WLrT2rGRNpFsDsxO9mqyCyFHIX3 sICvB3BvAp4peO63yu25C6mQhN6AHp4/Urmo7ngs9D/bEjsvAdw9ygF33LxktuB6COjtY8Fb 6QJLM3+rVQ9i3FGC2ZtCvXXXYNFbj60YuPsi3CPoK16PGuey3wkNkLtomG9btrfeba016sf2 Xo/COj95XdDpbh5peTqFNDsUR5odjCEtDsWSFgj3o3HFgG8NcEfvXYS7CPiuZ0skGtTfe10o MQS86L0j4NEQ7kOvJ5OvAPBDwb66kUy+uZVCvgPI/xICnlIKIdMiX7+s5fMIvPjAOfCAVlHR jIXXrEHW+OlmRrJXSiGF+2zw3Cngw5QBv1wA/Ar04MF73xj/ilx49RdpgnDv79NHWrUQdODG ANodM6+mxKM2vz/jHdkJUN+RkAevr8jupFcU8BTyAuAPIeAF0B8RPXmA+528DyQw8lUmBuzA QXCnz0ObhdWplov3tvfGvnQndZ9NXzVfd/1xdMHvAPIiAreF3AO78xIsFw1+B0C/m8vbHZB7 7gDY7+SUGO5S9XqQmg7jZRPXZEZnRo4Rn1cxjbcakxWjKdgrckeuXDtMW7hGaxY1aZ2RsGYO Od+/M1lvpkM8bYxJYF1XkrBiGtldywE8dWOywVKfPJsyikSvnke8TDmy2cGCzHKtno2yCldv giM4eR3gvg7GewtKQ6NSJYN5LrE72UsA33JeTSzQ1vNUfL5wj05PvJeGk3MArAocZAoEauW9 V2QwFQsObbCafT0TC2DVA1gXSzKawv3UC+IKerv1gptpMGjWM167nG5nW1yzucRshb85MB58 DSrp1J/YCGbKTXZrH2diQLWGltky4iYm5x0J73htfNVXdDA3nNIC0xcd/CJzUJLRFu64ecll d2IB3NADKBvhZ1mvfhDjdiSDNutGqFMLipOAvQLgTr33cOLkF00zbqoGx6QA6BZosaFCZT4x BK8h4BW0vprP0/CuzwpJm+vZpOnRRNL0AII9ljQFsDc/HEdagLU8ylsrAfBtT8SD9w5e/EkB 7iDPdDkDOjxYl7O8RNMDrKcA996XlAGP3vsgwXsfKkAePfjhN8GDv5lMvr+dSn54+ILMiH1L Vuf+RdrsCcdelxvg+jeSNGLhKwa2nFcFq4GOu5+dti65kMwCqCPcqcHP80NRnuEhvyisxINf DoBfH5dHzucLcO/n3Y8tU6vouhrTK32m3khLuFXwT7IPwL4NPP1gAPs2sB2JPOB3ge1J5CG/ X/DkDwLoDzGe/LG0AnL31R9k3q30BBjn84pT7/r7jOgQdD8Us2JAe0dHB4vb+R+MyH6BmjpC nEId7DaAXMkA6jcB5FJDuD9/+ztfo72H51hGjmnIBFBFR6yqJN3xU4NdXdP+kpLkQwLX7x71 U+ax9k3IWhOObARoe1UxJcGNa5D4zcvIFoA6/Z29GQlwtiZJK2eS84O6kjVmumRc3VYp8O99 hZx2e+zgBBNnKwr4/j69FZ1WuEkqxlZRKc/09xlVddn1MCyvjICfHfXyPQX9AN++kolQa++9 4jYvtV+CGzYCbBffeYl56vVZSUZDWQa7Ljn5RPBLkz6bJkq8drncWAtJXWYrcWOG8F5nQfOr BdpYQ9TLqvnHFGIRsPKWH3Dwi0LJaBfXbnFvmsXTZHpbHOQue5OKtIY7vsLfnfcJwdRhQccd AmNy3A9lUB0eSx4j1EX7JHD3iaAevMu2RFLzXA4/sPpubqThslluF6AhgL02nIt/9T3R8e0f vSHNTqeRRgfjSKO9saTJfgD7ATAAfDMR7oeV4c7LM4JEc4r34jHASg2997PovfNw73m+NOD7 XUZ5JokMusLDfYgU8LfwNZn8cC+DTIjMJ8sz/yDDLiYnYuEozCphxhOt148derA299yI17kr EgrIDID6rGeZxYAXJRoR8IvRgxfkmY0J4Lm/FuDed8uA4hVn89lYHnrut2cSYu68+xc58KKI bAcPfBtAGw1rgO9KBqiD7U7mAc978a+KpZr9SYInn4xwf0Mevv6TjDmfGAOO0VQxJoWbbpxW 3gFJxm82OkhwLlgg6+iD3PeFCPZbAPWbuWhFyqYC7GiPXxGy8XZyKjgi/uDcdBCy2UQ5htXZ HZidp5qUzahIsOtLYoMlJVLqTXDgU7aDjs50cs/eDFIMyjEbAe5HOzQhEV5LyRpjBf3dFtDd N1gbkuMdm5KYhRPI7LpN0uH594NJrVsx3MVaOK0XOMBqtTZNsQTj2ixywl7STOXYUvIMrBjb 0UkSd70D4IdfTMjqcyg8Gb5jniT3X2vvveI2L8GSDy9W1XXPCrE5Rv2L2sO9+tF04rAhBDcv HQMdb4CkvoqcF8Dql2alWt7xF5H33tsv7Uzz7wPiijwOaL+JyWMvD3e79c8yFAP9NnGNpmIA qbmi08qvDMadvOssFBbTDu7492TivD+N2AYlv3fel/YOS/7i52CjbNfgzwd39N49Trwg5ktu PYWBPxAkMfMy8o5lt3YLYPerCWBvfe81aXwyjTTYG0Ot0b5Y0viACPeYYu+9JePBozxD4Y4e /DF8Be8dvPhOKNEIgVbqvYMOj4CnkD9fAveSDBoe7oMB7IMEuA9DwAtw/wZev4PXEffSyZhn uWRVxgcy6m5WugInt/7e3TgeSDi27eABxESBPZ4pRa8Xxr4m055mkukAdxHwc0MhuBoOQdVI 0NpjX5LlYEuiX5LFAPfVMXnkQN6fpMHm+4/AYRnM8WPSETyzke7bnz9fmP0vMin0FVkH/94L bAPY5uhc4g2fsTU+j/gD2INTQZbJfEOOZBWQo2gZb8jRNAB7igB5mAiOpb8lT9/+Tb47Eh0B xz+OQ8B2WNZKMSQwCD11gA7uZ6gOE/fPcI4nQUcvuvWyiNwAkF9Hy5Hae3KNtWze8Pf3cgrF ZxTz2ptzynKMB6ccQMXraMGph1RFgb0sScYaW+HB/WwFUlJ1uB/DO7f94QnCHW2jvRk526kp uffLV2StuT4Pd/wbevDWRuQ2BFp7D1/8AOQXrC8jSk7SQmeW4MnbYV14uMcDYULviN2chA1P rDzDe+8Np2BW0EIFOrQw+eOGsrEP01GaCRbq65fbe/+YzkviMofX2/v7jDYee+q5k18kqX06 S1lvLwvu53i4485RB89nKFEchIuBnkCdMgYLm3lgwkmWXsK/wX/rARd6rvn8m/FY27085Qc8 MFMFoGu59F4cLN8XcUIJBHhYZlssvR3tIjTn0E6WAYijpn4gnTgfyoTXNFrTnfZS3Rb/eeHu E0Pc4Dic9iZmYosw8DrsOfmULFXpgkYgO9SCwelbY09UfOvbr0jDo8mkPkC9/p5oCveG+3jA NzmAHnwMaYLeO+ruh2Mp3NFaUbjHUbDTzJlzKaTL1XTS42Ym6X0ri/S984L0xp9vZJCeV1Oo 997jHHjwFxKVAM/LMzzgBwkaPML9q5u8946Q//aWCPg0MjH6DdmQ8yepj5k0A3yHCg8sXU4r ent1RyAG5v5ZNCviJZn0KINMB8AvCH8BIM8lCwHEU0COGXM/g4y5mkS+OhVDmu0KI47r7hOL DaHE4c57fjXaYz1q7i4Ah25GC67ctbtD8vUCM4hi1EWiGHoIYjlggw8Qxc+nif70K8R0wU3i tOkRabAthAw9HUvmXEsiKx+kk7XhuWQLrAgO5BRCsPYdOZ/zllzJfUfCCv/mpZLeXrSxOpzH DJioZwPcAyE2hB41dhtaufZ6QgpKMjdyeLBfyyltVwDi1LJ5uwyG2TjouR+NyX2JtZqEZwC9 djbtUeqIiTo7O44+FdjVSzLNZ1dVdFndCFMR6X3o4dm/SacJ9z0drYingyVZZ29BbkEA9XL/ TmSVlRHxgt+L5gng3+piSzoNW3YXwI2JHnLpndJOUJa0xV9/n57wXU1gshX7sCp77/29v6Pj A2vTDA30HnUjKctj+VWx9o+qFQ977SoE7nKVIPnNSwO3TjOdfD7OFTzOeuclersGnjuWHcDN OParHr2CwbhT8ARqUQ+kdCciaf0JNtVJjAOI3rsz13QmbnjYVXXzc7o7tRY200bDPquMqavn jnB33pnIP6Q9N6BkRGvcUL3dNzwbd4d6aAl3N4C7695U4goyjAt8FwU7QF00120awj2gBOzl gjvaFgysJpEap1+8hXM8yHVY6iwzsETAS1MGjcAbqgJg93HbFRXf6k4+qX8I4i47o0m9XWC7 wXPfw3jvIM002acM9+aHBS/+SBxpcyqJdLiURrrfe0kGhr4h38YWkSHPC153u/0iq+etrKxv IgrejE76nXwfXUiGPckn/e5kkV6Xkkmvi4nUEPK4uWmAAPiBNP89icKdGsgzCHn03r+FQOt3 oMGPhwjhorTfaSoaBslYLws8vEF1N9x95Jv9B5kbCcHYyFwyN+YlyDrpZCCAvE3gU1Jt9T1i MOUyUXx9hCgGAKCHHCSKrw4RnekPiPWlIh66CIXms7H92j7bU1kpVkfyid6Uu0Txw3GwY0Tx 4wmiGAn2Pfz87VGi+AY+66vDAH74rEHwmX3309/rzLhKqqy6S7puf0Z+ORZFpsL5rE18Q87k fUDHaD9o+f0A5nWolz4kYLNikP9awauuA1KQt/+zjBcoyVzN4e0K8yraZQHo1F4A2F+8Ixez 3tHMmR8OhsTAZ88TvPbGXEl2jFSOkersUs+zvGBXBXhdTtJCUIkJjadh+7tGMLl2Qa8dmDX/ +wYdE1YDvFcC3FdUtSD3Rgwg+5vXIcvtTMka+P1awdaBLbU0JNM6DUiCf7cYzv8HsK9g3LeW wN2CU5aKaa9WeF8DmHTbYpcrgHxdJbh3WtEUV4bYJAV7srotvfyo/fYnscCWceDZW8k4WRpJ MxWzeanV/Oo0mDrvepbHnqTSkowGcK+JejtIAxazrsbDTLeQK13yVq6euTR1rVR6Jj8z+oyF h+uUS3BcEfZUrX00gwZU8WfRMHumFnjvtYthn8rboRS+1R4EUx18o2HiCdgFgSlMacOb2gpu ymHnnfFvaeEvreGeSL12TIXEwKrrtoQy4U5fcUcq9luFz8XJim5owt/7AeDhGuJ11Npz34yb m2BVcyaHGIw9dh0GYSNO9Q5C0fjr3mq+BVyHtY4+TyNb3n5N6h1JJrV3RJM6O2JIXYA7Wv3d 0Yw8A4aeO9oBHvA0ewbg3uZ0Euly9yUZEF5I+oW8eV09KCTCcvb52zA57wev0xfMB34+YDHz 7C3n9XcfD7ifk/1L8u/k27A3pC9485ge2Ru8+D6XxN2rokSTBN57EtXgEfAo03wNYB9OPfg0 MinyDRn9KDcLHIsNEED1YB4+Z1ip/dB227PQbRAY/eFJNumwP5LUXXuPmEwHmI8AGA86yHvd 3xyloOYA0NyP8PrjKWK8IpxUuVCQD8e8EzTZVgCGBRaBkRFVrhNiMPsx0YH3cOK/0cAU38NE MPwI/30DAPYDAfo/niamW2JI2ydF6Bhth1VXJ4B7ffAaaRVCAMZY6lm3mtcG/r7jQFzeqxsv 39NNT2iX0LLRAOI5Iszfk4vZPNCpvSiE10LyKI+uQk5y7ZYM5JSDqNLsGBs1ckxFgJ3TRpIB 77g7TGy4ivHCNNA2bUc++bpBp4QljtZkKdgSBytqDyf+SNY52ZAlAPrl8Hu0FQh/wRYC4Bf1 GZ40oPPokHZtfnyiwM5sQwKWgqTSjeGTuQzg8W+2tC5Nt7XNwFrBeKhFx1iT6W5wbHTHNt/F LvjkT/fScuGzveEeusk8g/oVDXfVnZe6r2uL3kiVNY8KEJr1tIX7uWzaxLoawMbgp6P3FV3X fMWVLnmryhNgQSOFuz14oFhjYrvJgkevLDyjiO3WRGLrl0Rs4NXGN6HYrMFsfeBnwez8E0jV wETiEJRIHIOTSDUAr+061Nu3buLECpXtlwyB8z7qsjO+UNTbtYK7oLkXd2JSBXfMlsF0SPx3 uJLAWjJHMt65H0kvpHY08z1q9a7geaMXXy5ZBuHuH0t1d9N5Vx4C0HrJ6KXsSqmkINXQwDl2 6x+GNb9XAGCHCRE89to7QJ7bGUnqwM91BQ9eBDzKM2iN0XvfL4D9WAJpdzmT9HhaQPqHv3vn HhyGjSSOghc9C+7hNzCBDIIVWC+u6YyetDhV+6XDsWY4wN7fZuHle72vpqeOii8ig+5lk16o wZ9PKgZ830u8Fz/oagngqUyDcAf79nYamZ34jvQ5m4iZJnM5dlNc05m14XfL213PSml8JJOY TbkGQD/OyyjopY84Jg9ihPsogO76WGJ9LBMbnnsCALCq4+mq9/8sMvGMhfedBrAf1Rjsct9B vfzvTxLd5dHE7PLbHFp4rtFU9KgbgFMzi266QU8eVsJwLUcjOB7mk6LrEES9XAx1HuwX0F6U 2HmA+jlqIP9kFlJZJrTgAw/3ehNbMl57TZkVtpVEjlHZI1TxcbXzy4K7KYzl1vC5Rwa4NUv8 uWbDrOnOjm/nOdoStPnUbMiCqlZkAbyGe60ks62NyQIHa7II/p83a2qL4eeF8L4VTnbkZI92 ZAnAfpaL8+vRdVrwvZVbzK3KldTKYfuzWnAlyR52IDlXpXV9uqxuhuykDugA31/1xx27DauK jjBZrOxzIgo7QJ1Q9NncmlMdWFUrzZR385JyMLXPpoH6Px15VG3zc1L7ZCZ47jlawb0OaO7u IEs4bnpOuOE7L0BAopUkOOOgRr/TVwd3eKiwct9pw4XPiNk6WBlsiicWmxN4w58ZM/eKI+Yb GNuIr7Hw72KI8fJwfmndfd1YEe4QRJ6Jn+0mdF7yKEcqpFKbPTm4I9R38YXF3I5mvHfaFZ+r 4Ks6HqfwQxsWdNLePzINwYylCRDSWssyCPetsQQmCmKz4UkU1rLhSlfsk+6uNAGP41vLVfdC EOz1IdZSa2ccqRUcSWptj6SAR7iLgC+GO7Vo6sGjPNP8CID92gvSJ/wdyDmx8Zg1hKUiYBz0 5kp321K2xtO6KzouHwEP196+j/Kyv4soID3Ac+91PqE4ewZfqQbPePBDmCDrt3fTyfy030k7 TIns7zNO0FPdKLDaLmqOpSXsLhfk66yIAO/8JAWqJuBFr9zUM4ZUvfs7Zlhh4/b9Dg8+vLbY nkV0x10HsOPnHNcY5PT9oo04yn/HqFNEb8INYrEnm1Q5/zIdxvtG3NMBAfEmAIntuLLk6k9E CDeEc5vfb1dI3A2QVi6/BM391e/kVt7v5Bro7uipnxctiwc72tnMd+QMgB3tBnj1ng9SMU3Z CzcFqvDapU1l1AUCNS1nUR64F29cosFNkBq/q90ifaZjFcLaLEc7MhtsloMtmQOvd6aNJVOt TeBnGzBbavMYw4lgJmjz62u7kR2tGpIJjtVet2g3+jGsDAYIjfOlcBcBX+y9C45qVawZhatE GL+NFQN8RtJg/gDfn0H2bY/PuPuyK4+EvREWZcQtZL33itm81M/7O8Pfjofg5qVaoJ3Xv6wl 3OHfoN5c1TOE5ntzjac3k9Hb5ZZ5quBOjw0u+Fe6v556qj/38XuTNZEA9DhitSWBWIq2OV7J LDbFEYuNEgO4m66KJIYLn7yku2brjheb/baFG7HBbsPTVPd9APU9nwDu+Ls9IAkdySCO2+Ny 6OQy2D8IJpXZsMQeSJuYYCOSTitGg64abLXqXgSW+HXelsiXF9BKc4+gKyf3gxmkindoHEBi Cle6ch/bjNgUAIzppbsbXM7Nb3DuBam1O47UBLDXDIoohjv13uG17o4o0N55wCPcG+zhX5se RrBnkz6RRcTV7yn28wzi2iwcWibUldsq0nr9rpvuPxkR+Zbf5IRwFzY4UQ1e8N5FwA+mHjyv w3//MIvMSCRvEYQgRw0QYFWdBiU7Lu+oP/nUDdvrv8MYeEp0ftDcs9YBDV1/6i1ivj2T2J7O z696748C27NvicHMBwDmkzywNQE6rA7oCuEHkHB+PEt0f7tM9KbdIfrznxDDRSHEeFU0sT3/ ltidyU4F8K5DuQS81VnGUy+GwX3cwGGaYv1JTfFvxvPupFp6g1x2Op3MDM0nh1ILyRFMcXzz O7kDQdar4MWfBbgj1E8D0FkLL/ideCw4fx88zm9UaO1yQVSVcoyi4rpfqQumUr0dxmo3TDXs 27B7/AQn58KpjvZkGmNT7G2JZ/1a5Ow3g8kkW0sinQT4iaCKMBHwk8Hort/FKDCFcaDfBJln RS6TjwV8yeYmPsCLTY62wOdtA02+NjYFabMnNB6eh6lckxm25ZFmPn7zUqOpuI12vvm0i4lu wVgJMhfgroUsA147lgZGzdhy/s0UGICrMSddWOq5laHhKWu/bO2Ivpu7483Un34713j5c+qZ W3onaA13c/D2UTfVm3A+RNFjvdg4pB2tMjnYP9B8TViOY1ACLUtQY18yqb63guBOJZhU4n4s k1iuvIdlWgOFxiWl2ghy2Dy88bQ+MMgCHIJiMtwgdoBlBbSGOwRVXWEycdmXmImbPDj5DjnU FJ1XYveezS47ohIawEqt5q44UiMoEiwCAB+h5L3z8kwUL8+g9w5gr78rijQ6FE/agsfe9VlB QdXNj5+Dl7IWPXEJwDvImDLgcYLr772m07nkpG+fvyHdLySTnucSeO39QkmZAhHwCPeBggeP cB8d8pKMiShAvXobyD8tOKbSKFzzocZLbz6wOfMWgp93KGi1kU2odz36HNGdcJMYr4yAz7gl gF3d54heOkwQI88QnTFXCa48TX2SiOWOTGJ95BWxu0pIlZsfqNldKSIOj//md0732TQNlv3N YLx4m866FoOQp9p4h6V9ABi7LVc8y8cxbbA2miiWRhLOKwZiUBBQvp1N1se+IYfAi39Q8IHc Ak0eJZmTAPUTYFSeySjAFcheCAp31NJrL3cT93LAXV9GPqasgnvZFluAAhcOD63TJn1iNUcy sZoDmQQ2tqod2dSqGQnq3IGMA9BPqQbAd6xKpsoYTgYtW3wbAtxbBCBuymTyqXSEZOUZ5doz jnDPsPz1MRr0HeQ3qVEgBFWxiTZWsCxH1kx5gqmSzUtLsdxmsO3iu688AGz1L70E0xzuOBnU OZUF2nIsdl4KhYjybxgM4uT7h1pwpQv6lwqmwgTxNdzAA/qTbqQbLw4DuSWWWPokUrBrBXeQ aUxXgtc+7wFuN94HD02nYri3XjAAB7rB4rDXpmuiifXGWFJ1axwNblYXIO+xpzxwTygGu9OO 2BzjOVee0rZlTWf04lQ3Ascc5m4A3N9QroEJ4R2WFHDyjdFClgkn1UCaoTXhDyRl0x2NdUp1 yuFTvepNtML6F3Ybn0Q2vJlPasHKpXpgFFhECeDRe98GgN8hAF6QaHjtPYo0AK291ZVs0vHe q3y79Q9CYDUyn2swuasE6O25ktaKoom/K4F8vYmYQnZwdGzhm0FP8khXrD8DcO91PpEaQr63 UElywCXee6eQv5xIht5IJb9BMHXEg5wsOKdNnFjpE63u+HqwKp1iERQVZbU3l+j8dkmQUrTT xfHf6GDQ9HveC1frsSP04X06oMfrjrtBTMApsT76itjf+YNUvVP0yuZgUqyFT0iI6eq7D0xX 3XlgAma29v4ji8CIcFPPB49ANhwNem4fXAEbT7mANZD44nsdlmGjkQPWa8LeWAHQLWC8mkM8 wHR1NNFZHE4Us0OIrlckabgngYy6nEEWx78mZ18Tci+fUK0dc+JHnorCZIelTFkQTb32coFd C8CXBXc2NdoFnLQBKIH85uz6foxTNTIWbHSVKmRP/35kcd065DdHBzIewD/eyZFMUDIH+vqz e83XOFGqCCLLwZ0FvNR7L97cBNf2Gwz2QsyxCTinfavMvfCQwr7b2lpc6WYmcpOmxnDnOE0q QfLVzU5V2xBSVAPkg/qXNYN7ffhdffz5XC5NBzRf8gQG9f5bsAzuw+TMupQBd+XiTt3XuWEN EN1fz4ToTruTZ7w4lGrmVr6JxNJXS7jDz6jRGy17TnTHnHkMF3gcA5y2EPiYiOdtvDKqCN9n BoA3XR1FLNZD0HZTLKkWnEA8RMBrCvftItjTiJ3XswS6UaT7uvFlyBIlgG80tQ/M+IHVdiZk Y00aZ79ywx2712/mSjcuxsFrDR5QYzj3A/WvviyodTSDeAREEg+/CFI9AOCOgA8Mp3CnHvz2 EsDXAWmmzg6A+x7Q2S+9IF3Cioid5wME0EyJpy4CXbNeuY2mYh76qdEJpKjP7SxaqqDb2XjS A6SZngLge50v8d77FxsP94nx70iv0wnxILNhlpbYBKYe13BKEwC+j83p3BdmvsnggZ/VHu4S L16lxi5KMCNBQ0eowxi0PV9IHJ7+453t4dR4o3mXbkN8Yzd45ksV3T2ngHf3Kzx7P4P9pOi2 5heYHGfA8a+FOEVnGJu/GE0+/1Rv1MHrAPpeVKbp4YkVRk/arI8ostrIw90C4G4OMQGztVHE bFUEMVr0nChmPSOKOU+JsWc4aQhjpP+FdLIy8TVJIH+QXsGPwuH7J3PKZUFUZbN9tNeu0L6v rZx8LO57sReOk25qxPTQvvU6po12cXv/s7MLGQFwPzVuPJngUZ38Us2J/Aq/+9XZmfxGzYk3 JyeCk0G3xr1RLsHYhvT8bSQZZiZMjFJMyRS999LyTJMZzuiUYvs+XpoJCjb+9dBVYECdzwH3 0pUg+2waZADBVMy4qHMagH1FPdzrCz/XAJ3d6WAWsduVQYOXuuNv8Hp7q/kdVcDdRiY1z5j2 HWy32AYu9gjUf/XGXog2mP2IGC8Jo3q5lQ8AHbx2bT138/XRxGRlONGfcTsZlnK+8KB3Y6ED Ht0y/Vl34k0A6rjM5Q0ekrWR8KCArYkiVl5RxBHkJg9Mk9xVBtx3lHjsoOPHg2dwCIJ5X2so T3QSAQ/yhKedz/MknCCc/WI/wnOncGcbGPNF2lrMwVrUKx2DwuPpxrPtccR963Pi7h9BPMBq IOADwou9dwR8bfDga6NEsz2C1N0FQdRTaaRL6DtS1Rs09n5bVkqgLgK9NVfSL5ftmcv2ycX3 tYMVCwajTo2IfV/U/Woq6XIqnnQFwHenu1h5wBd775f47BmaQXMxkQy7k0EmJxbx9YK6rxsh gItW+4TVUguUOqpcLyoyBGkOZZIydfJygl8HPHadn84Sg7lPifWhl8Txyd/vrHbFYcbQCUXf Lau4dkt+4JrOHABA6Src607CdRMnwdYwyeH1aw7P5BSTGVcidL7ddQHOoS313Nsu7oUBVqtV z/KsVcDdDM7RFCRMdIr05j4hiukPAfSPiOnSp6TtoSRiP//iQ7hG3wnXR5rwYKcmQ+ajwa7Q vH+AvsrMuZKCgjXgPAbRAOaw4BPfutd++429A9k9YiQZ7epBRjq7kVEu7mQ0NbdiG1y7ZbaC r9q4BeDbSWZyk2eU8iZLdfJMVUzFFVbN9ljN02bOuQfAmi6ccn9ZI01094/ZvGRLq6IN3DrF dPLZWOwAJOrtItwxa0Y0BHrN06CtHwWg784gNjvSiS2Y9bZ0ClHdMRdR89wFnshACKi141rO bQJeSC2uyXRXeHXmms9xBLBU4VrPtwXvvip4J65w0k2wFCt6kXjR9afffW284BnNbjEHWFOY I9S1hDsOeNPVERCsepqPDz3cyO8E+PAPUt0J7TBjwGDewzRTCdzN10UScwjemq2OhM/A13Dq zTsG8h2Xqu9W0UMVG3YAkKtQsAcdhmvwlYwn247xWlmZQgR9Z1jOLbXd8DQOUyNpqz1fzbNl qOaOO3EPJIqeuxsDeAdhMu9uMufSg3rXXpHqexKJ69Zw4u4L5h9O4V5dhDsD+FoI+GBed29w LJm0ffiauO6IjMOAtKCxi+fHNkDHdL5mXOl+uU25kj65+D5swjK/0b7ImK/CCqgk0wnhfjqe L1EA1uOcRJ7BIOuFJFqa4LsnOWR09HsMph7CipxcST3yRnDfextMPXPD7vJ7oo9B0LIklXKB HaAOGrzuhBvEFMZflRugoWPWC67aBm71hrGPgfNugvTWRVipdVIaj/xEV3zN4LmYZzr3ZixN WRTh3nJuF6y0arnqWW5ZcDddEkpMFj8jxosgYDvvEdGb/ZAYLg/lN/Dxacr1mZiYk5qEB/2K 8to/Au6WzIZGJ+GYa9KVWbNZbXCHecsWX0UPdXAiu378hfzoXot871KdjHCtQX5wrU7t6+oN Xzdv9W04OFz7YAU0GjOROOUCaZrA3ViNPFMMeLh3Q3GXKoU7NuLGaz7Atx9Xunm4odzkWRFw 54Op2M0bIrw2C29lY2YH6u0NwHNvAIBvcIn32GuBd+cKQHfYlwlAz6BmuxONh7tNcCoxWQHS x9jrROeXcynciAN3uW92X8H0M1iGroUBuQheFwFsFsJ3oS2gQYZv91zhfjh4W3fs5UT9afff Gsx7QicJS4CzpW8SsdqaXAx2TeFuSdMhQYeEwY5yjLAleKbEq2wLens/OJ6dhktCX5mtUwF3 wczXRBBTeHBM4disNkSTagBcj10I+aQSuO/ipRgH/0jc+n9QAvZ2Em+2NeO5tmZkCjy+jnC8 s61W3gt3P5JFm3o4+2kaUAXP3SeKuB3IIPZ+4Qm42UbQU12KAY/t/iCa77I/Ib3G8UwAeyRx 8Q4nbgh3hDx67wD36v4C3AMF7x1eaweFk7r7EkiLG3mk7rHEVLoZDHPXS64rC6imDGQbSqyR kKlR3CcXxsf2AU/y8/o/zuM7OAHcO5/mAY9wp5A/V+LB98eywNdTSXf4e7MLL4jdmTy+GFxJ n17aqxeu5a+m6x8/sznxmqYuYn67xqmLmko1oK/rTbxFLHa+QAmGWO2Kj4Hz2QWrkZ8FmHeR QL2jZIUjNo4XJ8MmKJ2YzLwaDtd4G9yzVhzfI6AHXierNSEvrRDsuEItC+4LnxDjBY+JyYIn xHL183c0RbXTin4ykoy6QGpFg90czEACeB1OubBhaUdU3K3Oj2kKd4Dm8iatRkQOrt7g7be1 GpA1A78l33jUIcPdapNv3OuQr6rXL2zfdEA8xtsAuku5xtM7aLhxS9UOeuMy5Bl7OKYR8Iz5 Yy0aGH+tqeM6JGCWBnDXKQ/cVVeCbDrTDZfDDp6gtx9MJQ2vAtivQoAUoI4519UOvSC2uwHq OzMZqEvgDma5NQnADJ4yDCjD2Q+I4fR7RH/yjVd64y9n6I25mKw39nKKYMl64y6l6E26kW0w 8xF4FU/oEtIUJBCaDUOhDuYnvGoJdwygmq0FnX3pc6I/5WoMXOhNEs+Sz2/vuuZHHOjGqyLf aQJ3M1gFmMH5ma7gIW+3OZo4b4unUo0HeuwQgHXel4Ky1BFYufwqeYBZeUJ8iEVjZQpeoujl NcNqRTngDrIM/h3z3G03PouG4M40YfAWd70CCeUby+W3n9W+kEdz8BHsLj7PiUsx3HnAF8Nd 9N5Bg6+1LZo0OpdF2jwqeEdz9DsuH8GcowiopszDU58r6ZfLWl3hbw0p5JvNao+7V4eEFbzu fj2DdMQiYydL4N4N5JmuZ3nDMsEDQWPvdTmZ1PZ+TIxm3iL6fmnELDguAc53uWRiaQL3f6nV nuREi+2ZRPenC+XX21WBfcQJojfhJrHcnU2q3iP5FlvDsAGzF6xQBwowZ4HeQdMVDnijk01m X4sAmPsD3FsKAdWBmGdvvSHijdUm7eBuuugpsVz7/A1uVOQ6LO2hgSTzKb12BzBjFXDX1RTu ij6bx9Zp/1vIkBoNSX/X2mRsx35kTPu+ZKhHfYQ6add0QBJdPfXzXsG1X/IVp9xCULnHseoi aUZym/7UyDNVQFbF+7Sb1qFpv8SdFhAbEjBNxaShVnf/uEqQ3da21R2x76bT5jBaG6bm2Rzi fPQFqbo/iwc6mN1u3pTBXgJ3ajt5yNtsS4PgZxKx2AIe9MZYGtBEr9dkeTgxAU/aBAceDkKU XWBgUiijhx4A5p/MA501beAOkwMNoC4NI3qTr8XCBd0DD1l/OR1Y0XPDeL2JF0NM1rJgLwPu qwQDuONKxWwVQj6W1nPBHadmi249pxkjymAXoScnT7AyhQj61gDgxbZez+KwbDCFu7Y7VI9n Eau1D8IBEOO4ku5X7jDJ1QCIBrkfy8h1Rz0f/q3zlufwygPeFQDv5icA3u85SDTPiyFfMwgk mcPJpNXDt/xqqO/mRcI5ipBqznjq9QWA1xa+vwabd86V9MiljdAVPdbjRHtiaHjh+05nk0iH E3GkI3rup+Io4LtQyCeQXiDF9ACoNwgOI9azrhHF18eI4ufLNBPFZOXdx6DB/sJ6vxSSQwJ2 2J5/88oUxgaWEqgwSYYGT4/DOLtNLA/mEvsb73LMvB49VfTaMAuW/N1UAL2tCqgXrzREOQnG 0Rjj6ZdD4fgDRbhD0PU7wwmnH9hsjiFWm+O0g/vCp8R82eNsWEVvxRIGGuxBKQWdipJj1Mgz msLdDcYyNtU+2KN+h/wBtZqSHm51ycJBP5CRzTqSNo36pjp2n3sPJvs14IB8x4xTsdMUn9/f eHoDkMukE5y1TOBTrkSKiUzuO1+BtM8mbNh9EO5hO2zhB8fpC8/d6oqGu6pKkJZMJcifjH47 8dxmdQipujeTVNkHevqeTN52K5tauFPApxGb7YJRjx5eg9KIdWAqgDuFWAOs0WwA5NaBYPjq z5tVAOOtlwfum3AnKu5CfQ4P3NU4mvbYct4A2QBf3QkAUO9FBjNvxpki3D21hDtAHc0UJivj FfD3zQnEbOk9rMG9hQnatmEeYPbBbchkczRgZIoSiWKA7yoMqLpjrntArGaauwh3CMBWP5lN TEFTV3T3/EqAKIUrTBpYKvZ0jbN5RajlO21+TuGOco4LvLoA5N3Qe/eTgfuuWNLkCqzojien 0WvbaGpXGbA3FDx18Ts9BIC4MuYm/K6GAJi6cN1WtT6bkjIgtID2XG1/PJa0P4ElguMA7HGk G8oxl5JJ072RxHLmFVoSQPHtMSqx6M+8R3BTEZ4X13x2N6WJtMmMdqjD211599ZouRhMPVYx wVMAO2rsVhA4tb/xNtdsA4C9+7oJMlBnx15LmYleOi6oYZkB46kXn2IdGQAZD/funhh0Pm2z JVZLuIPcCdq7+bInCHdfAe5yWTKfQ5LRFu6ymjtc6z648u5dr927vnVbka7ujclvA8e+rNtt 6jO6SbDTiu+5BpM7M5OqdJzWBQj/wDWcXJ1T3ZBEdS0mNfIMOD5daaC37+YeIM+6wBgMRO9d DdxVBlU/pvOSA3gG63RGn8owWRJCbHcB2PdmkSoI+b3lgPsOAezbREsFuAsGurxNQEqx8WBP KjYr//LD3WIDv0IwXhYGUsw11Nf2S7TgNkqySPPZXRSD/H0NFz5+8VFwR5lmbQwxWvk8hwKv xZx+Ml6C1JutI8BPtDoCEBsIDzruQtxQNSA6DbNuNM6WkRQO0x9z7DosCbsVe9D1J9WGQb/B eV9Sptu+VFIN5Jhqm8IA7M8p5Hm48947lWcwewbMAyBfPSASNPY00upBATGde+k+aMk/qHpg BGArSUEc07WGkzZBbzKjEYxBv253X+Z2v5VNa8C3OxZHOpyMozJMl7PxpOm+SGIx7xbNG6dF vkaCBz4Ki3WdISZwX+wuvcPa5EfgYW7HatdwnMOwLovt+YJ3upPu8MW9PtZzF0oS6E2+Qyz3 5pCqtwpzaWGv7usmMkFSqRzXQiIXiUBvwEhX9YTrV5dqybDqMpl1jdfcG0+jXZIA+GPBmw+x 1Rbu85+ALPOEWKx4Inju81urqfnEZsl8cq9dQ7iz2TI0FRLAPAKzZHo07PS+Z4NORbXqUwnm qKLn+nHgeHRmkhbaSCTDxvSat1nYCrzpbVyT6TVUBFOl8NXnSvdzlQZXqTwDq4XqdHU7cOso WsUS9PdPDffSlSDrTqiGGpzuz+ffYPqf3b4X1HP/JHAP+hRwR409lmr9RotCQeO/xnvsrRcM UfOANQfo9YeH/hj8O6q3W5QT7vhAmXjFw4Ry6amQy86CXRxIDcqQKIo9WPpejP7DA0jz3PeA jr81Riu4O0OAt+aFlzQrgms5t72oeYMMNRw9nRrnc985wWqg2sbnBOsIOQmGHrwIeD64ysPd 3SeM1ACtvcm1POKyMyqeZsfUn9hBBdhrMhqmUoYOU35X7I9LAQ8P42DcbTjweWFhx4vppO2x WNrMo/2pRNIcoF5l+V2QXs4SxQ+nqceu85Ngo06CnSPmGKPZn5oCx+UJx9VWCe69N06knu6J /CLdXy9VgN4uSDETbxCsLVP1dlE+n35ZvOu4g0RPb8FM8I0Z77yeZKKvJbHasMoabzL7Og93 zOxoOrM11pyxWPk0w2ZLHDg1WsId4lpmSx+kKAb6rQbgNJDR29VuXPrMcJfWwCq9iWng1tn1 2/0U36b5oDwhG2WFovOq4Vy9iWyyQiuZ+9AA+ICVNQP1hvidg+taXSLJqCqPwpoq752XZ9ot cdX5fvcFeI4nUthjZchPBHfVlSA7rcDGvgd1x1x6a+mTQKqAzl5lX+aXD3dvHu5UhoHBbLgw BB64y9G0ponq7I1m4nIY4gwjdMecfmC8OoqUG+6rQXeHB8tw8eNk+N5tKsBeX3iAa5YhUVQv lig6reiLQTO3Q6lvXCBQ66TpJibsowqAd92dQqqfyMTdd3txoqCDGUvHDvBdYO8XHo96fDXv SOLoFUYc0XMHsFfbxADemw+uuvkC2NFAmql9OIU0v19A2wiCxzNADdjdmcwDB66kfRnbAL0q 04DFFY5rSr3dkdH9Qt6QjueSqSzTdF8UcVz1kOj8fB6gfgpezxDup7MA9TPFcEfPHbNfrPaA BOX56Bno9uOlWScAgDXWB9JSLHa/ILo/n/t4SQY9fzgmc99k4vD0nziBnqEae+ngeQvJqq0B E1iWTvIeEuPr4fTzHmc653oETaltMLkJXPcucE/3WHtFvLbxFpIHtIH7UoD74ruYQbVYOAbp rlQ5vf2TSzJlwF3KLDthXDnDRLekYbvRybRiZu+Nv9Jr3XxOR7hWrZn9FNIVU0NF1zWDAOzB tTuNi6Z1njqvbF6GJKOvqrGNytz39ktddL7fcxHUgbEC3LeogbvajJnyb17qt+UrPEH9KTfe 22zPAM+9xGv/IuHunUjBjlk1CF1D8NYNZtzN0v311CN4GFaC3NJHxnNSyp7ASnhw3jP1p12L MlnNSzJaw311OM3IMdkQT3R/O3mH44M2cmAXtWf3MiQKN+Ghrg0eNi43TwOEi7AMguYlf8Pp z7QT0+6EDGwkDh5aKwqXdktwa//u6iez8hH+jl7PiePGMGrovTtuRLjzoKdwpxYGcAcDr73B xWwIGkfHw3VbAg9Pe065mXJdSblYadsya8bY3XzVQPutpxgc4NXuelZm74cvaW1453WPiMGE S0TxPcguAHPdX85S05HCffRpoj/7AbE5WQBj4PxtrsOyYdKJHHPCbc/m5Zh4xQmleY9/HNhH nyOGyyOIw72/iEVQFFafXA+eYhcVgeXGDNRFoFdnJnk3YYJ3YcxV+JuHou+WX0GWCeOG7ziH u2zhHnZD6QmCqYXW5YC7+Ur43fxbUfCcTBMcCTG/nU3/k9XbPyXY1aRDlm7UwejuAOjNVfos faDo4TmIXuMWc9pxLeZ2ECpdNi2VwNB2UVfFAJ+5qIU36jA6tWOL/kVUTuuzqZfMBktNOpep 9t4B7roj9lzAlG+6G3xo4DrcnFmRcC+7EuQgv3k6Px5PMJx1H0CNQP9C4Q5Lb0ufJL6cAIDY eOlzYjjv6Xu9iVewKA/WcRgj1IxpJ3nIpJkIjUFjw85LPoaLeL3dolxwjwRvkXrtKTTtre74 dsJ3NpOAvbpkE5GjColCTO+qAQ/1OEvMcT+cQTcwaVU4DAKvHkcyic3GJ1Gg2c6C4+Jzpnus /8Fs0Y3HNc/lEuegeN5r38jac15/FwGPHjz87AqSTPW9CaTJnTf85pfOK79jJrBGTEVBD+Yc 2To2lhITAW9P63D08uqNzkXPyKIi7EJlOOkKUYw6AwYg/+V8MdhLwX00eO2jzxJDCGjbnM5/ g40/QILqqQT3VvO6Yd677YU3r7ASJPfjR+xMFTYp6c99SmzPvyNWuzGP3X+HUCtIVYylHrNq k8YgxEm+GmNKkz1MpL+ZzL72nPt6+zmYUBsLcD8GwdRywP0xMQeHROhA9p1wTOry2/U/J9wZ wOvIpG6zGTPFujvcW2+A9SThXOrCir0tSCytmP0TvLWY217R33sO7rmp2XVyXJs2X79v13oo QRPknO9VSDLSTBa5fsPymTPtlzjroiwzJHCRAPfV8PMyptLkJ4G7JJgauFFn1KksXLJhdkyV L8lzh58xdx7lF+qpe/IpjgbzAeqTr2OX+1M0h73VvEGC1imVYZrIbqIBHRoDMcarIt+brosp H9whiGq6Pp4HHu+1t5JpMsyC3VFp+3+JRCEWHOK3VDeeVhcm3BUgn6RgZyfUxjWG+xY+DbL6 qWxiMvfKA5CefqCwaTgZs2+W2QdFJ2F1ymrwXtZzF+FOvfiNGGAN4+WZzaHE1S+S1DmZQaof S8mE49oMx9dRZgLzkDQatpW0KjNjKlGKDyjVTuG4xtn4PY/CfRTcuFsQKAVwg3yi++v5suH+ yyViCmPD+mB6OkgNG7nG0zspSTJd13yHkobN2YJCgxn3+drp5fXaRxwnuuNBAjrwkthfe0MD qDCOBqgAewNJYNldEoNwlMQhqkqaLlPAA5DGmM69EaEzYu8l+K5WtIwCaO6Wq5+l2/h+BNx7 rP+GKQviqAbuuv8BuJfmVoPJxhBzMFPqq9xhaT1sSA3aeSPhXGrTHfHNZ7cszj5rNqs1rKzm ocTp3mNWVNOOo/Nbt/uOoLVp+y21Gt2mxcI1nayBJCNtKK9WmoH4W02Dnw9eAb7OF+C+BmIn sysa7qo3L7VZiPWGg3R/OvMKPWI7mgaZqR3cd6UDzNP5Xavi/2MK5HYmJTI4tcQC0VKo8amQ SUIqZBKf444mAB6hboY7TcFLxk1OBnMevdWfejMdm1pg5x6u3eLh4Jl2UpFP3kQm7ZC3Dst6 6ow8fIPX28sHd2zeYLjoUTIN4vEyBbsxQtzSLG2+ayuRKdiaFFSDhomiDconrgdT8l13JQOs YzSHO/zsHBxPap3PpQ8xnOcQDo+r1TyQZIIOVT+fW4CNvB03hxMR5qI5bCj5mXrvAtzdt8WR +lfzeCj03jiN46+v9DxdOX5yqsrx5yg+JGYcP+BNOGbgc/y5V4FVAMZ7DlidKSgwgoC47q8X Adg82EvD/SyRwl1v7BViFphOzL1Dw4VjY+9/M6zNYr4lLNzy8CuiP+FG+eFOuzGdI7gfwuHh X/yEzqc8yuVON+D46yLGWPDasJM73mtxgrcVTJzsxdokFPAApt8A7uEGY47fVnRZ1YdDvbif 91yzRXdisOtYOeDOH3sv6rnLZcrg/frswVRFGXAH2aUqQFwcUzh27OA5wdhUU67uBDfhOtfk Gk1tAPJVI3hve1j9Toaxddyl1/zIpp1/e9Oy42jSsuMo0rID2kjSCq39SFK36yTcZb2MU64E acLJw11Vp6hS3jusujoqsAPTAN+BeG3h+fOE75kpfL4Z8x1aw72szUt4gezhgYAlcdAR/fFX CtFDttuTpR3cdwHQg1OIyfIwKlOYe0WDdBJHSwZYB6YR66A06q1bB4D5Y547vqbw5ieVYJKJ BQZIvfgqjhToMDhBeiH6U25m6Y2/iAX1j2AeuSSXWKp1NuVKshLqc8pZCXyKWe+Nv+hNuBhS briviQKvPU54yD3HcsoyhVR/VtVV3VL4f9GL5YNE3T17Gk4+c7f6iSziEpxAy/1qLstEEuwB 63o0HXvE7uBazkOZogU8BEONppy5XfN8HkgycQBwFXDfEEp/pvIMTZEMoxUx61zM4et/t13c j1OWY8S6JKo2gIgDWKpJ8nAfuHWMyebQKMtDr0Azv0d0Ad4IddHUwn0kSCRT79DNQ8ZLbjwA L30kJ9XbYbVitTc50Twgjej8drF8mTI07fEE0Z8OsuWZt8R6XyKWy10n5E9LwV6fK5nwxPtf jZOf3K0YsxZ+b8sxKzkA1PfGMy+HGE05/wiklG8o3Ptunmm64FaUzdbywD2CmMy5Fgaf8YsA d7U7U0EyM4HJxISB+38iHVKuprt4ncRVDh+v6ri8IxzvRGDaYec+iyMbdp38pmmXcaRZl7Gk Wecx8ArW+TfBfiXNwar2Xf4U7udQrnQ9GanerqMV3Pt7d4Dj2KnostoDJh1bYJcfOKTDKwru qjYvWXBiMHWA7y86Iw6FG818QD1qqSSjCdyxcYbuuKsQVLzyTm/s5VyD6feKDOc+IkagcRot DgFtPJRKKabLw/lt+ytg0OHgwx2eKyOpdm4Mf0czXPCUGMx9QuAz3uhNuJqq+8vpEJ3Rxx7A RdkKXtgigNQoTnmDCOrcrbnSWmcDTjkzoTi9DH+Hud4G8x5m0EqQntrCPZLPa18eivnC/sKm GfHhlna0kSv+byYOAAZ0fLuuuhOcYXD+ZLn8Tpj74fRivV0zuGPZgRjidjCd2AdGJsGAXc3V n4jXpyU8zHPsNj+N9jj+gr6f19tVwF3Q4p3QIKha83gGcTucnKEYCMFZHpxNOGU5hj1Pa+Gc pGCXwt0GJmis1HjU6tTrAtONMIbGXCa6P5/XGO66I08Ro0UhxPr0Gz6/vcOyoUpwbzi5JQaU bY5nZ5jABM5hmd9y6O06WMP9t0vEzDeFT3vELl6tFwzm+JWiFOxi8FwqxbGNUiyEe8+aBQN5 O9F7hzH/ldG0i0/MltzD4mxzOT7TY7gCdfet8YVW3lrAfR4EVFeEYUA1ErzKCZz61pc83Ptt wZ4KljCWsAYMlgpwVHw+3V2Xk+/GZCl1iHB1BGMcWzQGO/RZEVm/54w3TXpOJU16oE3hrTva ZLBJ1Jp2n0gc+y0Pg2D+QtxByoxdM051iiJrarNm4H71RKBTr73LKncA/TYAfkcZx+ej4C63 jZfX27GJ8A9HE0wAwqidS712tXDflUllGASh3oRrfJ2RQf7BcIPOcN/vv63z4+HHOqNOhOn+ ejZB59dz8XrjrqTpT7qZV2yTb77Sm3wzW3fsxUTdsZfidX8+HaYz8thDbsSBm3CTDqCWDssx rHf9MwRJestAXVUtExHqtbiSdDPR6JZ3lCiMlj9/i5DWFu64osCmyAazb0djFUNOWaaozWle +N9U4olUBV21Bnjcmxy2xb7wOJgKcI/RHO7eEXQyqH7iBbFa8yAcvK7p1LNsMBk7TQW7H0vL ddufQaqBLs8DXQXcKeDRgw8lzvCZtfl8ecwomC5ZnYhyDBtAtZTxSqReDb7HFsuhmgXGJFge ekkMZz8EeJ/nTRO4gySDP5sAzKwPZwqxgGK9vRk9zraLesJ37LQ9m//KaHEY3XSkNdxpF6WT 4KiEEPtbH4j51uco/8xmxl5ZYBe9dSsGHOwYEMeBGTMWSuIRPTwxgHrAakNELm7ywjEGDs4g BcYRfOPf0qwxrVIhQ4j5qqfp8Jx6ci3mNORKN+cwlZNlAPL6MAYMFXyxr/8k3E1LOUTtl2C2 1Sqn4d7PWv24+WWdnjNJgz7zSCNqc0qs96xiq9l3QZbtwPWPYNzMBq+6Gqc+mKoK7rpq4T4k YBLcp1V4XQWJ5iSsvup+CriX3rzUdKYrXJR1sLzNMAOQ8cFU7eBuvT2DmIDHDTppMsxKXvCZ AyFiPRyi+iMUXVePU/RcPwM80VXYgYjCenDAzmIbErALG1LAv1sNf18B750KM9wvtPZ5y7kD QTuTa9MmVxpV9NbrcyUbhWpwyiln7pyYP9x+aVvUwoxXRLyntW20gTtWhoQHCOScN7TqI69p S4HHlk9l9Wc5T9acY7dVd1jaCAeBRUBKUVX/eOLsH11cMEwTWQZlHAim8lX/Oq/6kV6rxtOw xsXpmhdfFjnvTCbVqN6uAdzBg8fvr3XhJRZCO4SbvhivvZZEdrKTOU8jGbhTzRRWAT8br7of YnP2LW1ZB6s+GEMXAOgXNIY79h81B5nPIigmDsbPIk45O6op9XDhPlufffseJR+dH7WsBCk0 5aDlBQ7nkSpX8rNhvAYIJRfY4HkDRopxk5Hi2IndWIVJJSve+eqyujWMs53Wm6PzFVjsC7+r 3ZJe2KQbf2ftk6CVLGMKTpylZzj2EA6C56CFpnD/XJq7CrhLM/2KHSKY/HCHaYDDoPXRzb7x JC2+9yJ1+y8m9QcsA1tCGlBbDLaINOi/qKjWgGW5doO9nsG13APOymDa2Fp5ZfWxcBeP0Qy+ wwc4N4HCfbD/T1TC7bbWoyLhrnrzUre1ELgL2q3326XX2HDaTkaSUQt3+Nk6OI0YgQQjaM/o 2SGQuwmGD0EXrt6EriA3dKG5wFhzhTVsx1ZvQmf4eyeudHeiDlzpgkty5WRFb53NI3bnSnKI RaOBF/C2sZPNaeOVkUX4QGgNd9rVKTSHSjLKMoUc8KzVPNhKniyVyfpu+Vp/xpUnpr7JxBjj GEuekipefJVHFwb0snDfGkUwAOtyMDmXbuRqMbcvXjMIPA03mnb2Tg0IsjoFxgtwf64e7utD SDUAvOvuJFLjzAtan19IqWzEKQdRVfXFlauiR70u8HzbwOSzz/bUqzdmW9OIwdRbAPJzAtg1 gTtIMhhMnXiDoNdvtvGZGExVqqyI2/RNvZ6EWh3KA0Bf59MgtfTadX46B/JbBKl6708+vtLD czxXuqqgKrBbq1jJGHLKBaiMZMBFvVLw0pthwoPN5qhX6K1DYBzLVHfDHavWmyLzbLYm0tLY mhYOQ+/dyiuGX4n18OxdBtz1vkC4l+jureY7Y710p2GbEuoM8yR1hq4jdYttDak7ZA2pN2Q1 2CpSY8jal/ScsQl2n83f0/4SpfdjVBzc2y+tAt+3B5yBYTzcAybDd2+FidlBsnozVqPty8Jd 1eYlE0Zvt4eZayAOWMNpt4qsApOV6sloCncMgupPvYWD5SQE775iwC6tXd2JK7tZsghyaUML MVgqVyO8PiPBiFAXsxOkhr93hwu+zGD23WQTCIpqC3csSWyyLpYYLnyM3ek3CMfSsBzAY+Fe LMtg9xYTz4gss43xxGThM2I07zE1syUgCwDkq/lGU6nGmWbQMHD3jqS/czuYQRyDo/ht+GIb wV4bplitvh+GhcRwUqi2OaxsuG8IoTtWUb93P5qeLUxkH++1t1noCA+kl3lwXLLFrhcE0xP1 xwDQfwOI/6Yh3Ecj3E8TffDGbc68QTnwGKwSfxAkGX58wEQE3vxcy22xMWZ+qUTn5wvaSTK4 ixWDqNPuE6sTr4nd+VdZWENdGIstGKdCVfBcTr8VvTO2PomBBFxKkz04QC7wvRssPcMyFViE qtvaIQD4ztiJyXpTVJ61T6JWVSHRETNfG0EMJ529Dyvlvl8y3IFPZjDuaqqCO/xtXJWv/cJr f+NNan+zhdQejrYZbBO1OmBuX2/Otv3KNwyeK38YD2NkGPEp4G4CzkY9cGB2wwRakzo0QwKm 0TTIhlMsGbgblxfuZW9e6u8zivvuYBgu1zB1sYqWnjv+bLEhGjyo629pQEu+y4y0n6Zco2S2 K5G0NZvcDlMxYMpKMOwNc+JKcokdOeXNIW4Al+2Gi5+9QnmlnHAX0sm8xmsJPEOZyHqJp9Z2 cS30Lsz8UopQSzZZ9JQupbGaHw/5R/CwPiO26wDKPlHEJSAKgA5QF+EeHE8rQdJj67NpgXid QfZaXjUgPMH9SCZo6JE0E0YTz90RtHms5Q//FmQP74VqtHbNvPamM23gIVtq4vk03PrEG2K0 JIzoQSBebwwAnAJeC7j/fI4Ygo5ueyIXVynB4Il1VdLbsRLkIL+NNsdfpBtDjITuTNUG7iOO wgRyjpaWqHrnAzFZfe8RgPUXRmdvVEbwXFVgTrrDUV9FwNBWgI4TxsXMVzxKoJ5nvy1TQCvv iJlQ1luiX1n7agj3RQLcZwPcscfq9IuPFL29hpWCe/PZljSn/AtIhQQHpQqMl24ymrvoJKxz +S44q+aIIELt+0BSa0QANbfvAnJtvgkMgeu0BcbueDinOoxU++nhPtj/K0XJblQLONblKjJl 1H2PVnA3KwYJNnAd5D+fG3EkEYOEdntfyIJdJdwxmAqG9cx1fruQBRrqVoC7FOpSSUXaJLk1 p9yRSNpnU66CnlRX95DcKHb3p2glG0PaLGyCSzOjpSH5tDmHtnDHcgNrYzA74yho0H21BJ4q uPMyWX8fWnLA1DupCMsImyx8SsFeYo+J4ZxHxGDWQ9p0wXrVM1J1Uzho8ZHEBeQat11JxO14 Jr9Ts+3ir4vhDhKN65G0XNf9qbS3KnrkZXvuobAiiCI1zuaK+e3jmICxqtrXqr32+hPRe5ll svZRmPXJ18R4VRRIJVcJ5rXr/aYl3H8CSQazV7YkEev9dPPSJqkkA/e5O9bVsb1U+Npw8VPt Sg7AJKAYcYzoT7pFrI/nE9tT2WngPe+QyDFstpBc8FxVxoWujOQghZeYDcLDve/mb9Brt9rw PBPu5Sau/qTmuJKy3hiZbQsrbuxfoCncjSFwbQbPLEwW8XDd5oAn6aoE9xZzrbgm0000hLsV GHiowbqKz1NfpkTa67OpNe6PcB+99231n/aSGqP2kOpgbiN35dl8twPr32N23Ug4n6ZMppxq uLdf6gFOUHcts2VUw31o0BoFdpnDY+3lVZ+mRPb37qBGby833EtvXuqwrD4uVUC/fGm5MVZ7 uINhMNUQpAOdUSdi4EIulOSdt+PKbpAsAry50oPJPzws0Bswueos1N0YT13c7cfu/ixVpAoe FAyyHTdeGf6+fHCPIcZrovkAI1+/QnzI3Tn1DYYNmWW4kUxaqj1upTbxis4xBU/MZFEobYkm hbvRfF6mMZyDXthD6tmbLX5CbNeGEZe9qcR5fzIG/QKZjV3tsPSxx+ms1y57UgDsGsId9HaU eWqd5ytLgtf6rSSv3UmynFebIYMBJeOV90NtzhQQE0+62uNhPuYSeO4XNIf7aLQzmJ1Fux5Z BGCtG+9FUskOtOrBeNw25wpBvrmr3eYl2oDjBDFcFkbs7/xBjJdcvw/B6RESOUbV5i1VedKq 4KAnkWaUxgT97PZLm6NDYuMT+4rWdW84BVNbZ5stvhdltz2Vr7O0AeC+TgNZZs5DGFshxGpT 9Cta6rbNwvrqUiFVwB1TIs2EV+dPDHd9Wbj329INpWD3sUeK3MccIR6/HS6yG7kP98EchGsz Gs6rOadcYbOmOrjDKqYtXI+1WsBd1eRsrOi+rhrAPBic52+FlEgsArgZguMuZcBd2qxDLdxV BVPtQQvC7fen9MZdKbKCpV2V/VrCfXcGbb5hMBubDR98CAf+M6eqbroyuFl4N5EBeSOZzUds BT2p/MLmEbMbRGw45d2f/KaQgVtn6k+/GWeCsBbArhXc4QEyWvosC26cN7M0L8trZ8EuuwQH zRh3au439U4soNIPPIAmC1XDHc0YZBrUUA2w6fG8p8R8ayoxXf0kFgb3kuJVU93xtHVd9TMv 3rjuTiW0PMEWvgJkNfD6qf6+id+05LDhOQW7w/pQYr3sMXh3z4n1vmw+ntJhWa8yVihmMtlA xlyjqeZCpsAp6+OvCkyxNPKkGwDyixTs2sP9DJVlMPvF+uhLXm/vtna0kiSDcO/hOcpk9f3H lvtyaFaNVpuX6HvPENTqq94pek03bzWZ0Vkix9QsQ4ZTlwFRVjYIC3e+bvmQQD+rLdG5MEbw fL+BoGovvK82fglvbLBEhxdIMzBuy9bceYcA8+P1Rh+8wnVc3pTTvr0eV5FAV6iuLaMr2SRU HJMAYA6xHHngmdvE06TamONZNM1wsP9Srt3iFgLAa2oM95ZzQaoFGA8N8obrWkWDVZd6uA/c imw9CmOQZsYAK76D+8fuTFWXKaMW7ppVguy5oZvimz33DMCrsd2WwZf51QrumbQ0gMG0O2LN 8L5c6frVUkmlISdXCkC5SQG76YitoMcWXJKWkmV3/FkyOz+tJZsdnGAArDKYez/NVGu4Yy0Z Ib99+vUIWKlMFc5FupFH7iE3kNFX2WCqHQyIsYbz70aZeScRE/AYUZLRBO4U8Pi6NJSYB6Yh 7E4IPU15uDeb1QNXGW6nXhQ4BSUSB6wn4xVGqq4Hr9QzlNivCyG2K58RK4C56byHoMXexQA5 0Z98k04YFruL4d5Txbmq3rTUar41DOrpJqsehFofeVmA+rXB5BtEb2wJ2MsDd10w3Oxmezof SxrvE3bhlhSIqzehKW7Rt9gWG2sRnA7/5px2cEe9HSYgm9MFxHJbTBTc6zkwSbaU7GVQt3nL uAywaw/3/t7j8DmzWPU4AcCGkzcvzWwGaSYohXrv5utj6M7psuCODoGlVywxmnrhAXis/VWU HzDiPl3vVG0Lh5UKOMPz8o3lz0dCbceciIPxvQvu0RAxG46Be00ZuIup0Xwv4Y7LG8MY2mIz 6kA43UHaba27mliJZnAfEjgBJmF/YKIt13ZRFfj8JRrq7RrBXX0PwnoTHEHf/VXx3YEIvOG2 uwHs+zM1h/su3nM3x2Dq+Mt5VI9sOrObZJeoqu3/tSUXvKZkoxGbm+7KKZfIdVQBdUsVO/4s lTY7tJ5fGy78VsOFT3Jp/fb1CHXNPXfalAPgrvvL8duw7B8oCaQ6qck6YOFuWEpvbzTNETRC T5O14Zmm60GSWQhe+wIN4Y4PK7zicZkFpKCXeUBJGms1vz/C3XJnxltT0LmN5jwA3fU+MZx2 j+hOAZBPuUPNYCq8Tr0Lr7dhwr5FDKbcgs99Qix2ZomyzDAV8pO1xHOnpui2BsuxzjFZ+/g5 lWIA7PqTb1GwU7iP/Qi4/wSBTgiS2p58mU9TNKVZVI2ntwZvabPNsRdZZpsTAdintIP798do g3d7Pv3xFADgKxWbt+TkGBaMcg9rWV3+2U06VQS4u0B8pxUei5VPzEvaT7XpjA6KHuvH4u9s d6QWYV0m2okMx2lZcEfdfVUkvD88A66fD6e+cJjefwjuqtMg6020holtmuWYE5gF40Xry5SU ICiuhS/DFyVHEeJIfQHCe21/ORbjNPH8a/gZJ4lmKjKc5AqHlYI7jHt7BDsc3w/Ua++zqSHV 37uvc1NRkqPC4M4HU1vM8cDdgTojT70wXRHKZ8nsy9IO7jsy+GDqz2eSFAN81nANJrVhwN6Q k29KwG4ocmPMVQJyacaLA1NsyZap0WIhs9QxZfKFLZU2hPTG0rJBR42Xh7+j9ds3aAd3Uwp3 vp4MBJ1ayMgUcg+IocRrL+WhQcClCxzXQZBk3mI5BpMFIdp57hD3MPNJhlhASDx4eKuUAtmt 5vVDuJtvz3hrsiKSGMy8RwzBO0e4G0wXfhbMYBrabd4A8ggB88B0YroxHDsvLVSTx690H+AY cP+Ep+mGkCjr46+JyYY4KsXoIcjHXiZ64y6Vz3P/+SwFtR7ILGb+KcTmUOYL8Ih8S8G9xZwO GPC2PV9YaLg4hFZz1DhTRmifZ7opAVYGEEgduNULJJkOWmRFGanRTzkZXVlP5aRfp6TjEIIJ nKgt5mueJAhFy7COTiuMp1htjszE+k20FHZZcMfxAvcV4zk4IeiOOnAFVmUNOQ37p3Kft4eq nkyqqDlIL04YrIRzX8c1nubMZsJxJU1v2B3prOPoDpNBKyxzbjrq0AP7SecznGddJ84zrxXC MRyGcd5VEjPRBO7FSRIA9UFCJl0tGmvq79MOPPcVZUgyaoOpcnBXXQmy3eK6uNTWHXv5vaVX TKnOS5rAHQuCGS18DB7REex+M1ZSEa8uE52WSipso4pqEpOWQa0io6WztTlMZXVeVbv9Bvj+ ojf5SgR6feWDezSBQCxfkKvxtOYqMkesVCzr5FLeRElmnOGCe9GmmNu+NIzmt2sMd/DETJaF E7OgDIDj8RuwDBymFNBuNa8vC3fDWQD0GQjzsuAO3jt48qYb4kGaycRA3k6QJlR57vw9wYyY wf4/wtjabx6ckGp15BV42FFEfyKCHTz2cZcF+wi4Y9/S8TeJxZ4XfBZP381zSsmA7Zf2NZh6 5gbKKnpwDnymzHGNm3Hojr1CrI+9JubeIaHwkE7Qci+DoYoHlStHcSw7rqRblQdAqSuVZtY8 RWlmGbYTVHRd85PR9IsP7XalE4yd4bgtG+4PaNYMNpOn13CA708qzkV2klL8ZzoxFadBwj1p As/gAhjrHpxyLwRXpZ3oymVHqnPNZ9cHR3QipkJbTz4f57zwHnFacJeaM5jFmBMhAP2hEumE dc70ZMBeDHeIO9rQyo9DA+fQlNIWc2CFEfALPN99mHpSUq9dVdXJUnAvqxIkn5XReWVzxde7 rulPvk6s/JLVeu2ycMfNSxDEMYQlPvf9gftwUsMZPZLtoenGAF2apmjPWBVJloutjI5uoWb2 k6beydWgcFQM9MNgarzp6mgKdW3hboIlfufcxYqAC+HBaigjyagKpOqreICtwWuqBeDcYuIZ lW26JprPktEG7vMfAYBBa/VPzqflEBpO6aqUetp6fr9ywV0wXBVY7MvhpZn+PpMB8B6l6qbU m2iDaWTwPb5GK+6FWh3NfWOxI5PGAdBj1wcJpgTsFeC5T7xJrA8JWTw9N0xg4E6D8/C7X0zX PXxqfTCP6Iy5RhSaSjLotf9wghjANbK/UUSLkSm6rBqugddephyjRf0UpVgMUxjLHa59LYDP WgvPUGwrdwImsYF0k9pg/yDrrbE51HtH3V0DuBvBOZqufE5s/OJw52swgMhVk4yZTwl4DTNl zEEirA1yRydOuQ+CM7MLXRnwTWbUpTGLoYE7LSadC6+68P6rassfk2rL0B7xtvQRsZh4NlyU U9TsHpVrtcfDfYBPQzomB/n1pCvYbmtdMEsG4l5WMtzSWJJh4a6qEmTJ5qV+3t8pvj0QYjjz DrHBzkv7tYT7rkxiDl4mBN0K6ZboDkv7SUrdeshsErCXgFvaeo0tgSqtnKfqwkizUAxVFBiq wrVdXAelKMP5D19QvR3Bvl5buMcCWC48UfRcP1ImS6YsSUY2aAaeZ2+9yecfoKxisiIClsvP tID7Q3hoQZLxTQaN+O5z8GhmSDKW2kBQpzfeI4B7AX6+4awHAPd7msEdvHdDeDUFvdzqUG6B 0dJ7oRiQhkHbCZfyil4b2oNXMlqBXd1hJWi5PSnT6vgrYgo6N36P3oSrRB9grj/+sjzcEeS/ XdQK7iAl0vxzm+N52Mv1JABusGQ/RBN4yJZY7UxIMA9IBY3+vOZ6O8J91BliBCs7u4t5WfCQ +oB+30bNXgZRkjJhPF2NgpAaVj4s3sgkQKsGOFJ9DSacukO99/4+K8DJaA/3fZbp4rsR2CQH G2aXCXdwynCSN4YxhBVdTRffwQbcy2E16sBITMaqdPdPBXhN4Q5j2h6bTzOJEsXNTZTg3mZR U1pqZGjQXvOpF5/br3yS77gmjBTb6lDeVoVQs5x+GTtrjZGUCzGS8d5Lw73VfFP4nrlg68Br txDkyda4kmX4pU6S0QruaipB+i/ifjiajDeb5rdr6bmjmQH8dH49hw/AFpiZ2ko2dbgyuedy wU8LFWVPzVRcCFVA15fZzi0Hd3vQKNtidT2jZWEFtH67lnCnXrUnvzNVyBypo6LZgbnGkgw8 THD9phkueRiHKYImS0SvXUO4z4VAKnjj5oEZfEZL6wWDuJIWg8UbxHBTk/m29DdYbsFw5n3N 4Y425SYxBE8PgY011818o5P0J525pfvzoSv6U8/ehoBpuOX+rDyrw3lFZv5pxHh5BB+cHX+V ghzBXgruEFBFaOuhDj/xGtHDujIawf0MAPg00Yfjtj31mm/U3XpBr1JwHxK42+5CQT5q/VpV gkS4g55vsTubWO9PRnguLafXrqMF3HU0zZih463V/JZYHdIGPHWd7/dcAK+0C8CuHwZW7fZk FOGK2hzTIcuC+0y45xB/wffZbEt9R1P3+m7prUZ3/5TeuymmV2oM99I9EKqxJUZgtdUB7t14 utt72qVQu3VheQ6bY4jDpiji4IUWWWIbIojD+gj6ajXnRizAeLxMaq+hCt4Uwx3ieY60Mcdg /8H032EK8JDAGVhjRgXPypJkyoR76UqQKE8MDdqjM/rsazNYltntyy7VM1Ut3Pdk0FZ6xsvC 8IGIxZQzWC5KKyJKOw9Zq5BVpGYsA3NVQJfqX2ofEAym6v568oHxSj4FsjxwB70dszN2A1A6 SPR2VRkTaiUZ0FBrYwEtky0JBTRYWwx2DeA+F8sSPCVmMCmYesdiYNEPgrzdmOJq4o5fDLrt Mg9KzaedoxDuM+9qBXdMX8R/Z7zsOUFv2HJXFrE88JJgDrkFrPxMtyQSI4AIfp7+pOvUW6cQ H3+lNNyFbBn9WfdBN8+lkwYGWXV/O6ehLHOGGMJ32Z4toDnupYKpTWe0xYqYdpffvzNcHArA PqmZ3i5UgNTDVcHpAj5LpvfGCRrsQNbaa1fXcUhNUNVZGG+14LhGm8y7/sx49tUnih6ev4IU 1wkb2Fh5R2XYbk8jFl6xxGx52Z674fQ71EHAtEjrLVHpMGmsAh3btazqkFrA3QjMToP34UYo i3LCXexa5QQryg4QP8A0xMPm829F2W+JKai6NYFU9U0g9mg+8fDKW1X4uap3XIltiSXms66F w3P0o4pNeerhPti/Iy3vy3eLMoHJpQ38brgE7Jp47WXCXWUlSFr7eFjwcZ1fL7yz2BhL7A+8 UBtMLQ130NsDQQaY8xAehqMYcBoj49k4Mg+AlZoUIKmx1fLkYK4ns5lAVdqUmaSOzki9CRfD TCHAZ74hVmu4m6yJIQYLHibB4FlJu9Cr7hwvp7fLZ8n09x5mMOPKU4SjCTyIJZKMJp77E5oP b7Y1hRguuB0GOvNkCdjF3cCtcHu+2ZbYdLPNScR4ziPtPHcMrALciw1+h7EWlIOM5j8hRjMe EAPQwPVRgkGYTxBgDj+Xgjtq72Ou0InCcv9LUuXm79RL5qtCntXIc0eZxRhWIFUuvntHPfe6 E1oqbV7iy/yetD3z5j2CWuNgKnrtI08Sw/nPiN2Vd7gD+YCQ7tpAw8B5Ka+9gjoOKevuKHu2 WYQb03ZZ+0RnUWcDVmqwMh1nMufa0yr4fILUYrYS4L6sDLhPw6wpAPzCx8QmKEUMUHfTdEWi AeCx/ruNBnDXA6sCMDQrY2s/mwVXDHeQqpoBlGfhLl7zpfei7QKT3lbZlkpEsw9GSyH2Qclg 8Ar8sg9gzB8C0QtvR8M13Qz3vIaEWUowhuffWabwG+jtvnXBmtN7B7IMeu0wFqvJgF1rSUYV 3Et7sH029aeZMhOvvceKjmXp7VK4i8FUvcm33tNlSPd136rJ/VV5kSQmNyPqyaQf6agxuU7p QurnXHeIWq8xmHM/HT1wC63hDpIMSDn6U66GCTVWNNXbDVRKMs1nV8PNFyYbInNMMLddSZLR AO7zn9Jcb1P/lAIa92i/9CsG7GxZhxbwwM41XvU4GmufG8O/08pzR7ij904N4I6e+YRrxWZA X6/yBhKL/sQrFPKl4I5gB8nDcOYDYrnzBbG9+O693eVCYg4/G4AHSUv+agT3cwTLM9gcf/kS 7mmwsLmoJJjad/N0hJTV0Zfwb7Voq4fvG3Ua6/STKlcK8oSMqJYqSi6UlSGjkWerRcchZWkG m830WP89pvWazL32FLz3MVzTmT0AjttsAuJfYttLlGbKhPuMu0Jc5S6xgPFutSkce4kuhcnD SWZV8mmlGWwGMsDXUCu4N5+NRdUm4nNkseZJvG1w8muc3Ci39jC2Gy2DVNklWjqpsoM3u6Dk AtMFt8IxHgdyax0VezeK2QXXpytc5yYiu4AH9vD/3bmGk41hvNDxAMfUFawP3BNzLcGuFu5l V4KEGQ4Gcjx6b9bb0rSHOwZTIWij+9slfAC2c20WdtZwx566qLOujMkBnNNgM0jp1UrH5Q0w qGK4JOQNH0wtH9z1xp99BA/Sd8JkpkpvN5GZxEott2HF015v7Mk7Zj5JxAQCYCZLnmkOd1hK Y7NwlDSM14QmwqpkJXiwbSRgbyZYcwg+DdQbe+KGxY4s0MTDqdZKYa413HmJhkovglHYU6hf k4c76u4AdtTgcULCejBWh7NfAphO0bS+nVn0ODSG+yiA++Z4Yn3kRTbEjraWgvsgvw1WRzLT zXdkALS1aKv3w1Gi+9N5YgYToN2FV1ji2I+RZNh7XaWMfHCNKyhqsBtTTppxp6vGBpMbwYps DZWPhtCiZm0xoG665M5ze5BZsbcqFggzUSvLCPd78k2aUosN64UMpBYqsmY0iidUQDC1TFmG 9gQYGrTVdPHt57bbkvPLYlgppu1IKTBbdi8CxuEhTEWGicJDph1iabh3XmkGDrJdMdzRYx8a tB48fiv6vmazzGAM9oLj81AhN1co3JXSqrA4lc6oU9nYTxG1c/sDWsB9D8I9nW7m0fn5bAac hJckJbAs/VlPAw9cHcip4WCQGRD42fgd+F14QXEQ4E2yBy2ujc6owzex448ZAr0ccDdeHYke 8kG4iX045ckMl8yqzteAOSb8vanwPlvwOhcbr3iajJo5zW1fjEBnTR7uRvMf0ywHzHwxC0gT mi7QfQZyZR+a0P9vNLUdHPtR852Zb028EugmFvTWPhfcDSbcINjmDsFu5hMRhx4mxEDm4zFZ 7HlRiCUwtIb70Rd8jfm648VzboKF3NDhsDmbn4fSDRb/0thzH3EUpKNrxPLwSx5wmO5aIsm4 c6rvtSFXzm364nuFfycnzeB3lLRgZLJmOD6g3xBAM9FoxqWHIAGMwhIg8Hzvs92e/No6IIm2 hDRZqhnc8d7imLf0CktEeQJWgmKRKxPhePC49LhP4L2znyV8tvg8K8O9/iQEawNsWWcw8dQd ONZkbaFuG5yUb7k+BM4xaB/wawGs6usL91ZMAFHVPcuIk0jG4OhZw0rRSTHQrwXXYg5eJ2OE OhxjTeG6mQj/1ljyGQacFmDnZOAuDhARclVgmYAFcrbrjD6Tj+CyheBoWZkyynDPIjYQsDFa 9JRwo0/hRgqsxlePK1uiUDkwyjINBoV4ziLcRYiW1NHp5/2t3vjzz4xXRQp6u+ZwFzcvGS5+ molb2iFgJ1abc+dUL9PFczbglIsemdOHtd1iN/QYTL0TCmmRsMWhmsMds2Tgb6Yb4oipbwJK E9uEBt0lkCsp/8D/XG9Cc9zsY7zycRRMCCDNPCOGUz8x3Mfx3rohBE5N4bpaHX5FzLdGxwN8 93Ct5g1VdF41Fr13y4O57yncf9NcljHzSYCgblIyjL81DNyxzG8PrDVje/7Na+zJimV7NfXc Fd8fRamRVLnwVpQbR3ClJRlVgVSlsV0OqLFjuKysGYSuhzDp1IeJuwWMgQDqvTeZ3hXbWVqs expPey1sgmD7EnAcFjH13OXgjvd14nViBOMB972Yr3wQCZ83R8UkpieFkZpzRC3dWM3f9eF+ uaAkU8a1KHaOFAN8ugDD/EBCStMG6jaBCXngqUdirAJgvFDRdXV34Tq6cyUbLMVYoS1XWlJW Ajw4FrByCPxZ0WmlhfB7/hjbL7Hm2i62kkDdmHmPwcfAXbUH28MTt2Uf1P3tYoHllnhitzej zGCqVJaxCqKVIPkNJH02TeBUSxSsF/tJChDJeD3iQ2EmDExbWL6CLue/2GDmnWSTVVEC2LWB exSVZAzm3oXJzGex5IFXle/MzvClHlTwGCagx23mncDXbV8SojHcsaIfVozEQKrRisfYO3Sh BOxsdc1Gwv83hUGH6XKnsRAYTYkE6CLMKx7ul4VsGQD7DAC7dxKxPpFPzLwj4wAYuwHAfLeu Dssw//iY5aHcd1gSQQ/hToFeRiokeO7m/gCgrRHYnHwux7bV6+45Eqsm2px78w7r5Cg0LfMr 1G/HWvlVrrzn9260mteBK4klqZNkPqr+igpvtbRDoBxYFb13PL6G2FNV/7ejN+B6zAOwDMXj t9uVVmANgUOzZeFle+5TbvExlPHX6Psw48ZkHmj5A3wHyjhpanffysDdRPgZA6sG7KSGGjv8 /y8ASnOquQ/0s4YViD6nuq6MGXjGjfTHHL+hKdStvCMzjWddfgwrmm3wHRNg5d2VUy5K6M4p 78lh4S6nuxvB57jAce+C6zyLK90q0VgN2OW8djmHt0y4l/Zg+/vQ0qsGU28XWQWkauS1F8N9 D192wNInEbeTo0RxALyv/lzZEkWpZWtFgF0F3I0YuItNSXCX2B7U29FL1h7uQjB1KgRT+2wa p8EDz8LdUHJMlphqBscTaLoxJg9TE00p2DWE+3zQ2rGgGBwTaMPY/eoQrAL6c8pNwhtyJVU3 Gwi/awJL2paK/t6LTNaFxJtvy+C19xn3abZEhcGdBlZBhpnEV5Q0D0wlNmcLikzWPYkAXdOH azUft3Z3pXBvMXcYyjJWJ169NYJz5712zeFu4R8Vo+i7ZYES3PttmWPhHxmDaZo4uXBawB03 Rxl7xRL7G4S/rqUrfjoIgK3Qsa3CY5WT8lR77/UmNIFnexGmgEIwdDA28bb2i8222ZYO0kyk ZnCH+0hlNIC86bJQYuMXmwPHdwQ+t5uMo6a9PDPYH8GsV2plPjSwGgV7D09dWGGbwBjR5eT1 djrR4Q5Ss6V3w9Uya0/GewvPZwn6Y0/chPdvgBjCtzDptRekrDrCdavJlS4hLm64tGUcNiW4 Kzout4TzCaBw7+9TXQO4y4FdK69dhLtqDxYGJ5zoYty8hAE5a5id+YJhmsI9i9gB3BGKEEx9 RYOpjaY20UCiMPgYz0ZDuKtarYipn6eNV4STkmCq5nDHZtjg6VJvDrT7r7iSzUvsA2/FDAIj CdyN2WMCwGITiZMQDH1Pc9sR7ou0gDtMBKbeycRkfUQa3UBWAnaxrk89YQKqK/xcvxjwbRf1 xtQ588CkHHPccASfRUsRCIAvN9yFbBn8GbNwsJ6Mxd4cYrk3PZuu8PptWcY1noabjboUw73e RJRQDlqdfFWAZR1orvsvZcD9p9M0FRKLhsnAvRlMIGutD6SmmPml8D1TNYU76PIo95hvzyB2 5169gOfEl5Ov+Flm7ZWPhLuOCo+1bO+d76u6A8cEtlhEyctuN0AOxjk6DyjllQ13YUfxZF5/ t/aNzoRx763gy+CaqJjQygS8SskVgC49f/DmMR7VRNFrg5XMJIe1i8aZr3oUIx8kTS0wX/kw RsHXdscgZw+Qopty0pLidcfXgRVCT1g9tlPjuZeCO0h12PR6K5XtBvm1koBdCnijcoBda7iX bF4aErABvJQsDLJYByPcX/BNOjBjRo1h42w01Nvx3+r8egGDWVvVSBRyevun8NpVwb0k9bPv 5iG6Y888psFUhPh67eFutDwMM4O2MZuXxACbquCx1GvnV1DNZ1eFz1lmtOJZKua2Y+MP3Ghi Ap4ShbyY575AFdwxkBpOKzXqTzp3X9Fl1bdC8JQFu+iZ1BZ+riv8jcozEHz9lcozuzILsOSB EQIetXcAvAG1W5rDHbx1A8Frx4nBeEkoLYVgdTwfgp7PYxHeAIZx8DBhRlVnrqRpOgU8rWh4 Iu+1mTesBsdfp6V8sTcqblbS/UkoN4Cv2DMVwK47CuD+0yViHpRWGu6NpmGNFV/bk9nZxnCP 9X69SDjQ0TnU3VXZ92hHQG/HnanXidWRl8QiMDISxswULWNJH+W4aOC9m5XpvcP9heOeYbb8 fhR4lKvpRq49Ge+sYKWNzoMmnjtO0BgrwbRVw6m3aZVJ89WPouE+LRTqo6iKoakEvNp42tCg BvA8WCtNbs1n6wF4jWHsjIDnzYSVZPAa4LFIA6kgQb3DOANVEwb5rwLprzWsZuoxUFeGO16z +pNqg4NRswzNvRjuil5eGK/0MllwE/uyDi0Gd7vF5gB9G5oKWRr0hmrArrHXLoW71IMVd6bu 0h19Kh8Bgk11rcDDsQYNnbc0GYNlNb4GJBNreC8GIzGNTsgmmCcjUdip0CQ/tSSjWooa5DdL f8bNeAr3tQjtGHoeWIseoU7/n5oA9bUlcMcSCwh3CKZmATg2lxFgMy0D7paYYkYlovl3Y4zX hmUA1N6bbk6gtc5NMbMBm3SgRCN67hToJWDHhxOLhJl6x+XSJhUlXntD4dhqcyXVOMVyp7WF vzUUs2fAs5ttuPB2iPm2tFfmAel0wjCc+5AGWGk9d1oRkgX7jRIT89wxwwICkOj5o8SDMQCr I3nEck/aCwVfadALvEmUjDoK1kkwEfJd4T2bzHcmpVrsfgGTTCgxmPEA5K/7tHwBTjT60/ha 83oAHz2ceKbD3+Y8hRXBC4LyC6wI5hfDvf3SfnBN9thdfJNvihu75ofAvxP+LchE1CbeLPlZ NPi7wcxH2DoR9PYiYrTg6j0Itg2WrNDkYkkVJjdqEFjVyHsHT3UQrjAt14cm2e1Of1flADhk wangQIRTOU8juI+HFRTuIgaZjHa7ggCryfxrT2BV1I8Z44Zc2fXqVUN9oJ8xeOcWVKrhg6k6 IHfogSdvLJ47ANNK8vzQ84fz22S9NTa7WFPfEpmO+f7wnC+H8+8kcWrk4M4+Ix5c6VadYrYM D/e2i2Al4f81SlQC2EewAIfvbU+9+NJw1xbsZcJdT2WmDMz2uJyA5e17vfH4cIIHNkX00kSv 7TbdUFJid+kgMJh5l95ofA/ocrSmB1z84Z9DkyxHMNWUkaKqwgMfZLjwySsjABhKM1h+wHg1 WgRt0oybVlBGMF4dTQ31bBO+CTZvGEyddz+JlljVTG83UqG3W4En4gLe1QB4UCbSZeOw4OMG M6+GGK0OTUMv2mxTAjHzioPvhWPCQCt6XAtKmmSjh4/vM5hz/Zmi5/oxXEkDiXqMjlhduCce XEnZUxHwjQTAt4Bl7yQsvGXqHZNqsSuHmPumEJNVsEoBKBrOwlTJ+yVjYqpgUzBt7jZNo8Qd qnhtUN6xPJhHLPak5xgtvv0UyyDAQ4qB9g4qrBj2MNnNNF7zKMz69BtidTiPWB18SawOwOt+ eD30kv9/tMMv+b+jHX1FbM+/heONYOEOKxIMpgafrHK96L3NhUJic+oNsTnxBoK5YMcFw59P 8WZzqoDYnkZ7C3GBt8TuahFxuP8HrBYOXuJazm3LqU7vNf0UY1sizahsDK3Ce69V7L333jjZ dPHtMPBmC1F2xeAopkTi/dIY7ljY7bfzdDcxFiGzCYzPpg2ee26opak8oxbuGEAdEmgvnjN4 xYaot1NJZpC/B5yDLScW4+q6xkF4fmidKDwO223Jr+12pLyhBc8G+6+DsTxYGOe1hLGuCdir S7x2UW+3Y+EO/JhvuuhWmMVaujJYx8ouMNaxMFhHIQ2yPGDXyGtn4W6gBu5nuG9230RTDOeN k9o3e4pNga/fSm3vTfTMwCtrwylvwddo595ngHtxnAG8AVq3HnPcy7YjvI1WNl3+9QYMuF9U TGbq9HbVGQ/NZ9cHyaI/fO7PMEg8dX8+cgNA/8x4TVgaeMFFCHHTTfEAUJhoVoYD2CNo+iP8 jebbwzK5oyC11Bc8lZpMapfYAEXsTFODXb4Lk0JLReeV38NE460//eJ9061x6RZ7c0F3fkHr x2AHI/w+E9FwdeEVT7ANoEVQOrHcnwugzS8y84tNMph56R4M8mDcAg/H1ZMrqScvWlvBxP9v T0Hfav4g3TFHr+pPOnVTf/JpZZvC2hllE94Dq8clTDB1pgH8jdpUsGln5W26GoO/00wZXqdV VwHSqKJjSRrkeUvHkWzeO3iQLeBazDNdeDPUJighD5vqYAN8dAyM52sB9zEXaAxEH1Y3Flvi CcgecQC6NVzpvRzlArySzj40qDV4yPpUkhm41QXGUjOQVsxAE8fNSu7CeVNZCj1om4D4PKqr D/AdB/dKXGHVlMCdtToqwM5q7Q5KenvbRQ7gpc9Ab91y4/MUmFSCwDGrI8IdJqOaMEENU3T3 tK0AsFcA3Luubg8PdBdYvnTjOi7vBRevLyxnB3DtlgwB7WgYRJS/hpMarmzwO/wbvgffi+V9 OyztIfFiP6kmWe40yOazXeCc2yi6rO4I590VYN8DzrkPPY/2SwYJ5/0Vf96MFZ8vvKf90v7w b3oDtJpxZW9D1wTubBGo2lQPbzy9NXxnX9DDx8Hg3ogDV3/qxUfG6yMyTX0S35j5Jr1HqGKg 0GjRvShFn80zccOOILXU5ZTr57NNUZyFAewhvKeOoL83ETzeVlyTGd3g2oxCj1tn9MHLhvNv PjH1eh5vHpySY7nnxWvLvdlvLPeB7c9+Y7E3M988MCHddGN4nMHsyw/QWQDAroPxNBKuT2+O bRIilhxmqlMKG63En9vQ99Frzd4Dydjj78dXYEP5+7VksHBfBnAt53UtzuVvObeTMJ778/d3 6UD6XnFsy99n8XMH82Mb/n3bxZ0x4KZCklGZAvkJNvKoy3sXn2nlXau8h9oY9ORW4M1OQDDZ 7UovxJ7HuGOVZs3M1Q7uOhADwfdYB8DKbt71pzA+B0rGu9oAIQASpRTs92peagJrNV+Xpj8O CahJwd5vix08r+itW8AYd4G/dYRn11HReZUzba3XbW19KvkNDdoBcP0e7ldzTuy81HRmQ3hv D3iWGjJZMXLZMR4yHrsD47XbQiynE3yHj9mSu+GYT09XLf19Woobk+AatAWw/4bNOT4H2DWB e3G7LtmHnH8g2zPL5o5cSbs2fBDFbd6NufKVQK0wsGsMd/6GiYO/JiNNNBXOpzVz3h0kcGrF aNoNuNIlftVJMgZq9FIp3Osr3Yf6kzpwTaZ3hwH+G3rVNCgJMpiJ5/M0U+/4V3TV1HH5AEaO qSUclyujHYqdrZxkAF+X0d+bC9egHddgcjd4wAZgABQG9wqAfRD2Y6XfL9qQgD3gLW0GD2YZ TAijYWLoBQ9dF+batWWALhYva8GV1LlhrQUD+7ZKHn2JSSeL1lxJFUjphq3GSrty+c9vqebz xc8WP5OVuGqWETT/JCtSGe9d1a5VS8muVVcl712U3vpuxl3Ax602h6dithvGkHBnuhH20NUE 7r+eIxxmKAHgsTwGeMwQ6wnaBmPTtQz9XYfNiKEae8lGJR3GY28K0Hcqhl+r+QZc42n8s9N8 tin8W2eqd4PeD5IQ1g3qhpswcb8OM67dYZJvDO9vDGO3L4zJRkxCQe3inPb6k2rCWK3BlW60 LzYQqgJB2CrwHR2xlypcszRr76hMuC+7Ycy3E87XFL13eBamgENjo2G6o14ZYP9ouLNBGA9m lhdB14IBvHQ5zYKdBR1bKMye2bL7ySUZLeHuVCptrARsLZW8SOWqimzuuKoHXk6SUb0ztXSF vxJvS37CaQ8DriN4Mz9Rj35IAHoQi7mGU5pxJfXz2TLLrBdSVfi5mgTwtaT6O/OdHSRBTzGz pSvz/2LmSyeObcStDF8R6GwZBDlrxtyHVjL3oo1kspB+bmMmt78hc05yn81+LjtZtOCUW0TW ZiZxdkUqTYH8lHDXJLhqXcZ4wnNqpei08juUmmg54F3pNAMMU6FpfaEZZcEdPXeA+6hT8Lfr xMo3gZivehRFPdl+3q1k9PdikNEA6SA/G/ozXxTMXMhhL4H7wK2WMKarA5SNAJrWIMUYcY2m srEqE2x7B8HXiVSS6e8zRNFnU3dYJbrDSqsxrO5wlVKdazazPle6IXbNYm+9zUKsObRY0WVV W2ZFWwL25rOdYdWMlSV/gftwAAuoWa4PSaINswf4dhOutxkcbxfaQo8v6ytXVqCslMdygV0d 3FmNjvVi6zLee1OJJ9Va8kA1k2RlSMv72sl4sQb/IbirCjxVZzzlRgzgWzAAaCk5XzZYyT7w 9mWUHFAH96pMpkPNMiacNkrQbD67E1h7yQTrLgkIsW0LxXrXjgzgq8sEWJtLJvcOkgwX1jrK eNWqPGp2U5W4sUrcXMXCuCkDY/F+tJTx/JvKfHZ9mc9tLPO5LZn73IpTrgPP9v6VTuLqGmDr fOIUX21SI11lVuV47VCWHIXBc9sdyfnWgak0UM/vb9AE7mco3DkE/PirxMIrBiSeCNSg9wAM h6sCPA2SDgmoLQGbkoEHbkDB3mW1IQ2kgiQD8gr/LDWYbEIlmT6bGoLX3lDRbU0diOk0pZNZ iznV4fP7gvUHGaY2fEYPmDiacNKeqUJyAej2OEF4guTWsPhZwc2NnVc2hL/h/oAFuCLGNFJa UGzp3QgF9kLts6k5fcabzkTpaDyAfSHIeDbCM2+ipmaMJpkxGoNdDu5SL1Y6CGoxKXKNJd5O c8mD2lgC9upMsKmsQmE6/yG4y+mSou5cXwYszSRgYtMLWe9Y7oE35kqX+FV1H6pK7oMUtM1k ANdcMsGyEHJh7oPYHEVsY2grHKu9hoCXrmTaFa8glIOk6mSSxgx060kCWqyJGQ1SIIv3pKmM 599YAnX289lNWw2Y0gtNVNznppLNX2zsgvXaVSUJfJJYUhnyjCbeu5z8SCtGmkCQ1W53eiE2 0sZNTei907TTsuA++pSw2esE3Wxm5hlFbLclv4KgbQhId3PRo5VcG3Vas47kvEpWJ+C1Y60W kAXdAdYWAG1n8LrtQAJxhYlkJGjv9QDKzrBqGA4TQzdYwfLJA+2XtIAJYCCTJSbq6vTvcO79 4N/ihO4Eq4ivQOqZi41JAOC+GKAtzpvfk1GEu1/hnJYDxJ3oM9t+STX4/yWYXw/HUU14lsuC u14ZG5W0Ars0FbIs0LkxGRR1VTwM0ge1LgN2N4nWbi0psmP4qerJaAB3VVkF0sBifcZ7bCyp ydJAAnZ2lVJFjdeuScs/6YRTQ2bCkQMcu1GpFgMhJwbsbFNx0ayZyZ29/9UlOfCiNMTq4dKV nJyW3pTxpKUbqWoyXpSHTIpmTRWgbyQxtqRCPZkMCDZTQgr6hpI6O41lJgk220hVTwJV9VUq dFxrIM8YaVxUjF2V1R3fHjzRhZhFY7stKc92G3jwy8P4EhRTbvLlI8aXAXcswvbDcaI35jLd /Gd/MJtYbXqeTMsUDA1aCtJKTck10pNAvpSB52wKYDYTnxlaH31o4EQhM8UMvGYbkEGwmu1i RX/vATABVIP39IYgOO+Ft1vcBM7ra/Dm64NnjsXjmgjjm2aM4SQAx7YTYL4WPgPTj09arA9J tNoSkY6172nKKBYW84vNobXxB/tPFurZWyt6rq+PRcrA658AK2ZbUZ7REO4VBnZVO1RZ0LFe o3NxlJl/KOpIvB7pg1SbK9342lFSHlPOa//UD0BZQScbCUxZwJeVD1tTMpFVk6kYZyLjscg1 xFZ1H1wYwNdWAzi5CdZV5cYL/rvMmRQy8XurMF6eqslOTtJgV3LNZDTvBpJcezYrwVUmg8el OBhWAnopnFWls2k6adRSsaGlPvNzHSY9zl1yTe1ktPbPMra1CK6al1USWCmuUm9CBwDWFAzQ W3qFJtrszKC7tHHDHLbcoyUIxqmBO7Xj1IPHjWxmq58TS+9EzKUvpDtEhwXvBxAOx/orXMu5 xiqCi8qGQVTQ2kHb9gCwdkavXdHd0x5kmkGwIugOWnhtxQCfnvDzt/D3mVzTGSJ7+GSBuhNc AfRNMC0SN2kCwP1Amx8L759GoY4B4GHBJ6y8IzOsfaMyse4M5v5j5ykseY41s8xXYcmCoAPw GYPElS8EgTFWEQyfMxQkIpFxbKtQKdw19doVHwt3qSRgwSzhqkqCbO4yeaKsR1RDkmbnxMm3 0TNRVxr0E8NdbsMHO/BZr9VFAhXxvGtJoOEumcjUdZcy4FR3Rpfz3u1kAF9dxSYMFmw1JBOs HNhFz0I0M+ZasE2FnSSTCzvJN5BZ1TSW8aTryRwbe92cmcwdR8bYTB4W9Cyg5ay6TC6/K/MZ Ym6/uwzs2fssN7ZV1fSWBsw/6YpUy7ozplrIMy0EKa09wHA4QHgHaMyRdtuT821o39UYKtUY TLoBYOc3McnDvaTYGpaI0B93lebO405WbJphtvROGM0wGRo0F75jMMggzsUyJQZM8fgxI6b9 EmOlVW7DKUYA0qZgLakkM8C3A/w8gO7s7u/TC34eBR68GxND4hnWaj42y9iGejmsSPLRG4ef IyzWPI61hXOzDU6iGWZYQ8tmWxqxxHLRWxJoaqe1f/xLmlo5JHAtBFtxHNuBFNQYZRmaldNr QzNmJawO7pp67YqPhbtsqUzh4FiwOEoeMDdGp3KXPEBsil1VCVBUge6TPgBllEqVTmoi4Nns ERcJDNjzdVGxucGKU99dSl3DblX3QW6iraEU7ZefYB1k7oOZTIMAEwYC4mpG1XezUoncFm45 OaQ6c+2cZbJ22ACvHfOzfakHVfm+yJl0BcCmfbIThrPMPZbeZzYlzomZwO0kzRpMytpy/6ng XgF1Z2rJ6O884JvO6AXgXYHprWYrH0RZ+8e94D35aLoznRZy+/kcny2DcB91UmVTcd3RZ2m5 YFpNMgggvz31jeXG58mmi26FgkfsD3p5W8xbF7x5QwicWgl10OWqpxrTdEOE+5DAWQD2HnCM 0+B4q0oSBPim2IP8F2CddoQ39oNGbxy9crud6bT0AhY7xCwh68AUYgVQxxahtjvS3psvfxBN vfr+PsNpDaqOy2vDcY6jEtOQgEVcq3lOTOzKWrIqNlWR/qx1tUdt4K6jrlwmAxZb5kI5qHgw 2IfHkYE624bKvAzQfS64s4NeClMW8HYM5FkPkjX2fO0l25HlOrPoq9AVWe/dUMV9YIOdTiqA JDfhqJpgTWQq0hmrmVzkJjw3ySRTlvcsnzMsbAhhHg6pSQO+VSX3Rc5Ez59N97Rn/n1VFZ/j pOI+s5NQFaYaoKVMHW/Z3ZifEuxa5r5bqQnY15ek27YRAuMdwZseBhr2fCwTDMHE51V2puRb +yfTQnZ6E28QvV/O8dkyasoli1o8lk3WG3eFGC14QizWRgJkU0HLjkk3mnb+AUDeB2A9Bmw0 QHUGAPQH9NJBdnEA6JtJHBEz0LhtFN3X1QLI9wMA92McgxK4t55fG/T5YNugxFcoryDMzdZE 0JUErdMEhsUAsXeFVUAysYMViuX60ES6u3WQ3xSu/dI64J23h+P4jW6MGhq0Gya8virGb1lw /2ReuxTueioAL8LOSvJwVZF5QFiviz1RVUXsVZ7gZ/Royjpn6zLO2V5yzjZqJjJWZ5fLCtDk mOQmWrlJpxoDNXsZ79JURc6t1CuSGwNSyDtJPF+pOcvmCpccl62KpazULJiJRjoWWe/eXia9 0475LqnZyawQNBnb1mrGtsF/wmv/iMJibBKBHOBbFG9eE9Nem83qC6CbiZuewOtOoo15tsQR w5n3aRlmbuRJvmWhqs5WxZDH95yESeEC6Pi3iSXIPXZ7XmB7u5cWax/HgL4dhXo/SkJUox8W tJmmHQ4NXEhtsP8I2m2pu2dtWiis29p6APf+EHRtCdYGgqe44hgKvxsBgJ5H6wntyyxCgGOR PaNZD4jx7Ae0JhPW1LHyiS+y3Zb23nJDaBKVYAb5z4dJoy1MaH3huxZifSda932Q3zRMjZQZ yywDWNlTG0lGUVFwV9emyoTRYFngsQ8Ya6zXZVnemeszejSqYGoqAYoVc842kvRBawmczFVM ZAZqNipoCnjpaspOBmqqJhwLNbtj9WUydwyZAWkqGQM2MhOeg0QnZ71mBxUPgZw2KY4VqZlK xqKlZDxaS+6R9PdWzPdZMv/eSsW/t5GMaxsVk5CpBmD/T8K9rMJiUv3dVWaPR1PJ5rX2xZBv v3Q4gC7QZO7VJ9YB8dl2O9KKzEGqwYb6WClSZzRo8CLMy/TmT9KSzRioxVLhVluTieWGGABu AnjZaehpF4DXnWvtF5Nluel5KtZwoamIw4IPA/R30IDmMPCm0dMeFrQPbD//t+DjtHcwr6UX 2cJnYSNw3HlrsugpsdgYW2S9NfGt3bbkN8L7wFMHkPfZNAgmjt9g9bAFfnfUaPqFB/DzBphA 2kpWhOocPLPP7bWrg7sULMYqHi4LyYNiyfxeXQpQmYGETzzgNQG8puesyfkalrEDTVPAG0uO R27SsVEBIk0mHGlwV26iN5WZ6G1UeMBSj1nVxG/GlW4OrKqhgdx9MZfcH6mx7zGTmLmaz1B1 n+XutUY66ucAuxbyjDTOVEVSGljd5rU2SpCvP6kzeLdjabkJgKPttsQ8vqtTBHjEj4j+xOsg 1ZxW78kzjVD4JuWnQL/H5ivn+JLCE67QPHszhD5o4VUPZlPN3B77R+zJKMTgLMD5FTb7ttuV /t5ue0oBNuOw25lWWGV3xnv7vVlFWPXSft8LPuMHpCBawTI4nW8aPyzoIG2CPXDrbPDSh4CX vhJLA+MGJZryODQwCPPfIZDrKrM6lu4ZkUoyn9VrR8P/4IfpCKYrGH4pfjkeBB6MOBDQTAQz ZcxMMPH/xfcYM2bEqT+x4pODC62oWAtWiK/4+YLpCKYrGB4PHhceHx4nHq8xYyaCmaow8e/i +1Wdr+w5S45Jp4xjEr8Lr7k6sLEgkh6beFzSY9PV4JqI18GMK+1FS71g1lvWdCIUrxtrhswx qLo3Jmrui4nMPTKW+ZtpGSZ3n8Xjll7PUvdYOh4/tUnGlvSeGjHjiE0DlvPg63FMfX+uZF9D qc1rIIVMUQwO2G624n4kZp5gjRrMNsES0BhILYa3CPqyZBva0vAE0cFXkG8wGwdr3NgEJwud 4V5QGcdsZTjAOhy88Qd0MjGceouma+KmK9TUscmNKb4H6+UseEw9dtvtaXxv56GB22H1sYLa 0MCdRjMvPcSNSgo+M8YbPPhvuNIBejGozkqfbAzmP+a1cwzc1cFO+nDLPVxyZiQBHAs5PXWQ +0yDXR1M9TUAirrzNVQBT1VQ1/aYjLQEm7YTjrbfb8rAnp1wpN5yWcfEXjN2rOhLjkHu3hhp cG/KMmMtxrWqsa1yAv/cYFcx3tl7asjcQznAsxv5anGSDl2c6h3K7bimM7sp+mzGXZ07LdY+ ia+yO/2tTWAKMV8TSaUQ7L1KO2f9KEL8GJ8Pz0JdFfCxxSHo+ZhfjzVvjLAs8dwHNA0TvX1O +EwFvI/aiONU08diZhi8xXx7bCpjDAHgKnszEO4nsSQ2Sjxo5isfRivQk8dmHn02/8gpJwSw gGczpqSJFFKtvSzntkLBLoW7HFh01Txc7AMmNXUPqlrI/YcG/Mees4HMOetp6K2XBXndj5x4 jGQGlqoJRxXgy5rs5b5XzktWN+nLXTO5lYS6e1NRZqjFff6ixrYG3rsmgGfTbqV7G+pwpUtx SIutiaBvw7VZOEDRz3sxNhA3nnXpodXm8GS7XZlFNv7JxHwtL9kYTMZ2iSC//HQO9PnTRDGS Af4PR5U9fDYIOwLA/f1RovgO7NvDfP9bBPkIsVUi/14FnShO0YbqCHdD8OQxs8d8Yxyx251B QLZ5a7HuWYLh5LP3wEsPgsDrNEUPz0Gc/D4WddleUq/dVOK1G3wur12Eu0ID71H6cMk9ZHKD Xfqg6nwpg7+Cz1lPxTnrlAX1Mo5JlSdfljdb1qSjW46VhCrAqvOkpasZQxVg1C1jBaHpvakI 09dwXH+xY7sCAK9qA6Oow7NePFvfSFqtk7e64xHy/RTd1oxUDPBdg1KH0bTz9y08n8VjhySb oORCa9/EInNsB7ksjBYoo43UJ1wn+mOv0CwanZ/OEG70aQp/GqClxlefFIuUUcO+uaDRY849 /nuDiTeoHIQyjNnaKGLpHf/OJjDprbVf3EuzVY9iDCedvkMb2Q/wXQjHNwCOsy2nXNO9Vhlw ZyUZdXLMZwU7C3dNwKLqAVNlqv4t9wV6NBVxzhqfrybnXM7JR9OJVttVhLoVjiZQ1NdwRaOj xTFU5D3SdEz/14ztcgJeXIWZciUBc+lubXbzmqjFi1IN68mzlVNLrMHktlzz2V0UXVYPx1LU 2NcX4HoEpRHwnuNt/OKysWuSdUBCvrVvwlvLTfGF2JzebGUoaOZ8U3hj0M+LbT7Y3IfEZPFT +HsIfY+5ZyRmvxRaece9sdoaR3egWvlEZYDcEqXArBmE+ZAA9NBnwXH051rMacE1mNSQU73x joW7qwqwa5Py/dnhXhbotXnIyoTGlzTo1YBem3PmPsU5a3Es2gJJo+OroO8uC4xcBVl575GO lvZfNbY/AvDSEhRyXnxNrqQERUNOvs6QXEnmkrLMzWZ1VPRYPwpgiznrPgDeYIA+liPApjNH rH2jM9FsgxJfgnZfQG0PY8LvbPxjX9j4xWRZe0em0QbYmPkyNHAXfF4AfK6Xor/3VEXXNQMF kNeXMTm4i7KMB6dcckK6O7kssH9Wr10d3MsL/f+qgV5B0P+s5/spJtwKuA4VAsbPcX8q0v4P jGkdNVk0qnR4dne0tMYRC3m5JihsRy3l4nL1JjTnGk9rA6BvB9JIN5BIvlb02TRe0W/LDADz JgrnIQGBFPiqbHDAZvreQX5rAeTTFb28RlKYt5zbCj63BddwitgRroGMSeHOeu0eEjlGTmf/ osBeHrhXfvuy7GPg9H/h+yu/ffy9U5d6ayxJuWU3r6mqM8RCvgFXuiQ1Wx9frnKoXD1+tgAd 20VLDtD11QC8gQZgr/N/AeyVH+6V3yq/VX7AywXN9WVkGhNmTwNbAsNBC8hLez80VWGqWizK gZ6FvdQ0gXp9DaQYl/8WKabyw73yW+W3ym+qAF+WTCNq8eqKyclBvi6n3PFKDvZlWWNOvpx0 Iw3hXpa+rip46vSlB08rP9wrv1V+q/xWlrym6Q5pM051MTknTr73Q22udJOfhpx81yt1ps5z 1wTmLNBrc6p7MkgrqpY3j13nPyFJVv6BXfmt8lvlN4WWZTCMmYwadZCXloX24FTX/2d1cjkv XBPvXFOYSzcneaiAujbe+hcF9soP98pvld8qv6kLkKvaPGcg2ZlsyslXDJVCnvXmWdDX4kq3 S6zHKbc5VJe6KAdyVTCvUUY5ATmoq/PWNdXXP3sSQeUf0JXfKr9VfiuPFy8XcFUFeWk3JBb0 bhLYs8CvxQC6NgNtKbxZiKsDubjDVBXQ2aYxmpTtNfhS9PXKD/fKb5XfKr99KqlGHeSlXc2U 2t5xqltYeghwFq0Gp7rTlwhxdSCX9ugtq8eANhVVdb4ksFd+uFd+q/xW+e1jAq7alIW25Ep3 c5NrlSjX01Zdj1y2V64U4tK2n2yrRbm2eKoasJTHW/+P7+Wo/AO38lvlt8pvH6vHl9UPQerN S5vMsE1e5Lp6SRuaq+ptK+2ZK9clSR3QzWQ09f86qFd+uFd+q/xW+e1zQV7aZEYEvbrWnar6 2kr728q1llTXAcyqDKDLeemaVlP9ou5V5R+sld8qv1V++5SQL6u7GSvdsJ69XH9cGw3MWgbk UpirAnp5of5FltOo/IO08lvlt8pvnwLyqvoPqGv0UlZXLwsNTNMOYGUBXVUzm/+a+kiVf3BW fqv8Vvntc0C+rEYvqrp6yfXAVdfbtqwOYJp2Afuv8tIrP9wrv1V+q/z2uSGvTaMXuY5imva6 NZIxQ8EMGNMXTE8wXcZ0GONkTPFFWp1xsq9q/1j5rfJb5bfKbx9hnIzpSEyXMT3B9GXMQAuT /ls9xtjvkx6L3PH+117/yj8AK79Vfqv89p8CvRzspcDXlcBZE9OVMZ3/6zCv/HCv/Fb5rfLb lwx7VcD/WOP+r8O88sO98lvlt8pv/63Q/1irVNfy/wPC95oU2Gi6JAAAAABJRU5ErkJggg=='! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'AlainPlantec 9/11/2011 07:04'! pharoLogoForm ^ Form fromBinaryStream: self pharoLogoContents base64Decoded asByteArray readStream! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'AlainPlantec 9/11/2011 08:06'! setDesktopLogoWith: aMorph self desktopLogo ifNotNil: [self desktopLogo delete]. self desktopLogo: aMorph. self desktopLogo ifNotNil: [self desktopLogo openInWorld; beSticky; lock; goBehind]! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'AlainPlantec 9/11/2011 07:05'! showDesktopLogo ^ ShowDesktopLogo ifNil: [ShowDesktopLogo := true]! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'AlainPlantec 9/11/2011 07:24'! showDesktopLogo: aBoolean ShowDesktopLogo = aBoolean ifTrue: [^ self]. ShowDesktopLogo := aBoolean. self desktopLogoChanged! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'AlainPlantec 11/30/2009 06:31'! useDesktopGradientFill ^ UseDesktopGradientFill ifNil: [UseDesktopGradientFill := false]! ! !PolymorphSystemSettings class methodsFor: 'desktop' stamp: 'AlainPlantec 11/28/2009 15:49'! useDesktopGradientFill: aBoolean UseDesktopGradientFill := aBoolean. self desktopBackgroundChanged! ! !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 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: '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: '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: 'morphic' stamp: 'AlainPlantec 12/10/2009 16:04'! uiThemeClass ^ UITheme current class ! ! !PolymorphSystemSettings class methodsFor: 'morphic' stamp: 'AlainPlantec 2/11/2011 18:42'! uiThemeClass: aUIThemeClass | themeClass | themeClass := aUIThemeClass ifNil: [ UITheme standardThemeClass ]. themeClass beCurrent! ! !PolymorphSystemSettings class methodsFor: 'morphic' stamp: 'AlainPlantec 12/10/2009 16:02'! uiThemeClassChoices ^ UITheme allThemeClasses collect: [:c | c themeName -> c]! ! !PolymorphSystemSettings class methodsFor: 'morphic' stamp: 'CarloTeixeira 5/23/2011 15:47'! usePolymorphDiffMorph ^ usePolymorphDiffMorph ifNil: [usePolymorphDiffMorph := false.]! ! !PolymorphSystemSettings class methodsFor: 'morphic' stamp: 'FernandoOlivero 3/30/2011 16:14'! usePolymorphDiffMorph: aBoolean usePolymorphDiffMorph := aBoolean! ! !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: 'settings' stamp: 'AlainPlantec 9/17/2011 18:53'! 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]! ! !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: 'sound' stamp: 'HenrikSperreJohansen 1/21/2011 14:20'! soundSettingsOn: aBuilder (aBuilder setting: #soundEnabled) label: 'Sound'; target: SoundService; 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: 'sound' stamp: 'AlainPlantec 1/10/2010 07:54'! soundThemeClass ^ SoundTheme current class ! ! !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: 'sound' stamp: 'AlainPlantec 1/10/2010 07:54'! soundThemeClassChoices ^ SoundTheme allThemeClasses collect: [:c | c themeName -> c]! ! SharedPool subclass: #PoolDefiner instanceVariableNames: '' classVariableNames: 'Author Gloups' poolDictionaries: '' category: 'KernelTests-Classes'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PoolDefiner class instanceVariableNames: ''! !PoolDefiner class methodsFor: 'initialize' stamp: 'StephaneDucasse 10/7/2011 21:17'! initialize "self initialize" Gloups := 42. Author := 'Ducasse'.! ! SharedPool subclass: #PoolDefiner2 instanceVariableNames: '' classVariableNames: 'Author VariableInPoolDefiner2' poolDictionaries: '' category: 'KernelTests-Classes'! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PoolDefiner2 class instanceVariableNames: ''! !PoolDefiner2 class methodsFor: 'initialize' stamp: 'StephaneDucasse 12/13/2011 16:01'! initialize "self initialize" VariableInPoolDefiner2 := 33. Author := 'NotDucasse'.! ! ModelDependentDialogWindow subclass: #PopupChoiceDialogWindow instanceVariableNames: 'choice labels lines choicesMorph choiceMenus filter filterMorph' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Windows'! !PopupChoiceDialogWindow commentStamp: 'gvc 5/18/2007 12:26' prior: 0! 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:45'! choice "Answer the value of choice" ^ choice! ! !PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/15/2007 15:45'! choice: anObject "Set the value of choice" choice := anObject! ! !PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'AlainPlantec 12/2/2010 16:52'! choiceMenus "Answer the value of choiceMenus" ^ choiceMenus ifNil: [#()] ! ! !PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'gvc 2/4/2008 15:43'! choiceMenus: anObject "Set the value of choiceMenus" choiceMenus := anObject! ! !PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'gvc 2/6/2009 13:13'! choicesMorph "Answer the value of choicesMorph" ^ choicesMorph! ! !PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'gvc 2/6/2009 13:13'! choicesMorph: anObject "Set the value of choicesMorph" choicesMorph := anObject! ! !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: 'GaryChambers 7/5/2010 15:54'! filter "Answer the value of filter" ^ filter! ! !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 methodsFor: 'accessing' stamp: 'gvc 2/27/2008 15:24'! filterMorph "Answer the value of filterMorph" ^ filterMorph! ! !PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'gvc 2/27/2008 15:24'! filterMorph: anObject "Set the value of filterMorph" filterMorph := anObject! ! !PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/15/2007 15:49'! labels "Answer the value of labels" ^ labels! ! !PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/15/2007 15:49'! labels: anObject "Set the value of labels" labels := anObject! ! !PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/15/2007 15:49'! lines "Answer the value of lines" ^ lines! ! !PopupChoiceDialogWindow methodsFor: 'accessing' stamp: 'gvc 1/15/2007 15:49'! lines: anObject "Set the value of lines" lines := anObject! ! !PopupChoiceDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/16/2007 13:27'! activate: evt "Backstop." ! ! !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: 'as yet unclassified' stamp: 'gvc 5/18/2007 12:23'! deleteIfPopUp: evt "For compatibility with MenuMorph."! ! !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: '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 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: '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: '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 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: 'as yet unclassified' stamp: 'gvc 1/16/2007 13:03'! rootMenu "Answer the root menu. Answer self." ^self! ! !PopupChoiceDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/16/2007 16:07'! scrollPane "Answer the scroll pane." ^self findDeeplyA: GeneralScrollPane! ! !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: '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 7/30/2009 12:59'! switchToNextColumn "Give the next embedded menu keyboard focus." |menuWithFocus| (self choiceMenus isNil or: [self choiceMenus isEmpty]) ifTrue: [^self]. menuWithFocus := self choiceMenus detect: [:m | m hasKeyboardFocus] ifNone: []. menuWithFocus isNil ifFalse: [menuWithFocus navigateFocusForward]. menuWithFocus := self choiceMenus detect: [:m | m hasKeyboardFocus] ifNone: []. menuWithFocus isNil ifTrue: [self choiceMenus first takeKeyboardFocus]! ! !PopupChoiceDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 7/30/2009 12:58'! switchToPreviousColumn "Give the previous embedded menu keyboard focus." |menuWithFocus| (self choiceMenus isNil or: [self choiceMenus isEmpty]) ifTrue: [^self]. menuWithFocus := self choiceMenus detect: [:m | m hasKeyboardFocus] ifNone: []. menuWithFocus isNil ifFalse: [menuWithFocus navigateFocusBackward]. menuWithFocus := self choiceMenus detect: [:m | m hasKeyboardFocus] ifNone: []. menuWithFocus isNil ifTrue: [self choiceMenus last takeKeyboardFocus]! ! !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: '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: '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: 'initialization' stamp: 'GaryChambers 7/5/2010 15:57'! initialize "Initialize the receiver." super initialize. self labels: #(); lines: #(); filter: ''! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PopupChoiceDialogWindow class instanceVariableNames: ''! !PopupChoiceDialogWindow class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'FernandoOlivero 4/12/2011 10:12'! taskbarIcon "Answer the icon for the receiver in a task bar." ^self theme smallQuestionIcon! ! PopupChoiceDialogWindow subclass: #PopupChoiceDialogWindowWithMessage instanceVariableNames: 'textMorph iconMorph textFont message' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Windows'! !PopupChoiceDialogWindowWithMessage commentStamp: 'LaurentLaffont 3/4/2011 22:43' prior: 0! 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: 'accessing' stamp: 'gvc 7/21/2010 14:02'! icon "Answer an icon for the receiver." ^self theme questionIcon! ! !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'! iconMorph: anObject "Set the value of iconMorph" iconMorph := anObject! ! !PopupChoiceDialogWindowWithMessage methodsFor: 'accessing' stamp: 'alain.plantec 2/6/2009 10:08'! message ^ message! ! !PopupChoiceDialogWindowWithMessage methodsFor: 'accessing' stamp: 'alain.plantec 2/6/2009 10:08'! message: aStringOrText message := aStringOrText! ! !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: '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:41'! textFont: aFont "Set the text font." textFont := aFont! ! !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 09:34'! textMorph: anObject "Set the value of textMorph" textMorph := anObject! ! !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: '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: 'as yet unclassified' stamp: 'alain.plantec 2/6/2009 09:36'! newIconMorph "Answer an icon for the receiver." ^ImageMorph new image: self icon! ! !PopupChoiceDialogWindowWithMessage methodsFor: 'as yet unclassified' stamp: 'alain.plantec 2/6/2009 09:32'! newTextMorph "Answer a text morph." ^self newText: ''! ! PopupChoiceDialogWindow subclass: #PopupChoiceOrRequestDialogWindow instanceVariableNames: 'okButton' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Windows'! !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 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 methodsFor: 'accessing' stamp: 'GaryChambers 7/5/2010 16:01'! filterValue ^filter isEmpty ifTrue: [ nil ] ifFalse: [ filter ]! ! !PopupChoiceOrRequestDialogWindow methodsFor: 'accessing' stamp: 'EstebanLorenzano 11/21/2009 12:19'! okButton ^okButton! ! !PopupChoiceOrRequestDialogWindow methodsFor: 'event handling' stamp: 'AlainPlantec 11/22/2010 12:33'! processEnter: anEvent (super processEnter: anEvent) ifFalse: [ self okButton performAction ]. ^true! ! !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: 'private' stamp: 'EstebanLorenzano 11/21/2009 12:19'! okButton: aMorph okButton := aMorph! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PopupChoiceOrRequestDialogWindow class instanceVariableNames: ''! !PopupChoiceOrRequestDialogWindow class methodsFor: 'as yet unclassified' stamp: 'EstebanLorenzano 11/21/2009 12:34'! minWidth ^250! ! Stream subclass: #PositionableStream instanceVariableNames: 'collection position readLimit' classVariableNames: '' poolDictionaries: '' category: 'Collections-Streams'! !PositionableStream commentStamp: '' prior: 0! 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: '*Compression' stamp: 'ar 1/2/2000 15:32'! asZLibReadStream ^ZLibReadStream on: collection from: position+1 to: readLimit! ! !PositionableStream methodsFor: '*Fuel' stamp: 'MarianoMartinezPeck 9/6/2011 17:02'! 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 current 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: '*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: '*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: '*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: '*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: '*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: '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: '*System-Changes' stamp: 'ar 4/12/2005 17:34'! 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 not] whileTrue: [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: '*System-Changes' stamp: 'SeanDeNigris 6/21/2012 08:39'! fileInFor: client announcing: announcement "This is special for reading expressions from text that has been formatted with exclamation delimitors. The expressions are read and passed to the Compiler. Answer the result of compilation. Put up a progress report with the given announcement as the title. Does NOT handle preambles or postscripts specially." | val | announcement displayProgressFrom: 0 to: self size during: [:bar | [self atEnd] whileFalse: [bar current: self position. self skipSeparators. [ | chunk | val := (self peekFor: $!!) ifTrue: [ (self class evaluatorClass evaluate: self nextChunk for: client logged: false) scanFrom: self ] ifFalse: [ chunk := self nextChunk. self checkForPreamble: chunk. self class evaluatorClass evaluate: chunk for: client logged: true ]. ] on: InMidstOfFileinNotification do: [ :ex | ex resume: true]. self atEnd ifFalse: [ self skipStyleChunk ]]. self close]. "Note: The main purpose of this banner is to flush the changes file." Smalltalk logChange: '----End fileIn of ' , self name , '----'. ^ val! ! !PositionableStream methodsFor: '*System-Changes'! header "If the stream requires a standard header, override this message. See HtmlFileStream"! ! !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: '*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: '*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: '*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: '*System-Changes'! trailer "If the stream requires a standard trailer, override this message. See HtmlFileStream"! ! !PositionableStream methodsFor: '*System-Changes'! verbatim: aString "Do not attempt to translate the characters. Use to override nextPutAll:" ^ self nextPutAll: aString! ! !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'! contents "Answer with a copy of my collection from 1 to readLimit." ^collection copyFrom: 1 to: readLimit! ! !PositionableStream methodsFor: 'accessing' stamp: 'sw 3/10/98 13:55'! contentsOfEntireFile "For non-file streams" ^ self contents! ! !PositionableStream methodsFor: 'accessing' stamp: 'tk 9/23/2001 01:14'! last "Return the final element in the receiver" ^ collection at: position! ! !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: '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: '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: '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: 'accessing' stamp: 'nk 3/18/2004 08:52'! 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 current 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: '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: '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: '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: '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: '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: '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: 'accessing' stamp: 'CamilloBruni 8/1/2012 16:12'! originalContents "Answer the receiver's actual contents collection, NOT a copy." ^ collection! ! !PositionableStream methodsFor: 'accessing'! 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: '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: 'accessing'! 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: '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 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: '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: '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: '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: '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: '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: '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: '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 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: '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 7/16/2001 14:44'! int16: anInteger "Store the given signed, 16-bit integer on this (binary) stream." | n | (anInteger < -16r8000) | (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: '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: 'data get/put' stamp: 'jm 7/16/2001 14:46'! int32: anInteger "Store the given signed, 32-bit integer on this (binary) stream." | n | (anInteger < -16r80000000) | (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: '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: '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: '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: 'data get/put' stamp: 'jm 8/20/2001 07:53'! uint16: anInteger "Store the given unsigned, 16-bit integer on this (binary) stream." (anInteger < 0) | (anInteger >= 16r10000) ifTrue: [self error: 'outside unsigned 16-bit integer range']. self nextPut: (anInteger digitAt: 2). self nextPut: (anInteger digitAt: 1). ! ! !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: 'data get/put' stamp: 'jm 8/20/2001 08:07'! uint24: anInteger "Store the given unsigned, 24-bit integer on this (binary) stream." (anInteger < 0) | (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: '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: 'data get/put' stamp: 'jm 8/20/2001 07:52'! uint32: anInteger "Store the given unsigned, 32-bit integer on this (binary) stream." (anInteger < 0) | (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: '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: '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: '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: '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: 'nonhomogeneous accessing'! 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: '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: '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: '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: '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: '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: '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: '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: '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: '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: '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: 'positioning'! position "Answer the current position of accessing the sequence of objects." ^position! ! !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: '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: '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: 'positioning' stamp: 'mir 5/14/2003 18:45'! pushBack: aString "Compatibility with SocketStreams" self skip: aString size negated! ! !PositionableStream methodsFor: 'positioning'! reset "Set the receiver's position to the beginning of the sequence of objects." position := 0! ! !PositionableStream methodsFor: 'positioning' stamp: 'sw 3/10/98 13:55'! resetContents "Set the position and limits to 0." position := 0. readLimit := 0! ! !PositionableStream methodsFor: 'positioning'! setToEnd "Set the position of the receiver to the end of the sequence of objects." position := readLimit! ! !PositionableStream methodsFor: 'positioning'! 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: 'positioning'! 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: '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: '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: 'public' stamp: 'di 6/13/97 12:00'! skipSeparators [self atEnd] whileFalse: [self next isSeparator ifFalse: [^ self position: self position-1]]! ! !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: 'testing'! atEnd "Primitive. Answer whether the receiver can access any more objects. Optional. See Object documentation whatIsAPrimitive." ^position >= readLimit! ! !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: '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: 'private' stamp: 'nice 11/22/2009 18:03'! collectionSpecies "Answer the species of collection into which the receiver can stream" ^collection species! ! !PositionableStream methodsFor: 'private'! on: aCollection collection := aCollection. readLimit := aCollection size. position := 0. self reset! ! !PositionableStream methodsFor: 'private'! 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: 'private'! setFrom: newStart to: newStop position := newStart - 1. readLimit := newStop! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PositionableStream class instanceVariableNames: ''! !PositionableStream class methodsFor: '*FuelTests' stamp: 'MartinDias 10/12/2011 18:35'! on: 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'! on: aCollection "Answer an instance of me, streaming over the elements of aCollection." ^self basicNew on: aCollection! ! !PositionableStream class methodsFor: 'instance creation'! 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)! ! FileSystemGuide subclass: #PostorderGuide instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Core-Implementation'! !PostorderGuide commentStamp: 'cwp 11/18/2009 12:16' prior: 0! 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 8/12/2011 18:18'! pushVisit: aReference self push: (Message selector: #visit: argument: aReference)! ! !PostorderGuide methodsFor: 'showing' stamp: 'cwp 11/16/2009 10:50'! show: aReference self pushTraverse: aReference entry. self whileNotDoneDo: [self pop sendTo: self ]! ! !PostorderGuide methodsFor: 'showing' stamp: 'cwp 11/16/2009 21:57'! traverse: anEntry self pushVisit: anEntry. anEntry isDirectory ifTrue: [anEntry reference entries reverseDo: [:ea | self pushTraverse: ea]]! ! !PostorderGuide methodsFor: 'showing' stamp: 'cwp 11/16/2009 10:50'! visit: anEntry anEntry isDirectory ifTrue: [visitor visitDirectory: anEntry] ifFalse: [visitor visitFile: anEntry] ! ! GuideTest subclass: #PostorderGuideTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Tests-Core'! !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' )! ! Object subclass: #Pragma instanceVariableNames: 'method keyword arguments' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Pragmas'! !Pragma commentStamp: '' prior: 0! 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: 'lr 1/20/2006 02:04'! method "Answer the compiled-method containing the pragma." ^ method! ! !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: '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: '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: '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: '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: '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/20/2006 02:10'! numArgs "Answer the number of arguments in the pragma." ^ self arguments size.! ! !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: 'comparing' stamp: 'eem 3/7/2009 11:54'! analogousCodeTo: anObject ^self class == anObject class and: [keyword == anObject keyword and: [arguments = anObject 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: 'initialization' stamp: 'lr 1/20/2006 00:53'! setArguments: anArray arguments := anArray! ! !Pragma methodsFor: 'initialization' stamp: 'lr 1/20/2006 00:53'! setKeyword: aSymbol keyword := aSymbol! ! !Pragma methodsFor: 'initialization' stamp: 'lr 1/19/2006 23:39'! setMethod: aCompiledMethod method := aCompiledMethod! ! !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: '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: '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: '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 methodsFor: 'testing' stamp: 'eem 11/29/2008 16:39'! hasLiteral: aLiteral ^keyword == aLiteral or: [arguments hasLiteral: aLiteral]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Pragma class instanceVariableNames: ''! !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/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) ].! ! !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 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 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/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: '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 00:34'! keyword: aSymbol arguments: anArray ^ self new setKeyword: aSymbol; 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 ].! ! PragmaAnnouncement subclass: #PragmaAdded instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Pragmas'! !PragmaAdded commentStamp: 'alain.plantec 10/20/2009 11:34' prior: 0! A PragmaAdded is announced by a PragamColllector when a method defined with an acceptable pragma according to the PragmaCollector filter is added. Instance Variables ! Announcement subclass: #PragmaAnnouncement instanceVariableNames: 'pragma' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Pragmas'! !PragmaAnnouncement commentStamp: 'alain.plantec 10/20/2009 11:34' prior: 0! 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 ^ pragma! ! !PragmaAnnouncement methodsFor: 'accessing' stamp: 'alain.plantec 9/18/2009 22:39'! pragma: aPragma pragma := aPragma! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PragmaAnnouncement class instanceVariableNames: ''! !PragmaAnnouncement class methodsFor: 'instance creation' stamp: 'alain.plantec 10/19/2009 10:47'! pragma: aPragma ^ self new pragma: aPragma! ! Object subclass: #PragmaCollector instanceVariableNames: 'announcer collected filter' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Pragmas-Collector'! !PragmaCollector commentStamp: 'AlainPlantec 11/28/2009 01:09' prior: 0! 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: 'accessing' stamp: 'alain.plantec 9/18/2009 15:26'! announcer ^ announcer! ! !PragmaCollector methodsFor: 'accessing' stamp: 'alain.plantec 10/20/2009 13:15'! collected ^ collected ifNil: [collected := OrderedCollection new] ! ! !PragmaCollector methodsFor: 'accessing' stamp: 'alain.plantec 10/19/2009 10:59'! filter ^ filter ifNil: [filter := [:prg | true]]! ! !PragmaCollector methodsFor: 'accessing' stamp: 'alain.plantec 10/19/2009 11:00'! filter: aOneArgValuable filter := aOneArgValuable! ! !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'! collect: aBlock ^ self collected collect: aBlock ! ! !PragmaCollector methodsFor: 'enumerating' stamp: 'alain.plantec 9/18/2009 15:26'! detect: aBlock ^ self collected detect: aBlock ifNone:[] ! ! !PragmaCollector methodsFor: 'enumerating' stamp: 'alain.plantec 9/18/2009 15:26'! do: aBlock self collected do: aBlock ! ! !PragmaCollector methodsFor: 'enumerating' stamp: 'alain.plantec 9/18/2009 15:26'! noneSatisfy: aBlock ^ self collected noneSatisfy: aBlock! ! !PragmaCollector methodsFor: 'enumerating' stamp: 'alain.plantec 9/18/2009 15:26'! reject: aBlock ^ self collected reject: aBlock ! ! !PragmaCollector methodsFor: 'enumerating' stamp: 'alain.plantec 9/18/2009 15:26'! select: aBlock ^ self collected select: aBlock ! ! !PragmaCollector methodsFor: 'initializing' stamp: 'alain.plantec 9/18/2009 15:26'! initialize super initialize. announcer := Announcer new. self installSystemNotifications! ! !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: '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: '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: 'subscription' stamp: 'alain.plantec 9/18/2009 15:26'! announce: anAnnouncement "see Announcements packages" self announcer ifNotNil: [announcer announce: anAnnouncement]! ! !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: 'subscription' stamp: 'alain.plantec 9/18/2009 15:26'! unsubscribe: anObject "see Announcements packages" self announcer unsubscribe: anObject ! ! !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: '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: '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: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:29'! installSystemNotifications "Allows myself to be kept up-to-date regarding system changes" 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: '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: 'system changes' stamp: 'EstebanLorenzano 8/3/2012 14:08'! noMoreNotifications "Do not receiver any system change notification anymore" SystemAnnouncer uniqueInstance unsubscribe: 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: '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: 'testing' stamp: 'alain.plantec 9/18/2009 15:26'! ifNotEmpty: aBlock self collected ifNotEmpty: aBlock! ! !PragmaCollector methodsFor: 'testing' stamp: 'alain.plantec 9/18/2009 15:26'! isEmpty ^ self collected isEmpty! ! !PragmaCollector methodsFor: 'testing' stamp: 'alain.plantec 9/18/2009 15:26'! isNotEmpty ^ self collected isNotEmpty! ! !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: 'updating' stamp: 'alain.plantec 10/19/2009 10:58'! keepPragma: aPragma ^ self filter value: aPragma ! ! !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: '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 class instanceVariableNames: ''! !PragmaCollector class methodsFor: 'instance creation' stamp: 'alain.plantec 10/19/2009 16:16'! filter: aOneArgValuable ^ self new 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]]]) ! ! Announcement subclass: #PragmaCollectorReset instanceVariableNames: 'collector' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Pragmas-Collector'! !PragmaCollectorReset commentStamp: 'alain.plantec 10/20/2009 11:14' prior: 0! 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: 'as yet unclassified' stamp: 'DanielAvivEstebanAllende 1/29/2013 10:45'! collector ^collector! ! !PragmaCollectorReset methodsFor: 'as yet unclassified' stamp: 'alain.plantec 10/19/2009 11:45'! collector: aCollector collector := aCollector! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PragmaCollectorReset class instanceVariableNames: ''! !PragmaCollectorReset class methodsFor: 'as yet unclassified' stamp: 'alain.plantec 10/19/2009 11:45'! collector: aCollector ^ self new collector: aCollector! ! Object subclass: #PragmaMenuAndShortcutRegistration instanceVariableNames: 'items currentRoot platform model' classVariableNames: '' poolDictionaries: '' category: 'MenuRegistration-Core'! !PragmaMenuAndShortcutRegistration commentStamp: '' prior: 0! A PragmaMenuAndShortcutRegistration is the list items holder! !PragmaMenuAndShortcutRegistration methodsFor: '*Nautilus' stamp: 'EstebanLorenzano 2/6/2013 14:35'! keyText: aString if: aBoolean aBoolean ifTrue: [ self keyText: aString ]! ! !PragmaMenuAndShortcutRegistration methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 22:36'! currentRoot ^ currentRoot! ! !PragmaMenuAndShortcutRegistration methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 22:37'! currentRoot: aMenuRegistration currentRoot := aMenuRegistration! ! !PragmaMenuAndShortcutRegistration methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 21:26'! enabled: aBoolean self currentItem enabled: aBoolean! ! !PragmaMenuAndShortcutRegistration methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 21:25'! items ^ items! ! !PragmaMenuAndShortcutRegistration methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 23:16'! model ^ model! ! !PragmaMenuAndShortcutRegistration methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 23:16'! model: aModel model := aModel.! ! !PragmaMenuAndShortcutRegistration methodsFor: 'initialization' stamp: 'SeanDeNigris 7/16/2012 12:36'! attachShortcutCategory: aSymbol to: aClass KMRepository default attachCategoryName: aSymbol to: aClass.! ! !PragmaMenuAndShortcutRegistration methodsFor: 'keymapping' stamp: 'BenjaminVanRyseghem 4/7/2012 20:47'! initialize "Initialization code for PragmaMenuAndShortcutRegistration" super initialize. items := OrderedCollection new.! ! !PragmaMenuAndShortcutRegistration methodsFor: 'keymapping protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 22:59'! category: aByteSymbol self currentItem category: aByteSymbol! ! !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: '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: '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: '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: 'keymapping protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 22:59'! default: aKMModifiedShortcut self currentItem default: aKMModifiedShortcut! ! !PragmaMenuAndShortcutRegistration methodsFor: 'keymapping protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 23:27'! description: aByteString self currentItem help: aByteString! ! !PragmaMenuAndShortcutRegistration methodsFor: 'keymapping protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 23:27'! do: aBlockClosure self currentItem action: aBlockClosure! ! !PragmaMenuAndShortcutRegistration methodsFor: 'keymapping protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 23:12'! platform: anArray anArray isEmpty ifTrue: [ platform := #all ] ifFalse: [ platform := anArray first ]! ! !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 21:17'! arguments: anArray self currentItem arguments: anArray! ! !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 20:48'! currentItem ^ items last! ! !PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 20:49'! enabledBlock: aBlock self currentItem enabledBlock: aBlock! ! !PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 23:00'! group: aSymbol self createNewItem. self currentItem group: aSymbol! ! !PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 20:49'! help: aString self currentItem help: aString ! ! !PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 20:49'! icon: anIcon self currentItem icon: anIcon! ! !PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 23:00'! item: aSymbol self createNewItem. self currentItem item: aSymbol! ! !PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: 'EstebanLorenzano 1/30/2013 16:47'! keyText: aString self currentItem keyText: aString! ! !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 21:37'! order: anInteger self currentItem order: anInteger ! ! !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: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 21:06'! selector: aSelector self currentItem selector: aSelector! ! !PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 21:19'! target: aSymbol self currentItem target: aSymbol ! ! !PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 21:43'! with: aBlock self currentItem with: aBlock! ! !PragmaMenuAndShortcutRegistration methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 20:49'! withSeparatorAfter self currentItem withSeparatorAfter! ! !PragmaMenuAndShortcutRegistration methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/7/2012 20:50'! itemClass ^ PragmaMenuAndShortcutRegistrationItem! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PragmaMenuAndShortcutRegistration class instanceVariableNames: ''! !PragmaMenuAndShortcutRegistration class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 4/7/2012 23:16'! model: aModel ^ self new model: aModel; yourself! ! Object subclass: #PragmaMenuAndShortcutRegistrationItem instanceVariableNames: 'item action parent order enabledBlock label help icon selector arguments withSeparatorAfter target enabled group with precondition shortcut platform default category shortcutName keyText' classVariableNames: '' poolDictionaries: '' category: 'MenuRegistration-Core'! !PragmaMenuAndShortcutRegistrationItem commentStamp: '' prior: 0! A PragmaMenuAndShortcutRegistrationItem is an item of a menu or keymap! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 21:27'! action ^ action! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 21:29'! arguments ^ arguments! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 23:11'! default ^ default! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 23:43'! enabled ^ enabled! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 21:26'! enabled: aBoolean enabled := aBoolean! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 23:43'! enabledBlock ^ enabledBlock! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 21:47'! group ^ group! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 21:28'! help ^ help! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 21:28'! icon ^ icon! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 21:29'! isWithSeparatorAfter ^ withSeparatorAfter! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 21:27'! item ^ item! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'EstebanLorenzano 1/30/2013 16:48'! keyText ^keyText! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 21:28'! label ^ label! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 21:34'! order ^ order! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 21:34'! parent ^ parent! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 23:11'! platform ^ platform! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 21:29'! selector ^ selector! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 23:10'! shortcut ^ shortcut! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 21:29'! target ^ target! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/7/2012 21:48'! with ^ with! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 4/7/2012 20:50'! initialize "Initialization code for PragmaMenuAndShortcutRegistrationItem" super initialize. withSeparatorAfter := false.! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 20:47'! action: aBlock action := aBlock! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 21:17'! arguments: anArray arguments := anArray! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 20:47'! enabledBlock: aBlock enabledBlock := aBlock! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 21:41'! group: aSymbol group := aSymbol! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 20:47'! help: aString help := aString ! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 20:47'! icon: anIcon icon := anIcon! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 20:47'! item: aSymbol item := 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 20:47'! label: aString label := aString! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 21:37'! order: anInteger order := anInteger! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 20:47'! parent: aSymbol parent := aSymbol ! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 21:45'! precondition: aBlock precondition := aBlock ! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 21:07'! selector: aSymbol selector := aSymbol ! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 21:19'! target: aSymbol target := aSymbol ! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 21:52'! with: aBlock with := aBlock! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'menu protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 21:19'! withSeparatorAfter withSeparatorAfter := true! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 23:11'! category ^ category! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 23:11'! category: aByteSymbol category := aByteSymbol! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 23:11'! default: aKMModifiedShortcut default := aKMModifiedShortcut ! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 23:11'! platform: aSymbol platform := aSymbol! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/7/2012 23:10'! shortcut: aSymbol shortcut := aSymbol! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'protocol' stamp: 'GuillermoPolito 9/24/2012 11:56'! shortcutName ^shortcutName! ! !PragmaMenuAndShortcutRegistrationItem methodsFor: 'protocol' stamp: 'GuillermoPolito 9/24/2012 11:56'! shortcutName: aSymbol shortcutName := aSymbol! ! MenuRegistration subclass: #PragmaMenuBuilder instanceVariableNames: 'pragmaKeywords model pragmaCollector currentRoot' classVariableNames: '' poolDictionaries: '' category: 'MenuRegistration-Core'! !PragmaMenuBuilder commentStamp: 'AlainPlantec 11/16/2010 19:48' prior: 0! 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: 'accessing' stamp: 'AlainPlantec 2/13/2010 12:52'! builder ^ self! ! !PragmaMenuBuilder methodsFor: 'accessing' stamp: 'AlainPlantec 2/13/2010 12:57'! itemReceiver ^ model! ! !PragmaMenuBuilder methodsFor: 'accessing' stamp: 'AlainPlantec 2/13/2010 12:40'! model ^ model! ! !PragmaMenuBuilder methodsFor: 'accessing' stamp: 'AlainPlantec 2/13/2010 12:40'! model: anObject model := anObject! ! !PragmaMenuBuilder methodsFor: 'accessing' stamp: 'AlainPlantec 11/16/2010 20:53'! pragmaKeyword "Deprecated" ^ pragmaKeywords isEmptyOrNil ifFalse: [pragmaKeywords first]! ! !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 11/16/2010 19:37'! pragmaKeywords "Returns the pragma keyword used to select pragmas (see #pragmaCollector)" ^ pragmaKeywords ! ! !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: 'initialize-release' stamp: 'AlainPlantec 11/16/2010 19:55'! initialize super initialize. isGroup := true. currentRoot := self. pragmaKeywords := OrderedCollection new. ! ! !PragmaMenuBuilder methodsFor: 'initialize-release' stamp: 'AlainPlantec 2/15/2010 11:21'! release self pragmaCollector unsubscribe: self. pragmaCollector := nil. model := nil. super release ! ! !PragmaMenuBuilder methodsFor: 'menu building' stamp: 'BenjaminVanRyseghem 4/7/2012 22:01'! 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 ifNil: [ itemList := OrderedCollection new. self collectRegistrations. self arrangeRegistrations. self sortRegistrations]! ! !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: 'menu building' stamp: 'AlainPlantec 2/16/2010 16:58'! newSubItem | reg | reg := MenuRegistration owner: currentRoot. currentRoot addItem: reg. ^ reg! ! !PragmaMenuBuilder methodsFor: 'public menu building' stamp: 'StephaneDucasse 6/5/2011 22:47'! menu "returns a MenuMorph build from my menuSpec" ^ self menuSpec asMenuMorph! ! !PragmaMenuBuilder methodsFor: 'public menu building' stamp: 'StephaneDucasse 6/5/2011 22:47'! menuAt: aName "returns a MenuMorph from my menuSpec" ^ (self menuSpecAt: aName) asMenuMorph! ! !PragmaMenuBuilder methodsFor: 'public menu building' stamp: 'StephaneDucasse 6/5/2011 22:48'! menuEntitled: aTitle "returns a MenuMorph build from my menuSpec" ^ (self menuSpec label: aTitle) asMenuMorph! ! !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: '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: 'registrations handling' stamp: 'AlainPlantec 2/12/2010 14:34'! allMisplacedItems | misplaced | self collectMisplacedItemsIn: (misplaced := OrderedCollection new). ^ misplaced ! ! !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: '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 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: '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 class instanceVariableNames: ''! !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: 'AlainPlantec 11/16/2010 19:54'! 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; buildTree! ! !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: 'private' stamp: 'MarcusDenker 5/31/2011 15:33'! 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] ifNone:[]) "No order has been set - do not touch anything, the list order is ok" ifNil: [list] ifNotNil: [ :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]]! ! PragmaAnnouncement subclass: #PragmaRemoved instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Pragmas'! !PragmaRemoved commentStamp: 'alain.plantec 10/20/2009 11:33' prior: 0! A PragmaRemoved is announced by a PragamColllector when a method defined with an acceptable pragma according to the PragmaCollector filter is removed. Instance Variables ! Object subclass: #PragmaSetting instanceVariableNames: 'precondition target targetSelector name label description order icon ordering dialog allowedInStyle' classVariableNames: '' poolDictionaries: '' category: 'System-Settings-Core'! !PragmaSetting commentStamp: 'AlainPlantec 1/3/2011 10:54' prior: 0! 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: '*StartupPreferences' stamp: 'BenjaminVanRyseghem 8/1/2012 15:44'! exportSettingAction ^ nil! ! !PragmaSetting methodsFor: '*StartupPreferences' stamp: 'BenjaminVanRyseghem 2/5/2013 15:17'! isExportable ^ false! ! !PragmaSetting methodsFor: 'accessing' stamp: 'AlainPlantec 1/29/2010 13:58'! allowedInStyle ^ allowedInStyle ifNil: [allowedInStyle := self hasValue]! ! !PragmaSetting methodsFor: 'accessing' stamp: 'AlainPlantec 11/13/2009 15:52'! description "Answer the value of description" ^ description ifNil: [description := '']! ! !PragmaSetting methodsFor: 'accessing' stamp: 'alain.plantec 3/25/2009 19:36'! description: aText "Set the value of description" description := aText! ! !PragmaSetting methodsFor: 'accessing' stamp: 'AlainPlantec 1/29/2010 14:02'! hasDefault ^ false! ! !PragmaSetting methodsFor: 'accessing' stamp: 'AlainPlantec 1/29/2010 14:03'! hasEditableList ^ false! ! !PragmaSetting methodsFor: 'accessing' stamp: 'AlainPlantec 1/29/2010 14:03'! hasValue ^ false! ! !PragmaSetting methodsFor: 'accessing' stamp: 'AlainPlantec 11/23/2009 14:11'! label ^ label ifNil: [self name] ifNotNil: [label value]! ! !PragmaSetting methodsFor: 'accessing' stamp: 'AlainPlantec 11/23/2009 14:11'! label: aStringOrBlockOrMessageSend label := aStringOrBlockOrMessageSend! ! !PragmaSetting methodsFor: 'accessing' stamp: 'alain.plantec 10/18/2009 12:40'! name ^ name ifNil: [super name] ifNotNil: [name value]! ! !PragmaSetting methodsFor: 'accessing' stamp: 'alain.plantec 10/18/2009 12:39'! name: aNameOrBlockOrMessageSend name := aNameOrBlockOrMessageSend! ! !PragmaSetting methodsFor: 'accessing' stamp: 'alain.plantec 4/2/2009 11:59'! order ^ order! ! !PragmaSetting methodsFor: 'accessing' stamp: 'alain.plantec 4/2/2009 10:53'! order: aNumber order := aNumber! ! !PragmaSetting methodsFor: 'accessing' stamp: 'AlainPlantec 12/5/2009 08:42'! precondition ^ precondition ifNil: [precondition := [true]].! ! !PragmaSetting methodsFor: 'accessing' stamp: 'AlainPlantec 12/5/2009 08:43'! precondition: aValuable precondition := aValuable! ! !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 10:47'! settingReceiver ^ self targetSelector ifNil: [self realTarget] ifNotNil: [self realTarget perform: self targetSelector]! ! !PragmaSetting methodsFor: 'accessing' stamp: 'AlainPlantec 12/2/2009 16:40'! target ^ target! ! !PragmaSetting methodsFor: 'accessing' stamp: 'AlainPlantec 11/26/2009 21:15'! target: anObject target := anObject! ! !PragmaSetting methodsFor: 'accessing' stamp: 'AlainPlantec 11/26/2009 21:15'! targetSelector ^ targetSelector! ! !PragmaSetting methodsFor: 'accessing' stamp: 'AlainPlantec 11/26/2009 21:16'! targetSelector: aSelector targetSelector := aSelector! ! !PragmaSetting methodsFor: 'comparing' stamp: 'alain.plantec 4/20/2009 15:18'! = other ^ self species = other species and: [self name = other name]! ! !PragmaSetting methodsFor: 'comparing' stamp: 'alain.plantec 4/20/2009 15:19'! hash ^ self species hash bitXor: self name hash ! ! !PragmaSetting methodsFor: 'user interface' stamp: 'alain.plantec 3/11/2009 15:38'! asString ^ self name! ! !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: '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'! defaultIcon ^ self theme smallConfigurationIcon! ! !PragmaSetting methodsFor: 'user interface' stamp: 'AlainPlantec 1/30/2010 08:07'! dialog ^ dialog! ! !PragmaSetting methodsFor: 'user interface' stamp: 'AlainPlantec 1/30/2010 07:59'! dialog: aValuable dialog := aValuable! ! !PragmaSetting methodsFor: 'user interface' stamp: 'alain.plantec 3/12/2009 12:58'! enabled ^ true! ! !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: 'user interface' stamp: 'AlainPlantec 1/29/2010 14:12'! getFont ^ FontChooser openWithWindowTitle: 'Font for ' , self name for: self setSelector: #realValue: getSelector: #realValue ! ! !PragmaSetting methodsFor: 'user interface' stamp: 'AlainPlantec 11/25/2009 08:27'! icon ^ icon ifNil: [icon := self defaultIcon]! ! !PragmaSetting methodsFor: 'user interface' stamp: 'AlainPlantec 11/23/2009 22:18'! icon: aForm icon := aForm! ! !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: '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: 'user interface' stamp: 'AlainPlantec 2/11/2011 14:09'! labelMorphFor: aContainer ^ StringMorph contents: (aContainer model viewedLabelOfSetting: self)! ! !PragmaSetting methodsFor: 'user interface' stamp: 'AlainPlantec 11/25/2009 08:18'! noOrdering ordering := false! ! !PragmaSetting methodsFor: 'user interface' stamp: 'AlainPlantec 1/29/2010 14:04'! notInStyle allowedInStyle := false! ! !PragmaSetting methodsFor: 'user interface' stamp: 'AlainPlantec 11/25/2009 08:18'! ordering ^ ordering ifNil: [ordering := true]! ! !PragmaSetting methodsFor: 'user interface' stamp: 'FernandoOlivero 4/12/2011 10:13'! theme ^ UITheme current ! ! TestCase subclass: #PragmaTest instanceVariableNames: 'atPragma anotherAtPragma yetAnotherAtPragma atPutPragma' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Pragmas'! !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). ! ! !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: '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.! ! PragmaAnnouncement subclass: #PragmaUpdated instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Pragmas'! !PragmaUpdated commentStamp: 'alain.plantec 10/20/2009 11:33' prior: 0! 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 ! SystemWindow subclass: #PreDebugWindow instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tools-Debugger'! !PreDebugWindow commentStamp: 'LaurentLaffont 3/15/2011 20:51' prior: 0! I am the window that shows up when the debugger is launched. I show you the first lines of the stack trace that caused my apparition, and buttons to allow you to: - resume the execution - abandon the execution - debug this error - create the method if it is MessageNotUnderstood exception To see me, evaluate: 2/0! !PreDebugWindow methodsFor: 'as yet unclassified' stamp: 'nk 2/12/2003 23:00'! createMethod model createMethod! ! !PreDebugWindow methodsFor: 'as yet unclassified' stamp: 'sw 10/15/1998 13:00'! debug model debug! ! !PreDebugWindow methodsFor: 'as yet unclassified' stamp: 'sw 10/15/1998 13:00'! proceed model proceed! ! !PreDebugWindow methodsFor: 'as yet unclassified' stamp: 'tbn 7/29/2010 21:30'! setBalloonTextForCloseBox closeBox ifNotNil: [closeBox setBalloonText: 'Abandon this execution by closing this window' translated]. ! ! !PreDebugWindow methodsFor: 'as yet unclassified' stamp: 'mir 11/10/2003 15:15'! storeLog model storeLog! ! !PreDebugWindow methodsFor: 'label' stamp: 'AlainPlantec 12/1/2009 22:50'! setLabelWidgetAllowance ^ labelWidgetAllowance := CodeHolder optionalButtons ifTrue: [super setLabelWidgetAllowance] ifFalse: [180]! ! Object subclass: #Preferences instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Compatibility'! !Preferences commentStamp: 'MarcusDenker 6/12/2011 22:09' prior: 0! An empty class to help people loading their code when it contains sends to methods of the old Preferences.! Object subclass: #PreferencesHandler instanceVariableNames: 'firstLink actions' classVariableNames: '' poolDictionaries: '' category: 'StartupPreferences'! !PreferencesHandler commentStamp: '' prior: 0! I am the one which manage the links of the chain of responsibilites to retreive the good preference file! !PreferencesHandler methodsFor: 'actions' stamp: 'SeanDeNigris 8/4/2012 10:48'! buildActionList "All found files will be executed." | directories | directories := OrderedCollection new. directories add: [ self lookInGeneralPreferencesFolder ]. directories add: [ self lookInPreferencesVersionFolder ]. directories add: [ self lookInImageFolder ]. ^ directories! ! !PreferencesHandler methodsFor: 'actions' stamp: 'SeanDeNigris 8/4/2012 10:53'! lookInGeneralPreferencesFolder ^ self lookInFolder: StartupLoader preferencesGeneralFolder forFilesMatching: '*.st'.! ! !PreferencesHandler methodsFor: 'actions' stamp: 'SeanDeNigris 8/4/2012 11:26'! lookInImageFolder ^ self lookInFolder: FileSystem workingDirectory forFilesMatching: StartupLoader startupScriptName.! ! !PreferencesHandler methodsFor: 'actions' stamp: 'SeanDeNigris 8/4/2012 10:53'! lookInPreferencesVersionFolder ^ self lookInFolder: StartupLoader preferencesVersionFolder forFilesMatching: '*.st'.! ! !PreferencesHandler methodsFor: 'actions' stamp: 'SeanDeNigris 8/4/2012 10:53'! perform | results | results := OrderedCollection new. actions do: [:each | each value ifNotNil: [ :res | results addAll: res ] ]. ^ results ! ! !PreferencesHandler methodsFor: 'initialization' stamp: 'SeanDeNigris 8/4/2012 10:48'! initialize super initialize. actions := self buildActionList.! ! !PreferencesHandler methodsFor: 'private' stamp: 'SeanDeNigris 7/8/2012 11:56'! lookInFolder: folder | result | self flag: 'I should be #lookInFolder:forFilesMatching:, so that #lookInImageFolder can delegate to me, like the other two lookup methods'. result := OrderedCollection new. folder exists ifFalse: [ ^ nil ]. "To filter resources files such as .DS_Store" folder fileNames do: [:name | name first = $. ifFalse: [ result add: (folder / name)]]. ^ result isEmpty ifTrue: [ nil ] ifFalse: [ result ]! ! !PreferencesHandler methodsFor: 'private' stamp: 'SeanDeNigris 8/4/2012 10:56'! lookInFolder: folder forFilesMatching: pattern | result files | result := OrderedCollection new. folder exists ifFalse: [ ^ nil ]. files := folder filesMatching: pattern. files do: [ :e | result add: e ]. ^ result isEmpty ifTrue: [ nil ] ifFalse: [ result ]! ! FileSystemGuide subclass: #PreorderGuide instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Core-Implementation'! !PreorderGuide commentStamp: 'cwp 11/18/2009 12:18' prior: 0! 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 8/12/2011 18:19'! pushAll: aCollection aCollection reverseDo: [ :ea | work add: ea ]! ! !PreorderGuide methodsFor: 'showing' stamp: 'cwp 11/16/2009 10:47'! show: aReference self push: aReference entry. self whileNotDoneDo: [| entry | entry := self pop. entry isFile ifTrue: [visitor visitFile: entry] ifFalse: [visitor visitDirectory: entry. self pushAll: entry reference entries]]! ! GuideTest subclass: #PreorderGuideTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'FileSystem-Tests-Core'! !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' )! ! TextDiffBuilder subclass: #PrettyTextDiffBuilder instanceVariableNames: 'sourceClass' classVariableNames: '' poolDictionaries: '' category: 'System-FilePackage'! !PrettyTextDiffBuilder commentStamp: 'HenrikSperreJohansen 5/21/2010 01:42' prior: 0! 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: 'SvenVanCaekenberghe 1/8/2012 14:47'! split: aString | formatted trimmed | trimmed := aString asString trimBoth. trimmed isEmpty ifTrue: [ ^super split: '' ]. formatted := [ sourceClass prettyPrinterClass format: trimmed in: sourceClass notifying: nil] on: Error do: [ :ex | trimmed ]. ^ super split: formatted! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PrettyTextDiffBuilder class instanceVariableNames: ''! !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 ! ! SelectorException subclass: #PrimitiveFailed instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Exceptions'! !PrimitiveFailed commentStamp: 'SvenVanCaekenberghe 4/21/2011 12:31' prior: 0! 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' ]! ! CommandLineHandler subclass: #PrintVersionCommandLineHandler instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-CommandLine'! !PrintVersionCommandLineHandler commentStamp: '' prior: 0! Usage: printVersion 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: $PHAROVM Foo.image printVersion result will be something like: [version] 2.0 #20401! !PrintVersionCommandLineHandler methodsFor: 'actions' stamp: 'MarcusDenker 11/16/2012 14:51'! printVersion FileStream stdout nextPutAll: '[version] '; nextPutAll: SystemVersion current major asString; nextPutAll: '.'; nextPutAll: SystemVersion current minor asString; nextPutAll: ' #' ; nextPutAll: SystemVersion current highestUpdate asString; cr.! ! !PrintVersionCommandLineHandler methodsFor: 'activation' stamp: 'MarcusDenker 11/16/2012 14:55'! activate self activateHelp. self printVersion. self quit. ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! PrintVersionCommandLineHandler class instanceVariableNames: ''! !PrintVersionCommandLineHandler class methodsFor: 'accessing' stamp: 'MarcusDenker 11/16/2012 14:50'! commandName ^ 'printVersion'! ! !PrintVersionCommandLineHandler class methodsFor: 'accessing' stamp: 'MarcusDenker 11/16/2012 14:50'! description ^ 'Print image version'! ! MessageDialogWindow subclass: #ProceedDialogWindow instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Windows'! !ProceedDialogWindow commentStamp: 'gvc 5/18/2007 12:22' prior: 0! Yes/no dialog. Test result as to whether the dialog is cancelled (no) or not (yes).! !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 5/18/2007 10:30'! icon "Answer an icon for the receiver." ^self theme questionIcon! ! !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/10/2007 13:50'! newButtons "Answer new buttons as appropriate." ^{self newOKButton. self newCancelButton isDefault: true}! ! !ProceedDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/11/2007 17:34'! no "Answer no." self cancel! ! !ProceedDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/11/2007 17:34'! yes "Answer yes." self ok! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ProceedDialogWindow class instanceVariableNames: ''! !ProceedDialogWindow class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'FernandoOlivero 4/12/2011 10:13'! taskbarIcon "Answer the icon for the receiver in a task bar." ^self theme smallQuestionIcon! ! Link subclass: #Process instanceVariableNames: 'suspendedContext priority myList threadId errorHandler name env' classVariableNames: 'PSKeys PSKeysSema' poolDictionaries: '' category: 'Kernel-Processes'! !Process commentStamp: 'IgorStasenko 11/7/2011 11:25' prior: 0! 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 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: 'accessing' stamp: 'ajh 1/27/2003 18:39'! copyStack ^ self copy install: suspendedContext copyStack! ! !Process methodsFor: 'accessing' stamp: 'ajh 1/24/2003 19:44'! isActiveProcess ^ self == Processor activeProcess! ! !Process methodsFor: 'accessing' stamp: 'dkh 4/25/2009 13:34'! isSuspended ^myList isNil or: [ myList isEmpty ]! ! !Process methodsFor: 'accessing' stamp: 'bgf 12/31/2008 11:56'! 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 pc > suspendedContext startpc]]! ! !Process methodsFor: 'accessing' stamp: 'MartinMcClure 1/10/2010 17:54'! name ^name ifNil: [ self hash asString forceTo: 10 paddingStartWith: $ ]! ! !Process methodsFor: 'accessing' stamp: 'svp 12/5/2002 14:42'! name: aString name := aString! ! !Process methodsFor: 'accessing'! priority "Answer the priority of the receiver." ^priority! ! !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'! suspendedContext "Answer the context the receiver has suspended." ^suspendedContext! ! !Process methodsFor: 'accessing'! suspendingList "Answer the list on which the receiver has been suspended." ^myList! ! !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: '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 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: '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: '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: '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: '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/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 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'! 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 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: '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: '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: '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: '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 suspended state' stamp: 'ajh 1/24/2003 10:17'! step ^ suspendedContext := suspendedContext step! ! !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 1/23/2003 22:06'! stepToCallee "Step until top context changes" | ctxt | ctxt := suspendedContext. [ctxt == suspendedContext] whileTrue: [ suspendedContext := suspendedContext step]. ^ suspendedContext! ! !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: 'changing suspended state' stamp: 'ajh 1/24/2003 10:17'! stepToSendOrReturn ^ suspendedContext := suspendedContext stepToSendOrReturn! ! !Process methodsFor: 'debugging' stamp: 'CamilloBruni 9/21/2012 13:52'! debug ^ self debugWithTitle: 'Debug'.! ! !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: '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: '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 methodsFor: 'printing' stamp: 'nk 10/28/2000 07:33'! browserPrintString ^self browserPrintStringWith: suspendedContext! ! !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: '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: 'printing'! printOn: aStream super printOn: aStream. aStream nextPutAll: ' in '. suspendedContext printOn: aStream! ! !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: '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: '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: '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: '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: 'private' stamp: 'GiovanniCorriga 8/30/2009 15:40'! environmentKeyNotFound self error: 'Environment key not found'! ! !Process methodsFor: 'private'! suspendedContext: aContext suspendedContext := aContext! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Process class instanceVariableNames: ''! !Process class methodsFor: 'instance creation'! 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! ! !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! ! Model subclass: #ProcessBrowser instanceVariableNames: 'selectedProcess selectedContext methodText processList processListIndex stackList stackListIndex selectedClass selectedSelector searchString autoUpdateProcess deferredMessageRecipient lastUpdate startedCPUWatcher keyEventsDict' classVariableNames: 'SuspendedProcesses WellKnownProcesses' poolDictionaries: '' category: 'Tools-Process Browser'! !ProcessBrowser commentStamp: '' prior: 0! 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: '*Shout-Styling' stamp: 'AlainPlantec 8/27/2011 00:03'! shoutAboutToStyle: aPluggableShoutMorphOrView selectedContext ifNil: [^false]. aPluggableShoutMorphOrView classOrMetaClass: self selectedClass. ^ true ! ! !ProcessBrowser methodsFor: 'accessing' stamp: 'JuanVuletich 10/26/2010 14:01'! deferredMessageRecipient: anObject deferredMessageRecipient := anObject! ! !ProcessBrowser methodsFor: 'accessing'! processList ^ processList! ! !ProcessBrowser methodsFor: 'accessing'! processListIndex ^ processListIndex! ! !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: '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: '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: 'accessing' stamp: 'EstebanLorenzano 1/31/2013 18:20'! selectedProcess ^selectedProcess! ! !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: 'accessing'! stackList ^ stackList! ! !ProcessBrowser methodsFor: 'accessing'! stackListIndex ^ stackListIndex! ! !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: 'accessing' stamp: 'nk 10/28/2000 08:36'! text ^methodText! ! !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: 'initialization' stamp: 'JuanVuletich 10/26/2010 14:05'! mayBeStartCPUWatcher startedCPUWatcher ifTrue: [ self setUpdateCallbackAfter: 7 ]. ! ! !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: '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: '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: '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: '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 actions' stamp: 'AndyKellens 6/11/2010 14:15'! inspectPointers | tc pointers | selectedProcess ifNil: [^self]. tc := thisContext. pointers := selectedProcess pointersToExcept: { self processList. tc. self}. pointers isEmpty ifTrue: [^self]. OrderedCollectionInspector openOn: pointers withEvalPane: false withLabel: '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: '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: 'process actions' stamp: 'nk 3/8/2001 13:23'! resumeProcess selectedProcess ifNil: [^ self]. self class resumeProcess: selectedProcess. self updateProcessList! ! !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: '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 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: 'process actions' stamp: 'nk 10/29/2000 08:56'! wasProcessSuspendedByProcessBrowser: aProcess ^self class suspendedProcesses includesKey: aProcess! ! !ProcessBrowser methodsFor: 'process list' stamp: 'nk 10/27/2000 09:24'! exploreProcess selectedProcess explore! ! !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: 'process list'! inspectProcess selectedProcess inspect! ! !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: '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: '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: 'process list' stamp: 'sd 11/20/2005 21:27'! prettyNameForProcess: aProcess | nameAndRules | aProcess ifNil: [ ^'' ]. nameAndRules := self nameAndRulesFor: aProcess. ^ aProcess browserPrintStringWith: nameAndRules first! ! !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: 'process list' stamp: 'EstebanLorenzano 1/31/2013 19:25'! processListMenu: menu ^menu addAllFromPragma: 'processBrowserProcessListMenu' target: self! ! !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 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: 'IgorStasenko 4/26/2011 15:35'! browseContext selectedContext ifNil: [^ self]. Smalltalk tools browser newOnClass: self selectedClass selector: self selectedSelector! ! !ProcessBrowser methodsFor: 'stack list' stamp: 'sd 11/20/2005 21:27'! changeStackListTo: aCollection stackList := aCollection. self changed: #stackNameList. self stackListIndex: 0! ! !ProcessBrowser methodsFor: 'stack list' stamp: 'nk 10/27/2000 09:28'! exploreContext selectedContext explore! ! !ProcessBrowser methodsFor: 'stack list' stamp: 'nk 10/27/2000 09:41'! exploreReceiver selectedContext ifNotNil: [ selectedContext receiver explore ]! ! !ProcessBrowser methodsFor: 'stack list' stamp: 'nk 7/8/2000 20:23'! inspectContext selectedContext inspect! ! !ProcessBrowser methodsFor: 'stack list' stamp: 'nk 10/27/2000 09:41'! inspectReceiver selectedContext ifNotNil: [selectedContext receiver inspect]! ! !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: 'nk 10/28/2000 12:13'! moreStack self updateStackList: 2000! ! !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: 'stack list' stamp: 'EstebanLorenzano 1/31/2013 19:25'! stackListMenu: aMenu selectedContext ifNil: [^ aMenu]. ^aMenu addAllFromPragma: 'processBrowserStackListMenu' target: self! ! !ProcessBrowser methodsFor: 'stack list' stamp: 'nk 10/28/2000 16:18'! stackNameList ^ stackList ifNil: [#()] ifNotNil: [stackList collect: [:each | each asString]]! ! !ProcessBrowser methodsFor: 'stack list' stamp: 'nk 7/8/2000 20:24'! updateStackList self updateStackList: 20! ! !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: 'updating' stamp: 'nk 10/28/2000 21:48'! isAutoUpdating ^autoUpdateProcess notNil and: [ autoUpdateProcess isSuspended not ]! ! !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: 'updating' stamp: 'sd 11/20/2005 21:27'! setUpdateCallbackAfter: seconds deferredMessageRecipient ifNotNil: [ | d | d := Delay forSeconds: seconds. [ d wait. d := nil. deferredMessageRecipient addDeferredUIMessage: [self updateProcessList] ] fork ]! ! !ProcessBrowser methodsFor: 'updating' stamp: 'sd 11/20/2005 21:27'! startAutoUpdate self isAutoUpdatingPaused ifTrue: [ ^autoUpdateProcess resume ]. self isAutoUpdating ifFalse: [| delay | delay := Delay forSeconds: 2. autoUpdateProcess := [[self hasView] whileTrue: [delay wait. deferredMessageRecipient ifNotNil: [ deferredMessageRecipient addDeferredUIMessage: [self updateProcessList]] ifNil: [ self updateProcessList ]]. autoUpdateProcess := nil] fork]. self updateProcessList! ! !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: 'views' stamp: 'nk 10/28/2000 11:44'! hasView ^self dependents isEmptyOrNil not! ! !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: '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 class instanceVariableNames: ''! !ProcessBrowser class methodsFor: '*Polymorph-TaskbarIcons' stamp: 'FernandoOlivero 4/12/2011 10:28'! theme ^ UITheme current ! ! !ProcessBrowser class methodsFor: '*famfam-icons-extensions' stamp: 'EstebanLorenzano 4/26/2012 14:05'! taskbarIcon "Answer the icon for the receiver in a task bar." ^self theme iconNamed: #processBrowserIcon! ! !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: '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: '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: '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: 'alain.plantec 6/1/2008 19:06'! 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. WorldState addDeferredUIMessage: [ self dumpTallyOnTranscript: tally ]. ] fork.! ! !ProcessBrowser class methodsFor: 'initialization' stamp: 'janniklaval 2/10/2011 12:09'! cleanUp "Remove terminated processes from my suspended list" self suspendedProcesses keys do: [:ea | ea isTerminated ifTrue: [self suspendedProcesses removeKey: ea]]! ! !ProcessBrowser class methodsFor: 'initialization' stamp: 'MarcusDenker 5/20/2011 08:32'! initialize "ProcessBrowser initialize" SuspendedProcesses ifNil: [ SuspendedProcesses := IdentityDictionary new ]. self registerWellKnownProcesses! ! !ProcessBrowser class methodsFor: 'initialization' stamp: 'StephaneDucasse 5/18/2012 18:20'! 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: 'the low space watcher' allowStop: false allowDebug: false. self registerWellKnownProcess: [ WeakArray runningFinalizationProcess ] label: 'the WeakArray finalization process' allowStop: false allowDebug: false. self registerWellKnownProcess: [ Processor backgroundProcess ] label: 'the idle process' allowStop: false allowDebug: false. self registerWellKnownProcess: [ InputEventFetcher default fetcherProcess ] label: 'Input event fetcher process' allowStop: false allowDebug: false. self registerWellKnownProcess: [ UIManager default uiProcess ] label: 'the Morphic UI process' 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: 'Delay scheduling process' allowStop: false allowDebug: false! ! !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: '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: '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: 'process control' stamp: 'nk 3/8/2001 17:09'! debugProcess: aProcess self resumeProcess: aProcess. aProcess debugWithTitle: 'Interrupted from the Process Browser'. ! ! !ProcessBrowser class methodsFor: 'process control' stamp: 'JuanVuletich 11/1/2010 10:13'! isUIProcess: aProcess ^ aProcess == UIManager default uiProcess! ! !ProcessBrowser class methodsFor: 'process control' stamp: 'StephaneDucasse 5/18/2012 18:22'! nameAndRulesFor: aProcess "Answer a nickname and two flags: allow-stop, and allow-debug" WellKnownProcesses do: [:blockAndRules | blockAndRules key value == aProcess ifTrue: [ ^ blockAndRules value value ]. ]. ^ {aProcess suspendedContext asString. true. true}! ! !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: '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: '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: '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: '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: 'process control' stamp: 'nk 3/8/2001 13:25'! terminateProcess: aProcess aProcess ifNotNil: [ self suspendedProcesses removeKey: aProcess ifAbsent: []. aProcess terminate ]. ! ! !ProcessBrowser class methodsFor: 'process control' stamp: 'sd 11/20/2005 21:28'! 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" | entry | entry := WellKnownProcesses detect: [:e | e key value == aProcess] ifNone: [^ self]. WellKnownProcesses remove: entry! ! !ProcessBrowser class methodsFor: 'process control' stamp: 'nk 3/8/2001 13:26'! wasProcessSuspendedByProcessBrowser: aProcess ^self suspendedProcesses includesKey: aProcess! ! !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: 'world menu' stamp: 'AlainPlantec 2/18/2010 11:20'! menuCommandOn: aBuilder (aBuilder item: #'Process Browser') parent: #Tools; action:[self open]; icon: self taskbarIcon.! ! ProcessSpecificVariable subclass: #ProcessLocalVariable instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Processes'! !ProcessLocalVariable commentStamp: 'mvl 3/13/2007 12:28' prior: 0! My subclasses have values specific to the active process. They can be read with #value and set with #value:! !ProcessLocalVariable methodsFor: 'as yet unclassified' stamp: 'IgorStasenko 11/7/2011 11:20'! value: anObject Processor activeProcess psValueAt: index put: anObject! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ProcessLocalVariable class instanceVariableNames: ''! !ProcessLocalVariable class methodsFor: 'accessing' stamp: 'IgorStasenko 11/2/2011 18:41'! value: anObject ^ self soleInstance value: anObject! ! TestCase subclass: #ProcessSpecificTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Processes'! !ProcessSpecificTest commentStamp: 'mvl 3/13/2007 13:52' prior: 0! A ProcessSpecificTest is a test case for process local and dynamic variables. ! !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 14:13'! checkLocal: value self assert: TestLocalVariable 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.! ! !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 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. ! ! Object subclass: #ProcessSpecificVariable instanceVariableNames: 'index' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Processes'! !ProcessSpecificVariable commentStamp: 'mvl 3/13/2007 13:53' prior: 0! 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 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/7/2011 11:18'! index: anInteger index := anInteger! ! !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:53'! valueOrNil "a faster version, which doesn't using ifAbsent: to avoid using block closure" ^ Processor activeProcess psValueAt: index ! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ProcessSpecificVariable class instanceVariableNames: 'hash soleInstance'! !ProcessSpecificVariable class methodsFor: 'accessing' stamp: 'IgorStasenko 11/2/2011 18:40'! soleInstance ^ soleInstance ifNil: [ soleInstance := self new ]! ! !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: '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: 'class initialization' stamp: 'MarianoMartinezPeck 8/28/2012 14:53'! resetSoleInstance soleInstance := nil.! ! !ProcessSpecificVariable class methodsFor: 'instance creation' stamp: 'IgorStasenko 11/2/2011 18:19'! new | instance | instance := super new. instance index: (Process allocatePSKey: instance). ^ instance! ! TestCase subclass: #ProcessTerminateBug instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Tests-Exceptions'! !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. ! ! !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: '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:41'! 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)" self shouldnt: [process terminate] raise: BlockCannotReturn. self assert: sema isSignaled. ! ! TestCase subclass: #ProcessTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Processes'! !ProcessTest commentStamp: 'GiovanniCorriga 8/30/2009 14:56' prior: 0! A ProcessTest holds test cases for generic Process-related behaviour.! !ProcessTest methodsFor: 'running' stamp: 'IgorStasenko 11/2/2011 18:34'! tearDown ! ! !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'! testHighPriorityOverridesWaitTime | lowerPriorityWaitingLonger higherPriorityWaitingLess | lowerPriorityWaitingLonger := [ ] forkAt: 10. higherPriorityWaitingLess := [ ] forkAt: 12. self assert: Processor nextReadyProcess equals: higherPriorityWaitingLess.! ! !ProcessTest methodsFor: 'testing' stamp: 'NouryBouraqadi 10/1/2009 07:45'! testIsSelfEvaluating self assert: Processor printString = 'Processor'! ! !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 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 00:52'! testSchedulingIsFirstComeFirstServed | priorityWaitingLonger priorityWaitingLess | priorityWaitingLonger := [ ] fork. priorityWaitingLess := [ ] fork. self assert: Processor nextReadyProcess equals: priorityWaitingLonger.! ! !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: '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.! ! Object subclass: #ProcessorScheduler instanceVariableNames: 'quiescentProcessLists activeProcess' classVariableNames: 'BackgroundProcess HighIOPriority LowIOPriority SystemBackgroundPriority SystemRockBottomPriority TimingPriority UserBackgroundPriority UserInterruptPriority UserSchedulingPriority' poolDictionaries: '' category: 'Kernel-Processes'! !ProcessorScheduler commentStamp: '' prior: 0! My single instance, named Processor, coordinates the use of the physical processor by all Processes requiring service.! !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: '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: '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: 'accessing'! activePriority "Answer the priority level of the currently running Process." ^activeProcess priority! ! !ProcessorScheduler methodsFor: 'accessing'! activeProcess "Answer the currently running Process." ^activeProcess! ! !ProcessorScheduler methodsFor: 'accessing' stamp: 'nk 10/27/2000 16:27'! backgroundProcess "Answer the background process" ^ BackgroundProcess! ! !ProcessorScheduler methodsFor: 'accessing'! highestPriority "Answer the number of priority levels currently available for use." ^quiescentProcessLists size! ! !ProcessorScheduler methodsFor: 'accessing'! 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: '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: '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: 'ar 7/8/2001 16:21'! waitingProcessesAt: aPriority "Return the list of processes at the given priority level." ^quiescentProcessLists at: aPriority! ! !ProcessorScheduler methodsFor: 'printing' stamp: 'NouryBouraqadi 10/1/2009 07:48'! printOn: aStream self isSelfEvaluating ifFalse: [^super printOn: aStream]. aStream nextPutAll: #Processor! ! !ProcessorScheduler methodsFor: 'priority names'! 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: 'priority names'! 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: 'priority names' stamp: 'ar 7/8/2001 17:02'! lowestPriority "Return the lowest priority that is allowed with the scheduler" ^SystemRockBottomPriority! ! !ProcessorScheduler methodsFor: 'priority names'! 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'! timingPriority "Answer the priority at which the system processes keeping track of real time should run." ^TimingPriority! ! !ProcessorScheduler methodsFor: 'priority names'! userBackgroundPriority "Answer the priority at which user background processes should run." ^UserBackgroundPriority! ! !ProcessorScheduler methodsFor: 'priority names'! 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'! userSchedulingPriority "Answer the priority at which the window scheduler should run." ^UserSchedulingPriority! ! !ProcessorScheduler methodsFor: 'process state change'! 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: 'process state change'! 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: 'process state change'! terminateActive "Terminate the process that is currently running." activeProcess terminate! ! !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: 'removing'! 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: 'self evaluating' stamp: 'NouryBouraqadi 10/1/2009 07:47'! isSelfEvaluating ^self == Processor! ! !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 instanceVariableNames: ''! !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: '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" ! ! !ProcessorScheduler class methodsFor: 'background process' stamp: 'di 2/4/1999 08:45'! 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 == nil ifFalse: [BackgroundProcess terminate]. BackgroundProcess := [self idleProcess] newProcess. BackgroundProcess priority: SystemRockBottomPriority. BackgroundProcess resume. ! ! !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'! 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'! ! RectangleMorph subclass: #ProgressBarMorph instanceVariableNames: 'start end value height width' classVariableNames: 'DefaultHeight DefaultWidth' poolDictionaries: '' category: 'Morphic-ProgressBar'! !ProgressBarMorph commentStamp: '' prior: 0! 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: '*Deprecated20' stamp: 'SeanDeNigris 5/22/2012 15:29'! barSize: anInteger self deprecated: 'use #value: instead' on: '05/14/2012' in: 'Pharo 2.0'. value := anInteger. self changed.! ! !ProgressBarMorph methodsFor: 'accessing' stamp: 'SeanDeNigris 5/14/2012 19:50'! decrement self value: self value - 1.! ! !ProgressBarMorph methodsFor: 'accessing' stamp: 'SeanDeNigris 5/14/2012 19:50'! increment self value: self value + 1.! ! !ProgressBarMorph methodsFor: 'accessing' stamp: 'SeanDeNigris 5/14/2012 19:47'! value ^ value.! ! !ProgressBarMorph methodsFor: 'accessing' stamp: 'SeanDeNigris 5/14/2012 20:12'! value: aNumber value := aNumber. self changed.! ! !ProgressBarMorph methodsFor: 'drawing' stamp: 'Sd 11/30/2012 20:15'! 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: self completedWidth @ 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: 'initialization' stamp: 'Sd 11/30/2012 20:18'! initialize "Initialize the receiver from the current theme." super initialize. value := 0. start := 0. end := 100. height := DefaultHeight. width := DefaultWidth. self fillStyle: (self theme progressBarFillStyleFor: self); borderStyle: (self theme progressBarBorderStyleFor: self); barFillStyle: (self theme progressBarProgressFillStyleFor: self); extent: width@height + (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: '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 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: 'private' stamp: 'SeanDeNigris 5/14/2012 20:01'! startAt: aNumber value := start := aNumber.! ! !ProgressBarMorph methodsFor: 'private' stamp: 'SeanDeNigris 5/14/2012 19:41'! totalBarWidth ^ self width - (2 * self borderWidth).! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ProgressBarMorph class instanceVariableNames: ''! !ProgressBarMorph class methodsFor: 'initialization' stamp: 'Sd 11/30/2012 20:16'! defaultHeight: aNumber DefaultHeight := aNumber! ! !ProgressBarMorph class methodsFor: 'initialization' stamp: 'Sd 11/30/2012 20:15'! defaultWidth: aNumber DefaultWidth := aNumber. ! ! !ProgressBarMorph class methodsFor: 'initialization' stamp: 'Sd 11/30/2012 21:59'! initialize "ProgressBarMorph initialize" self defaultWidth: 120. self defaultHeight: 10.! ! !ProgressBarMorph class methodsFor: 'instance-creation' stamp: 'SeanDeNigris 5/14/2012 15:18'! from: startNumber to: endNumber ^ self new startAt: startNumber; endAt: endNumber.! ! Morph subclass: #ProgressIndicatorMorph instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic'! !ProgressIndicatorMorph methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 8/30/2012 18:56'! drawOn: aCanvas aCanvas fillOval: self bounds fillStyle: self fillStyle borderWidth: 2 borderColor: Color black. ! ! Exception subclass: #ProgressInitiationException instanceVariableNames: 'workBlock maxVal minVal aPoint progressTitle' classVariableNames: '' poolDictionaries: '' category: 'Deprecated20'! !ProgressInitiationException commentStamp: '' prior: 0! I provide a way to alter the behavior of the old-style progress notifier in String. See examples in: ProgressInitiationException testWithout. ProgressInitiationException testWith. ! !ProgressInitiationException methodsFor: 'accessing' stamp: 'JuanVuletich 10/28/2010 13:06'! maxVal ^maxVal! ! !ProgressInitiationException methodsFor: 'accessing' stamp: 'JuanVuletich 10/28/2010 13:06'! minVal ^minVal! ! !ProgressInitiationException methodsFor: 'accessing' stamp: 'JuanVuletich 10/28/2010 13:05'! point ^aPoint! ! !ProgressInitiationException methodsFor: 'accessing' stamp: 'JuanVuletich 10/28/2010 13:04'! progressTitle ^progressTitle! ! !ProgressInitiationException methodsFor: 'accessing' stamp: 'pavel.krivanek 9/28/2006 20:31'! workBlock ^ workBlock! ! !ProgressInitiationException methodsFor: 'action' stamp: 'CamilloBruni 8/30/2012 16:15'! defaultAction ^ UIManager default displayProgress: progressTitle from: minVal to: maxVal during: workBlock! ! !ProgressInitiationException methodsFor: 'action' stamp: 'SeanDeNigris 6/21/2012 00:24'! sendNotificationsTo: anObject self resume: (workBlock value: (anObject start: minVal; end: maxVal)).! ! !ProgressInitiationException methodsFor: 'initialize-release' stamp: 'RAA 5/15/2000 11:43'! display: argString at: argPoint from: argMinVal to: argMaxVal during: argWorkBlock progressTitle := argString. aPoint := argPoint. minVal := argMinVal. maxVal := argMaxVal. workBlock := argWorkBlock. ^self signal! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ProgressInitiationException class instanceVariableNames: ''! !ProgressInitiationException class methodsFor: 'signalling' stamp: 'ajh 1/22/2003 23:51'! display: aString at: aPoint from: minVal to: maxVal during: workBlock ^ self new display: aString at: aPoint from: minVal to: maxVal during: workBlock! ! Notification subclass: #ProgressNotification instanceVariableNames: 'amount done extra' classVariableNames: '' poolDictionaries: '' category: 'UIManager-Support'! !ProgressNotification commentStamp: '' prior: 0! 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 instanceVariableNames: ''! !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! ! LayoutPolicy subclass: #ProportionalLayout instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Morphic-Layouts'! !ProportionalLayout commentStamp: '' prior: 0! I represent a layout that places all children of some morph in their given LayoutFrame.! !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].! ! !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! ! AbstractResizerMorph subclass: #ProportionalSplitterMorph instanceVariableNames: 'leftOrTop rightOrBottom splitsTopAndBottom oldColor traceMorph' classVariableNames: 'ShowHandles' poolDictionaries: '' category: 'Morphic-Windows'! !ProportionalSplitterMorph commentStamp: 'jmv 1/29/2006 17:16' prior: 0! I am the morph the user grabs to adjust pane splitters.! !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'! 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 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: '*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: '*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 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: '*Polymorph-Widgets' stamp: 'gvc 7/30/2007 15:55'! normalFillStyle "Return the normal fillStyle of the receiver." ^self theme splitterNormalFillStyleFor: self! ! !ProportionalSplitterMorph methodsFor: '*Polymorph-Widgets' stamp: 'gvc 11/10/2006 11:36'! noteNewOwner: o "Update the fill style." super noteNewOwner: o. WorldState addDeferredUIMessage: [self adoptPaneColor: self paneColor]! ! !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 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: '*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 4/26/2007 10:21'! setGrabbedColor "Set the color of the receiver when it is grabbed." self fillStyle: self pressedFillStyle! ! !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 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:40'! showLeftOrTop "Show the receiver and all left or top morphs." self show. leftOrTop do: [:m | m show]! ! !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: '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: 'apl 7/8/2005 13:38'! getOldColor ^ oldColor ifNil: [Color transparent]! ! !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: 'accessing' stamp: 'jrp 8/6/2005 23:59'! handleSize ^ self class splitterWidth @ 30! ! !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: '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: '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: 'accessing' stamp: 'bvs 3/24/2004 17:25'! splitsTopAndBottom ^ splitsTopAndBottom! ! !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: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: '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: '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: '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: 'actions' stamp: 'bvs 3/24/2004 16:39'! resizeCursor ^ Cursor resizeForEdge: (splitsTopAndBottom ifTrue: [#top] ifFalse: [#left]) ! ! !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: '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 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: '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: 'initialize' 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: 'operations' stamp: 'bvs 3/24/2004 16:57'! addLeftOrTop: aMorph leftOrTop add: aMorph! ! !ProportionalSplitterMorph methodsFor: 'operations' stamp: 'bvs 3/24/2004 16:55'! addRightOrBottom: aMorph rightOrBottom add: aMorph. ! ! !ProportionalSplitterMorph methodsFor: 'operations' stamp: 'bvs 3/24/2004 16:39'! beSplitsTopAndBottom splitsTopAndBottom := true. ! ! !ProportionalSplitterMorph methodsFor: 'operations' stamp: 'jrp 3/21/2006 22:45'! normalizedX: x ^ (x max: self leftBoundary) min: self rightBoundary! ! !ProportionalSplitterMorph methodsFor: 'operations' stamp: 'jrp 3/21/2006 23:12'! normalizedY: y ^ (y max: self topBoundary) min: self bottomBoundary! ! !ProportionalSplitterMorph methodsFor: 'testing' stamp: 'jrp 7/9/2005 17:44'! isCursorOverHandle ^ self class showSplitterHandles not or: [self handleRect containsPoint: ActiveHand cursorPoint]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ProportionalSplitterMorph class instanceVariableNames: ''! !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:44'! showSplitterHandles ^ ShowHandles ifNil: [ShowHandles := false]! ! !ProportionalSplitterMorph class methodsFor: 'preferences' stamp: 'AlainPlantec 12/14/2009 21:45'! showSplitterHandles: aBoolean ShowHandles := aBoolean! ! ProtoObject subclass: #ProtoObject instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Kernel-Objects'. ProtoObject superclass: nil! !ProtoObject commentStamp: '' prior: 0! ProtoObject establishes minimal behavior required of any object in Squeak, 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. Current examples are ObjectOut and ImageSegmentRootStub, and one could argue that ObjectTracer should also inherit from this class. ProtoObject has no instance variables, nor should any be added.! !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: '*Fuel-Collections' stamp: 'ul 12/18/2011 11:14'! largeIdentityHash self primitiveFailed! ! !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! ! !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: '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: '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: '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: 'debugging' 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: '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: 'debugging' stamp: 'eem 4/8/2009 19:10'! withArgs: argArray executeMethod: compiledMethod "Execute compiledMethod against the receiver and args in argArray" self primitiveFailed! ! !ProtoObject methodsFor: 'initialize-release' stamp: 'MarianoMartinezPeck 8/24/2012 15:59'! initialize "Subclasses should redefine this method to perform initializations on instance creation" ! ! !ProtoObject methodsFor: 'pointers' stamp: 'AndyKellens 6/11/2010 14:14'! pointersTo ^self pointersToExcept: #()! ! !ProtoObject methodsFor: 'pointers' 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: 'pointers' stamp: 'MarianoMartinezPeck 1/18/2012 22:53'! pointsTo: anObject "Answers true if I hold a reference to anObject, or false otherwise" ^ (self instVarsInclude: anObject) or: [ ^self class == anObject and: [ self class isCompact not ] ]! ! !ProtoObject methodsFor: 'system primitives' 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: 'system primitives' 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: 'system primitives' stamp: 'ajh 1/13/2002 17:02'! 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) == nil ifFalse: ["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: 'system primitives' stamp: 'ajh 10/9/2001 17:20'! doesNotUnderstand: aMessage ^ MessageNotUnderstood new message: aMessage; receiver: self; signal! ! !ProtoObject methodsFor: 'system primitives' 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: 'system primitives' 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: 'system primitives' 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: '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: '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: '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: 'testing' stamp: 'md 11/24/1999 19:26'! isNil "Coerces nil to true and everything else to false." ^false! ! ClassTestCase subclass: #ProtoObjectTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'KernelTests-Objects'! !ProtoObjectTest commentStamp: '' prior: 0! 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: 'sd 6/5/2005 09:05'! testFlag self shouldnt: [ProtoObject new flag: #hallo] raise: Error.! ! !ProtoObjectTest methodsFor: 'tests - testing' stamp: 'ul 12/18/2009 15:40'! testIfNil | object block | object := ProtoObject new. self shouldnt: [ object ifNil: [ self halt ]] raise: Halt. self assert: (object ifNil: [ nil ]) == object. "Now the same without inlining." block := [ self halt ]. self shouldnt: [ object ifNil: block ] raise: Halt. block := [ nil ]. self assert: (object ifNil: block) == object. ! ! !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: '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: 'ul 12/18/2009 15:48'! testIsNil self deny: ProtoObject new isNil! ! !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.! ! Object subclass: #Protocol instanceVariableNames: 'methods name' classVariableNames: '' poolDictionaries: '' category: 'NewClassOrganizer'! !Protocol commentStamp: '' prior: 0! A Protocol is a simple value holder representing a protocol. It's composed of a name and a set of method selectors! !Protocol methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/12/2012 14:21'! methods ^ methods! ! !Protocol methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/12/2012 14:02'! methods: anObject methods := anObject! ! !Protocol methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/12/2012 14:21'! name ^ name! ! !Protocol methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/12/2012 14:02'! name: anObject name := anObject! ! !Protocol methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 4/12/2012 14:38'! initialize "Initialization code for Protocol" super initialize. methods := IdentitySet new.. name := self class defaultName.! ! !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: 'protocol' stamp: 'BenjaminVanRyseghem 4/12/2012 14:11'! addMethod: aSymbol ^ methods add: aSymbol! ! !Protocol methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/12/2012 14:11'! includesMethod: aSymbol ^ methods includes: aSymbol! ! !Protocol methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/12/2012 16:27'! isEmpty ^ self methods isEmpty! ! !Protocol methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/12/2012 14:12'! rename: newName self name: newName! ! !Protocol methodsFor: '~~~ all ~~~' stamp: 'BenjaminVanRyseghem 4/12/2012 14:11'! removeMethod: aSymbol ^ methods remove: aSymbol! ! !Protocol methodsFor: 'private' stamp: 'BenjaminVanRyseghem 4/12/2012 16:05'! canBeRemoved ^ true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Protocol class instanceVariableNames: ''! !Protocol class methodsFor: 'data' stamp: 'BenjaminVanRyseghem 4/12/2012 14:38'! defaultName ^ #'as yet unclassified'! ! !Protocol class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 4/12/2012 14:06'! name: nm ^ self new name: nm; yourself! ! !Protocol class methodsFor: 'instance creation' stamp: 'BenjaminVanRyseghem 4/12/2012 14:02'! name: nm methods: methods ^ self new methods: methods; name: nm; yourself! ! SystemAnnouncement subclass: #ProtocolAdded instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Announcements'! !ProtocolAdded commentStamp: '' prior: 0! 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! Object subclass: #ProtocolClient instanceVariableNames: 'stream connectInfo lastResponse pendingResponses progressObservers' classVariableNames: '' poolDictionaries: '' category: 'Network-Protocols'! !ProtocolClient commentStamp: 'gk 12/13/2005 00:34' prior: 0! 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: 'accessing' stamp: 'mir 3/7/2002 14:55'! logProgressToTranscript self progressObservers add: Transcript! ! !ProtocolClient methodsFor: 'accessing' stamp: 'mir 5/9/2003 15:52'! messageText ^super messageText ifNil: [self response]! ! !ProtocolClient methodsFor: 'accessing' stamp: 'mir 5/9/2003 15:52'! response ^self protocolInstance lastResponse! ! !ProtocolClient methodsFor: 'accessing' stamp: 'mir 2/22/2002 17:33'! stream ^stream! ! !ProtocolClient methodsFor: 'accessing' stamp: 'mir 2/22/2002 17:33'! stream: aStream stream := aStream! ! !ProtocolClient methodsFor: 'actions' stamp: 'mir 3/7/2002 13:10'! close self stream ifNotNil: [ self stream close. stream := nil]! ! !ProtocolClient methodsFor: 'actions' stamp: 'mir 3/7/2002 13:11'! reopen self ensureConnection! ! !ProtocolClient methodsFor: 'testing' stamp: 'mir 3/7/2002 14:33'! isConnected ^stream notNil and: [stream isConnected]! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 3/8/2002 11:35'! connectionInfo connectInfo ifNil: [connectInfo := Dictionary new]. ^connectInfo! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 2/25/2002 19:34'! defaultPortNumber ^self class defaultPortNumber! ! !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 4/7/2003 16:56'! host ^self connectionInfo at: #host! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 3/8/2002 11:37'! host: hostId ^self connectionInfo at: #host put: hostId! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 3/7/2002 13:35'! lastResponse ^lastResponse! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 3/7/2002 13:35'! lastResponse: aString lastResponse := aString. ! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 2/25/2002 19:07'! logFlag ^self class logFlag! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 5/12/2003 18:10'! logProgress: aString self progressObservers do: [:each | each show: aString]. ! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 3/8/2002 11:40'! openOnHost: hostIP port: portNumber self host: hostIP. self port: portNumber. self ensureConnection! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 4/7/2003 16:56'! password ^self connectionInfo at: #password! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 3/8/2002 11:37'! password: aString ^self connectionInfo at: #password put: aString! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 7/23/2003 16:45'! pendingResponses pendingResponses ifNil: [pendingResponses := OrderedCollection new]. ^pendingResponses! ! !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 4/7/2003 16:57'! port ^self connectionInfo at: #port! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 3/8/2002 11:38'! port: aPortNumber ^self connectionInfo at: #port put: aPortNumber! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 3/7/2002 14:54'! progressObservers progressObservers ifNil: [progressObservers := OrderedCollection new]. ^progressObservers! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 7/23/2003 16:45'! pushResponse: aResponse self pendingResponses add: aResponse! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 3/8/2002 11:35'! resetConnectionInfo connectInfo := nil! ! !ProtocolClient methodsFor: 'private' stamp: 'mir 11/11/2002 16:19'! user ^self connectionInfo at: #user ifAbsent: [nil]! ! !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 protocol' stamp: 'mir 5/9/2003 18:47'! checkResponse "Get the response from the server and check for errors." self checkResponseOnError: [:response | (TelnetProtocolError protocolInstance: self) signal] onWarning: [:response | (TelnetProtocolError protocolInstance: self) signal]. ! ! !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: '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 protocol' stamp: 'mir 3/7/2002 13:16'! fetchNextResponse self lastResponse: self stream nextLine! ! !ProtocolClient methodsFor: 'private protocol' stamp: 'mir 7/23/2003 16:50'! fetchPendingResponse ^pendingResponses ifNil: [self fetchNextResponse; lastResponse] ifNotNil: [self popResponse]! ! !ProtocolClient methodsFor: 'private protocol' stamp: 'mir 5/12/2003 18:10'! sendCommand: aString self stream sendCommand: aString. ! ! !ProtocolClient methodsFor: 'private protocol' stamp: 'mir 3/5/2002 14:31'! sendStreamContents: aStream self stream sendStreamContents: aStream! ! !ProtocolClient methodsFor: 'private testing' stamp: 'mir 3/7/2002 13:42'! responseIsError self subclassResponsibility! ! !ProtocolClient methodsFor: 'private testing' stamp: 'mir 3/7/2002 13:42'! responseIsWarning self subclassResponsibility! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ProtocolClient class instanceVariableNames: ''! !ProtocolClient class methodsFor: 'accessing' stamp: 'mir 2/25/2002 16:00'! defaultPortNumber self subclassResponsibility! ! !ProtocolClient class methodsFor: 'accessing' stamp: 'mir 2/25/2002 19:07'! logFlag self subclassResponsibility! ! !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: '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] ! ! !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: 'retrieval' stamp: 'mir 3/5/2002 16:21'! retrieveMIMEDocument: aURI self subclassResponsibility! ! Error subclass: #ProtocolClientError instanceVariableNames: 'protocolInstance' classVariableNames: '' poolDictionaries: '' category: 'Network-Protocols'! !ProtocolClientError commentStamp: 'mir 5/12/2003 18:05' prior: 0! 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 5/16/2003 11:17'! messageText ^super messageText ifNil: [self response]! ! !ProtocolClientError methodsFor: 'accessing' stamp: 'mir 10/30/2000 13:48'! protocolInstance ^protocolInstance! ! !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 class instanceVariableNames: ''! !ProtocolClientError class methodsFor: 'instance creation' stamp: 'mir 10/30/2000 16:15'! protocolInstance: aProtocolInstance ^self new protocolInstance: aProtocolInstance! ! Object subclass: #ProtocolOrganizer instanceVariableNames: 'allProtocol protocols' classVariableNames: '' poolDictionaries: '' category: 'NewClassOrganizer'! !ProtocolOrganizer commentStamp: '' prior: 0! A ProtocolOrganizer is part of a ClassOrganizer. It manages the protocols of the class that owns it! !ProtocolOrganizer methodsFor: 'accessing' stamp: 'BenjaminVanRyseghem 4/12/2012 14:19'! allProtocol ^ allProtocol! ! !ProtocolOrganizer methodsFor: 'backward compatibility' stamp: 'BenjaminVanRyseghem 4/12/2012 15:12'! allProtocolsNames ^ self allProtocols collect: #name! ! !ProtocolOrganizer methodsFor: 'backward compatibility' stamp: 'BenjaminVanRyseghem 4/12/2012 16:55'! protocols ^ protocols! ! !ProtocolOrganizer methodsFor: 'backward compatibility' stamp: 'BenjaminVanRyseghem 4/12/2012 16:55'! protocolsNames ^ self allProtocolsNames! ! !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: '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: 'importing' stamp: 'BenjaminVanRyseghem 4/12/2012 18:15'! importFrom: aClassOrganizer aClassOrganizer categories do: [:cat || protocol methods | cat = ClassOrganizer nullCategory ifFalse: [ methods := aClassOrganizer listAtCategoryNamed: cat. protocol := self addProtocolNamed: cat asString. methods do: [:m | protocol addMethod: m ]]].! ! !ProtocolOrganizer methodsFor: 'initialization' stamp: 'BenjaminVanRyseghem 4/12/2012 14:36'! initialize "Initialization code for ProtocolOrganizer" super initialize. protocols := IdentitySet new. allProtocol := AllProtocol protocolOrganizer: self.! ! !ProtocolOrganizer methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/12/2012 14:17'! allMethods ^ self protocols gather: [:p | p methods ].! ! !ProtocolOrganizer methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/12/2012 15:10'! allProtocols ^ { allProtocol }, protocols asArray! ! !ProtocolOrganizer methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/24/2012 15:10'! classify: aSymbol inProtocolNamed: aProtocolName | name protocol | name := aProtocolName. name = allProtocol name ifTrue: [ name := Protocol defaultName ]. "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: 'protocol' stamp: 'BenjaminVanRyseghem 4/24/2012 15:10'! classify: aSymbol inProtocolNamed: aProtocolName suppressIfDefault: aBoolean | protocolsToRemove | protocolsToRemove := {}. aBoolean ifTrue: [ protocolsToRemove := self protocolsOfSelector: aSymbol ]. protocolsToRemove do: [:e | self removeProtocol: e ]. self classify: aSymbol inProtocolNamed: aProtocolName. ! ! !ProtocolOrganizer methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/12/2012 15:39'! getProtocolNamed: aName ^ self allProtocols detect: [ :e | e name = aName ] ifNone: [ self allProtocol ]! ! !ProtocolOrganizer methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/24/2012 14:16'! getProtocolNamed: aByteString ifNone: aBlockClosure ^ protocols detect: [:e | e name = aByteString ] ifNone: aBlockClosure ! ! !ProtocolOrganizer methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/12/2012 15:10'! methodsInProtocolNamed: aName ^ (self getProtocolNamed: aName) methods! ! !ProtocolOrganizer methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/12/2012 15:19'! protocolsOfSelector: aSelector ^ (self protocols select: [:e | e includesMethod: aSelector ]) asArray! ! !ProtocolOrganizer methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/12/2012 16:56'! protocolsSorted ^ { allProtocol name }, (self protocols collect: #name) asArray sort! ! !ProtocolOrganizer methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/24/2012 14:38'! removeMethod: aSymbol (self protocolsOfSelector: aSymbol) do: [ :p | p removeMethod: aSymbol ]! ! !ProtocolOrganizer methodsFor: 'protocol' stamp: 'BenjaminVanRyseghem 4/12/2012 16:17'! renameProtocol: oldName into: newName ^ (self getProtocolNamed: oldName) name: newName; yourself! ! !ProtocolOrganizer methodsFor: 'protocol - adding' stamp: 'BenjaminVanRyseghem 4/12/2012 14:11'! addProtocol: aProtocol ^ protocols add: aProtocol! ! !ProtocolOrganizer methodsFor: 'protocol - adding' stamp: 'BenjaminVanRyseghem 4/12/2012 14:11'! addProtocolNamed: aName ^ protocols add: (Protocol name: aName)! ! !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: 'protocol - removing' stamp: 'BenjaminVanRyseghem 4/24/2012 14:37'! removeProtocol: aProtocol aProtocol canBeRemoved ifFalse: [ ProtocolRemovaleException signal ]. ^ protocols remove: aProtocol! ! !ProtocolOrganizer methodsFor: 'protocol - removing' stamp: 'BenjaminVanRyseghem 4/24/2012 14:38'! removeProtocolNamed: aName | protocolToRemove | protocolToRemove := self getProtocolNamed: aName. ^ self removeProtocol: protocolToRemove! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! ProtocolOrganizer class instanceVariableNames: ''! !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! ! Error subclass: #ProtocolRemovaleException instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NewClassOrganizer'! !ProtocolRemovaleException commentStamp: '' prior: 0! A ProtocolRemovaleException is an error raised when someone try to remove a protocol that should not be removed! SystemAnnouncement subclass: #ProtocolRemoved instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-Announcements'! !ProtocolRemoved commentStamp: '' prior: 0! 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! Object subclass: #PrototypeTester instanceVariableNames: 'prototype' classVariableNames: '' poolDictionaries: '' category: 'SUnit-Core-Utilities'! !PrototypeTester commentStamp: 'mjr 8/20/2003 13:09' prior: 0! I am a simple holder of a prototype object and hand out copies when requested.! !PrototypeTester methodsFor: 'as yet unclassified' stamp: 'mjr 8/20/2003 18:56'! prototype "Get a prototype" ^ prototype copy ! ! !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 class instanceVariableNames: ''! !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! ! Notification subclass: #ProvideAnswerNotification instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'UIManager-Support'! Object subclass: #PseudoClass instanceVariableNames: 'name definition organization source metaClass' classVariableNames: '' poolDictionaries: '' category: 'System-FilePackage'! !PseudoClass commentStamp: '' prior: 0! 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: '*MonticelloGUI' stamp: 'StephaneDucasse 2/10/2012 16:15'! asClassDefinition ^ MCClassDefinition name: self name superclassName: self superclass name category: self category instVarNames: self instVarNames classVarNames: self classVarNames asSortedCollection poolDictionaryNames: self poolDictionaryNames classInstVarNames: self class instVarNames type: self typeOfClass comment: self organization classComment asString commentStamp: self organization commentStamp ! ! !PseudoClass methodsFor: 'accessing' stamp: 'nk 4/29/2004 06:59'! allCallsOn ^ (self realClass ifNil: [ ^#() ]) allCallsOn! ! !PseudoClass methodsFor: 'accessing' stamp: 'StephaneDucasse 4/30/2011 21:38'! allCallsOnIn: aSystemNavigation ^ (self realClass ifNil: [ ^#() ]) allCallsOn! ! !PseudoClass methodsFor: 'accessing' stamp: 'sma 6/16/1999 22:59'! allInstVarNames ^#()! ! !PseudoClass methodsFor: 'accessing' stamp: 'nk 2/18/2004 18:32'! allSuperclasses ^ (self realClass ifNil: [ ^#() ]) allSuperclasses! ! !PseudoClass methodsFor: 'accessing' stamp: 'jb 7/1/2011 10:54'! compilerClass ^ (Smalltalk globals at: name ifAbsent: [ ^ self class compilerClass ]) compilerClass! ! !PseudoClass methodsFor: 'accessing'! fullName ^self name! ! !PseudoClass methodsFor: 'accessing' stamp: 'nk 3/9/2004 10:24'! instVarNames ^ #()! ! !PseudoClass methodsFor: 'accessing'! name ^name! ! !PseudoClass methodsFor: 'accessing'! name: anObject name := anObject! ! !PseudoClass methodsFor: 'accessing' stamp: 'NS 4/6/2004 15:46'! organization organization ifNil: [organization := PseudoClassOrganizer defaultList: SortedCollection new]. "Making sure that subject is set correctly. It should not be necessary." organization setSubject: self. ^ organization! ! !PseudoClass methodsFor: 'accessing' stamp: 'nk 2/23/2005 18:00'! prettyPrinterClass ^self class prettyPrinterClass! ! !PseudoClass methodsFor: 'accessing' stamp: 'lr 3/14/2010 21:13'! realClass ^ Smalltalk globals at: self name asSymbol ifAbsent: [ ]! ! !PseudoClass methodsFor: 'accessing' stamp: 'NorbertHartl 6/20/2008 21:25'! theMetaClass ^ self metaClass! ! !PseudoClass methodsFor: 'accessing' stamp: 'wod 5/19/1998 17:42'! theNonMetaClass "Sent to a class or metaclass, always return the class" ^self! ! !PseudoClass methodsFor: 'categories'! removeCategory: selector (self organization listAtCategoryNamed: selector) do:[:sel| self organization removeElement: sel. self sourceCode removeKey: sel. ]. self organization removeCategory: selector.! ! !PseudoClass methodsFor: 'categories'! removedCategoryName ^'*** removed methods ***' asSymbol! ! !PseudoClass methodsFor: 'categories'! 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: 'class'! classComment: aChangeRecord self organization classComment: aChangeRecord! ! !PseudoClass methodsFor: 'class' stamp: 'di 1/13/1999 12:00'! classPool self exists ifFalse: [^ nil]. ^ self realClass classPool! ! !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: 'class'! comment: aString self commentString: aString.! ! !PseudoClass methodsFor: 'class' stamp: 'ar 2/5/2004 15:18'! commentString ^self comment asString! ! !PseudoClass methodsFor: 'class'! commentString: aString self classComment: aString asText. "Just wrap it"! ! !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: 'class'! definition: aString definition := aString! ! !PseudoClass methodsFor: 'class'! metaClass ^metaClass ifNil:[metaClass := PseudoMetaclass new name: (self name)].! ! !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: 'class' stamp: 'di 1/13/1999 12:00'! sharedPools self exists ifFalse: [^ nil]. ^ self realClass sharedPools! ! !PseudoClass methodsFor: 'errors'! classNotDefined ^self inform: self name,' is not defined in the system. You have to define this class first.'.! ! !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: 'filein/fileout'! 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: 'filein/fileout'! fileInCategory: aCategory ^self fileInMethods: (self organization listAtCategoryNamed: aCategory)! ! !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: 'filein/fileout'! fileInMethod: selector ^self fileInMethods: (Array with: selector)! ! !PseudoClass methodsFor: 'filein/fileout'! fileInMethods ^self fileInMethods: self selectors! ! !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: '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: '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: '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: '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: 'filein/fileout'! fileOutMethodsOn: aStream ^self fileOutMethods: self selectors on: aStream.! ! !PseudoClass methodsFor: 'filein/fileout'! 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: 'methods' stamp: 'sma 6/1/2000 14:54'! addMethodChange: aChangeRecord | selector | selector := self parserClass new parseSelector: aChangeRecord string. self organization classify: selector under: aChangeRecord category. self sourceCodeAt: selector put: aChangeRecord! ! !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'! methodChange: aChangeRecord aChangeRecord isMetaClassChange ifTrue:[ ^self metaClass addMethodChange: aChangeRecord. ] ifFalse:[ ^self addMethodChange: aChangeRecord. ]. ! ! !PseudoClass methodsFor: 'methods'! removeMethod: selector self organization removeElement: selector. self sourceCode removeKey: selector. ! ! !PseudoClass methodsFor: 'methods'! 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: 'methods'! selectors ^self sourceCode keys! ! !PseudoClass methodsFor: 'methods'! sourceCode ^source ifNil:[source := Dictionary new]! ! !PseudoClass methodsFor: 'methods'! sourceCodeAt: sel ^(self sourceCode at: sel) string! ! !PseudoClass methodsFor: 'methods'! sourceCodeAt: sel put: object self sourceCode at: sel put: object! ! !PseudoClass methodsFor: 'methods'! sourceCodeTemplate ^''! ! !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: 'override' stamp: 'nk 2/18/2004 18:30'! isMeta ^false! ! !PseudoClass methodsFor: 'printing' stamp: 'sma 6/17/1999 00:00'! literalScannedAs: scannedLiteral notifying: requestor ^ scannedLiteral! ! !PseudoClass methodsFor: 'printing' stamp: 'ar 2/5/2004 16:04'! printOn: aStream super printOn: aStream. aStream nextPut:$(; print: name; nextPut:$)! ! !PseudoClass methodsFor: 'removing'! 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: 'removing'! 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: 'testing' stamp: 'lr 3/14/2010 21:13'! exists ^ (Smalltalk globals at: self name asSymbol ifAbsent: [ ^ false ]) isKindOf: Behavior! ! !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: 'testing'! hasComment ^self organization commentRemoteStr notNil! ! !PseudoClass methodsFor: 'testing'! hasDefinition ^definition notNil! ! !PseudoClass methodsFor: 'testing'! hasMetaclass ^metaClass notNil! ! !PseudoClass methodsFor: 'testing' stamp: 'lr 3/14/2010 21:13'! nameExists ^ Smalltalk globals includesKey: self name asSymbol! ! !PseudoClass methodsFor: 'testing' stamp: 'StephaneDucasse 2/20/2010 21:50'! needsInitialize ^self hasMetaclass and: [self metaClass includesSelector: #initialize]! ! !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: 'private' stamp: 'nk 2/18/2004 18:33'! allSubclassesWithLevelDo: classAndLevelBlock startingLevel: level ^ (self realClass ifNil: [ ^self ]) allSubclassesWithLevelDo: classAndLevelBlock startingLevel: level! ! !PseudoClass methodsFor: 'private'! confirmRemovalOf: aString ^self confirm:'Remove ',aString,' ?'! ! !PseudoClass methodsFor: 'private' stamp: 'jb 7/1/2011 10:54'! evaluate: aString ^self class evaluatorClass evaluate: aString for: nil logged: true! ! !PseudoClass methodsFor: 'private' stamp: 'lr 3/14/2010 21:13'! makeSureClassExists: aString | theClass | theClass := Smalltalk globals at: aString asSymbol ifAbsent: [ nil ]. theClass ifNotNil: [ ^ true ]. ^ self confirm: aString , ' does not exist in the system. Use nil instead?'! ! !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: 'private' stamp: 'jb 7/1/2011 10:54'! parserClass ^ self class evaluatorClass parserClass! ! BasicClassOrganizer subclass: #PseudoClassOrganizer instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-FilePackage'! !PseudoClassOrganizer methodsFor: 'accessing' stamp: 'NS 4/6/2004 12:27'! setDefaultList: aCollection super setDefaultList: aCollection. self classComment: nil.! ! !PseudoClassOrganizer methodsFor: 'as yet unclassified' stamp: 'MarcusDenker 9/17/2012 14:57'! categoriesSorted ^ self categories! ! !PseudoClassOrganizer methodsFor: 'comment accessing' stamp: 'NS 4/6/2004 16:44'! classComment "Answer the comment associated with the object that refers to the receiver." classComment == nil ifTrue: [^'']. ^classComment! ! !PseudoClassOrganizer methodsFor: 'comment accessing' stamp: 'NS 4/6/2004 16:44'! classComment: aChangeRecord classComment := aChangeRecord! ! PseudoClass subclass: #PseudoMetaclass instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'System-FilePackage'! !PseudoMetaclass methodsFor: 'accessing'! fullName ^self name,' class'! ! !PseudoMetaclass methodsFor: 'accessing'! 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! ! Link subclass: #QSystemTally instanceVariableNames: 'class method receivers tally senders' classVariableNames: '' poolDictionaries: '' category: 'AndreasProfiler'! !QSystemTally commentStamp: '' prior: 0! 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 22:24'! maxClassNameSize "Return the default maximum width of the class name alone" ^30! ! !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: '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: 'accessing' stamp: 'ar 6/11/2007 21:57'! method "Answer the CompiledMethod associated with this tally" ^method! ! !QSystemTally methodsFor: 'accessing' stamp: 'ar 6/11/2007 21:58'! tally "Answer the tally count for this node" ^tally! ! !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: '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 methodsFor: 'copying' stamp: 'ar 6/11/2007 22:31'! copyWithTally: hitCount ^ (QSystemTally new class: class method: method) bumpBy: hitCount! ! !QSystemTally methodsFor: 'initialize' stamp: 'ar 6/11/2007 22:07'! class: aClass method: aCompiledMethod class := aClass. method := aCompiledMethod. tally := 0.! ! !QSystemTally methodsFor: 'initialize' stamp: 'AlexandreBergel 1/29/2013 11:02'! initialize super initialize. ! ! !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: '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: '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: 'report' stamp: 'AlexandreBergel 1/29/2013 11:11'! getNewTabsFor: tabs ^ tabs size < self maxTabs ifTrue: [ tabs ] ifFalse: [ (tabs select: [ :x | x = '[' ]) copyWith: '[' ]! ! !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: '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: '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: 'report' stamp: 'ar 6/11/2007 22:44'! printOn: aStream aStream print: class; nextPutAll: '>>'; print: (method ifNotNil:[method who last]). aStream nextPutAll: ' -- '; print: tally.! ! !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: 'tallying' stamp: 'ar 6/11/2007 21:54'! bumpBy: count "Bump this tally by the specified amount" tally := tally + count! ! !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: '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: 'tallying' stamp: 'ar 6/11/2007 22:02'! tallyPath: context by: count "Tally the context chain" | aMethod tally | aMethod := context method. tally := receivers. [tally == nil] whileFalse:[ tally method == aMethod ifTrue:[^tally bumpBy: count]. tally := tally nextLink. ]. tally := QSystemTally new class: context receiver class method: aMethod. tally nextLink: receivers. receivers := tally. ^tally 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 class instanceVariableNames: ''! !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.'! ! Rectangle subclass: #Quadrangle instanceVariableNames: 'borderWidth borderColor insideColor' classVariableNames: '' poolDictionaries: '' category: 'Graphics-Primitives'! !Quadrangle commentStamp: '' prior: 0! I represent a particular kind of Rectangle that has a border and inside color.! !Quadrangle methodsFor: '*Graphics-Display Objects'! display "Display the border and insideRegion of the receiver on the Display." self displayOn: Display! ! !Quadrangle methodsFor: '*Graphics-Display Objects'! displayOn: aDisplayMedium "Display the border and insideRegion of the receiver." borderWidth ~~ 0 ifTrue: [aDisplayMedium border: self region widthRectangle: borderWidth rule: Form over fillColor: borderColor]. insideColor ~~ nil ifTrue: [aDisplayMedium fill: self inside fillColor: insideColor]! ! !Quadrangle methodsFor: '*Graphics-Display Objects'! displayOnPort: aPort at: p "Display the border and insideRegion of the receiver." (insideColor == nil or: [borderWidth <= 0]) ifFalse: [aPort fill: (self region translateBy: p) fillColor: borderColor rule: Form over]. insideColor == nil ifFalse: [aPort fill: (self inside translateBy: p) fillColor: insideColor rule: Form over]! ! !Quadrangle methodsFor: 'bordering'! borderColor "Answer the form that is the borderColor of the receiver." ^borderColor! ! !Quadrangle methodsFor: 'bordering' stamp: 'lr 7/4/2009 10:42'! borderColor: aColor "Set the borderColor of the receiver to aColor, a Form." borderColor := aColor! ! !Quadrangle methodsFor: 'bordering'! borderWidth "Answer the borderWidth of the receiver." ^borderWidth! ! !Quadrangle methodsFor: 'bordering' stamp: 'lr 7/4/2009 10:42'! borderWidth: anInteger "Set the borderWidth of the receiver to anInteger." borderWidth := anInteger! ! !Quadrangle methodsFor: 'bordering' stamp: 'lr 7/4/2009 10:42'! borderWidthLeft: anInteger1 right: anInteger2 top: anInteger3 bottom: anInteger4 "Set the border width of the receiver to a Rectangle that represents the left, right, top, and bottom border widths." borderWidth := anInteger1 @ anInteger3 corner: anInteger2 @ anInteger4! ! !Quadrangle methodsFor: 'bordering'! inside "Answer a Rectangle that is the receiver inset by the borderWidth." ^self insetBy: borderWidth! ! !Quadrangle methodsFor: 'bordering'! insideColor "Answer the form that is the insideColor of the receiver." ^insideColor! ! !Quadrangle methodsFor: 'bordering' stamp: 'lr 7/4/2009 10:42'! insideColor: aColor "Set the insideColor of the receiver to aColor, a Form." insideColor := aColor! ! !Quadrangle methodsFor: 'bordering'! region "Answer a Rectangle that defines the area of the receiver." ^origin corner: corner! ! !Quadrangle methodsFor: 'bordering' stamp: 'lr 7/4/2009 10:42'! region: aRectangle "Set the rectangular area of the receiver to aRectangle." origin := aRectangle origin. corner := aRectangle corner! ! !Quadrangle methodsFor: 'bordering' stamp: 'sw 5/4/2001 18:30'! setHeight: aNumber "Set the receiver's height" self region: (origin extent: (self width @ aNumber))! ! !Quadrangle methodsFor: 'bordering' stamp: 'sw 5/4/2001 17:54'! setLeft: aNumber "Move the receiver so that its left edge is given by aNumber. An example of a setter to go with #left" self region: ((aNumber @ origin y) extent: self extent)! ! !Quadrangle methodsFor: 'bordering' stamp: 'sw 5/4/2001 18:19'! setRight: aNumber "Move the receiver so that its right edge is given by aNumber. An example of a setter to go with #right" self region: ((origin x + (aNumber - self right) @ origin y) extent: self extent)! ! !Quadrangle methodsFor: 'bordering' stamp: 'sw 5/4/2001 18:26'! setWidth: aNumber "Set the receiver's width" self region: (origin extent: (aNumber @ self height))! ! !Quadrangle methodsFor: 'initialization' stamp: 'alain.plantec 5/28/2009 10:16'! initialize "Initialize the region to a null Rectangle, the borderWidth to 1, the borderColor to black, and the insideColor to white." super initialize. origin := 0 @ 0. corner := 0 @ 0. borderWidth := 1. borderColor := Color black. insideColor := Color white. ! ! !Quadrangle methodsFor: 'rectangle functions' stamp: 'CamilloBruni 8/1/2012 16:10'! intersect: aRectangle "Answer a new Quadrangle whose region is the intersection of the receiver's area and aRectangle." ^ self class region: (super intersect: aRectangle) borderWidth: borderWidth borderColor: borderColor insideColor: insideColor! ! !Quadrangle methodsFor: 'transforming' stamp: 'CamilloBruni 8/1/2012 15:58'! align: aPoint1 with: aPoint2 "Answer a new Quadrangle translated by aPoint2 - aPoint1." ^ self class region: (super translateBy: aPoint2 - aPoint1) borderWidth: borderWidth borderColor: borderColor insideColor: insideColor! ! !Quadrangle methodsFor: 'transforming' stamp: 'CamilloBruni 8/1/2012 15:58'! alignedTo: alignPointSelector "Return a copy with offset according to alignPointSelector which is one of... #(topLeft, topCenter, topRight, leftCenter, center, etc)" ^ self class region: (super translateBy: (0@0) - (self perform: alignPointSelector)) borderWidth: borderWidth borderColor: borderColor insideColor: insideColor! ! !Quadrangle methodsFor: 'transforming' stamp: 'CamilloBruni 8/1/2012 16:15'! scaleBy: aPoint "Answer a new Quadrangle scaled by aPoint." ^ self class region: (super scaleBy: aPoint) borderWidth: borderWidth borderColor: borderColor insideColor: insideColor! ! !Quadrangle methodsFor: 'transforming' stamp: 'CamilloBruni 8/1/2012 16:18'! translateBy: aPoint "Answer a new Quadrangle translated by aPoint." ^ self class region: (super translateBy: aPoint) borderWidth: borderWidth borderColor: borderColor insideColor: insideColor! ! !Quadrangle methodsFor: 'private' stamp: 'lr 7/4/2009 10:42'! setRegion: aRectangle borderWidth: anInteger borderColor: aMask1 insideColor: aMask2 origin := aRectangle origin. corner := aRectangle corner. borderWidth := anInteger. borderColor := aMask1. insideColor := aMask2! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! Quadrangle class instanceVariableNames: ''! !Quadrangle class methodsFor: 'instance creation' stamp: 'fc 1/16/2005 21:20'! origin: originPoint corner: cornerPoint "Override Rectangles origin:corner: in order to get initialized. Answer an instance of me whose corners (top left and bottom right) are determined by the arguments." ^self new setOrigin: originPoint corner: cornerPoint! ! !Quadrangle class methodsFor: 'instance creation'! region: aRectangle borderWidth: anInteger borderColor: aMask1 insideColor: aMask2 "Answer an instance of me with rectangle, border width and color, and inside color determined by the arguments." ^super new setRegion: aRectangle borderWidth: anInteger borderColor: aMask1 insideColor: aMask2! ! ProceedDialogWindow subclass: #QuestionDialogWindow instanceVariableNames: 'answer' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Windows'! !QuestionDialogWindow commentStamp: 'gvc 5/18/2007 12:20' prior: 0! 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'! answer: anObject "Set the value of answer" answer := anObject! ! !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/11/2007 17:36'! no "Answer no." self answer: false; ok! ! !QuestionDialogWindow methodsFor: 'as yet unclassified' stamp: 'gvc 1/10/2007 14:44'! yes "Answer yes." self answer: true; ok! ! QuestionDialogWindow subclass: #QuestionWithoutCancelDialogWindow instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Polymorph-Widgets-Windows'! !QuestionWithoutCancelDialogWindow commentStamp: 'gvc 5/18/2007 12:20' prior: 0! 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}! ! MimeConverter subclass: #QuotedPrintableMimeConverter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Network-MIME'! !QuotedPrintableMimeConverter commentStamp: '' prior: 0! 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. --bf 11/27/1998 16:50! !QuotedPrintableMimeConverter methodsFor: 'conversion' stamp: 'SvenVanCaekenberghe 1/8/2012 15:25'! mimeDecode "Do conversion reading from mimeStream writing to dataStream" | line s c1 v1 c2 v2 | [ (line := mimeStream nextLine) isNil ] whileFalse: [ line := line trimRight. line size = 0 ifTrue: [ dataStream cr ] ifFalse: [ s := line readStream. [ dataStream nextPutAll: (s upTo: $=). s atEnd ] whileFalse: [ c1 := s next. v1 := c1 digitValue. ((v1 between: 0 and: 15) and: [ s atEnd not ]) ifFalse: [ dataStream nextPut: $=; nextPut: c1 ] ifTrue: [ c2 := s next. v2 := c2 digitValue. (v2 between: 0 and: 15) ifFalse: [ dataStream nextPut: $=; nextPut: c1; nextPut: c2 ] ifTrue: [ dataStream nextPut: (Character value: v1 * 16 + v2) ] ] ]. line last = $= ifFalse: [ dataStream cr ] ] ]. ^ dataStream! ! Object subclass: #RBAbstractClass instanceVariableNames: 'name newMethods instanceVariableNames model superclass subclasses removedMethods realClass' classVariableNames: 'LookupSuperclass' poolDictionaries: '' category: 'Refactoring-Core-Model'! !RBAbstractClass methodsFor: 'accessing'! allClassVariableNames ^self subclassResponsibility! ! !RBAbstractClass methodsFor: 'accessing'! allInstanceVariableNames | sprClass | sprClass := self superclass. ^sprClass isNil ifTrue: [self instanceVariableNames] ifFalse: [sprClass allInstanceVariableNames , self instanceVariableNames]! ! !RBAbstractClass methodsFor: 'accessing'! allPoolDictionaryNames ^self subclassResponsibility! ! !RBAbstractClass methodsFor: 'accessing'! 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'! allSuperclasses | supers sprClass | supers := OrderedCollection new. sprClass := self superclass. [sprClass notNil] whileTrue: [supers add: sprClass. sprClass := sprClass superclass]. ^supers! ! !RBAbstractClass methodsFor: 'accessing' stamp: 'lr 7/23/2010 08:02'! classBinding ^ Smalltalk globals associationAt: self name! ! !RBAbstractClass methodsFor: 'accessing'! instanceVariableNames ^self privateInstanceVariableNames copy! ! !RBAbstractClass methodsFor: 'accessing'! instanceVariableNames: aCollectionOfStrings instanceVariableNames := aCollectionOfStrings asOrderedCollection! ! !RBAbstractClass methodsFor: 'accessing'! model ^model! ! !RBAbstractClass methodsFor: 'accessing'! name ^name! ! !RBAbstractClass methodsFor: 'accessing'! name: aSymbol name := aSymbol! ! !RBAbstractClass methodsFor: 'accessing'! newMethods ^newMethods isNil ifTrue: [newMethods := IdentityDictionary new] ifFalse: [newMethods]! ! !RBAbstractClass methodsFor: 'accessing'! realClass ^realClass! ! !RBAbstractClass methodsFor: 'accessing'! realClass: aClass realClass := aClass. superclass isNil ifTrue: [superclass := LookupSuperclass]! ! !RBAbstractClass methodsFor: 'accessing'! removeSubclass: aRBClass self subclasses remove: aRBClass ifAbsent: []! ! !RBAbstractClass methodsFor: 'accessing'! removedMethods ^removedMethods isNil ifTrue: [removedMethods := Set new] ifFalse: [removedMethods]! ! !RBAbstractClass methodsFor: 'accessing' stamp: 'lr 10/26/2009 22:08'! soleInstance ^ self theNonMetaClass! ! !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: 'accessing'! superclass ^superclass == LookupSuperclass ifTrue: [model classFor: self realClass superclass] ifFalse: [superclass]! ! !RBAbstractClass methodsFor: 'accessing' stamp: 'lr 10/26/2009 22:09'! theMetaClass ^ model metaclassNamed: self name! ! !RBAbstractClass methodsFor: 'accessing' stamp: 'lr 10/26/2009 22:08'! theNonMetaClass ^ model classNamed: self name! ! !RBAbstractClass methodsFor: 'accessing'! withAllSubclasses ^(self allSubclasses) add: self; yourself! ! !RBAbstractClass methodsFor: 'accessing'! withAllSuperclasses ^(self allSuperclasses) add: self; yourself! ! !RBAbstractClass methodsFor: 'comparing'! = aRBClass ^self class = aRBClass class and: [self name = aRBClass name and: [self model = aRBClass model]]! ! !RBAbstractClass methodsFor: 'comparing'! hash ^self name hash bitXor: self class hash! ! !RBAbstractClass methodsFor: 'deprecated' stamp: 'lr 10/31/2009 17:32'! metaclass self deprecated: 'Use aClass>>#theMetaClass instead'. ^ self theMetaClass! ! !RBAbstractClass methodsFor: 'deprecated' stamp: 'lr 10/31/2009 17:32'! nonMetaclass self deprecated: 'Use aClass>>#theNonMetaClass instead'. ^ self theNonMetaClass! ! !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: 'enumerating' stamp: 'MarcusDenker 9/18/2012 14:12'! subclassesDo: aBlock self subclasses do: aBlock! ! !RBAbstractClass methodsFor: 'initialize-release'! initialize name := #'Unknown Class'! ! !RBAbstractClass methodsFor: 'initialize-release'! model: aRBSmalltalk model := aRBSmalltalk! ! !RBAbstractClass methodsFor: 'method accessing'! addMethod: aRBMethod self newMethods at: aRBMethod selector put: aRBMethod. removedMethods notNil ifTrue: [removedMethods remove: aRBMethod selector ifAbsent: []]! ! !RBAbstractClass methodsFor: 'method accessing'! allSelectors | class selectors | class := self. selectors := Set new. [class notNil] whileTrue: [selectors addAll: class selectors. class := class superclass]. ^selectors! ! !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 ^ self compile: aString withAttributesFrom: (self methodFor: (RBParser parseMethodPattern: aString))! ! !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: '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: 'method accessing' stamp: 'lr 11/1/2009 23:48'! compileTree: aRBMethodNode ^ (self methodFor: aRBMethodNode selector) compileTree: aRBMethodNode! ! !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: '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: '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: 'method accessing'! 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: 'method accessing'! parseTreeFor: aSelector | class | class := self whoDefinesMethod: aSelector. class isNil ifTrue: [^nil]. ^(class methodFor: aSelector) parseTree! ! !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: 'method accessing'! removeMethod: aSelector self newMethods removeKey: aSelector ifAbsent: []. model removeMethod: aSelector from: self. self removedMethods add: aSelector! ! !RBAbstractClass methodsFor: 'method accessing'! 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'! sourceCodeFor: aSelector | class | class := self whoDefinesMethod: aSelector. class isNil ifTrue: [^nil]. ^(class methodFor: aSelector) source! ! !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: '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: '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: '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: 'method accessing'! whoDefinesMethod: aSelector | sprClass | (self directlyDefinesMethod: aSelector) ifTrue: [^self]. sprClass := self superclass. ^sprClass isNil ifTrue: [nil] ifFalse: [sprClass whoDefinesMethod: aSelector]! ! !RBAbstractClass methodsFor: 'printing'! printOn: aStream aStream nextPutAll: self name! ! !RBAbstractClass methodsFor: 'printing'! storeOn: aStream aStream nextPutAll: 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'! definesInstanceVariable: aString (self directlyDefinesInstanceVariable: aString) ifTrue: [^true]. ^self superclass notNil and: [self superclass definesInstanceVariable: aString]! ! !RBAbstractClass methodsFor: 'testing'! definesMethod: aSelector (self directlyDefinesMethod: aSelector) ifTrue: [^true]. ^self superclass notNil and: [self superclass definesMethod: aSelector]! ! !RBAbstractClass methodsFor: 'testing'! definesPoolDictionary: aSymbol (self directlyDefinesPoolDictionary: aSymbol) ifTrue: [^true]. ^self inheritsPoolDictionaries and: [self superclass notNil and: [self superclass definesPoolDictionary: aSymbol]]! ! !RBAbstractClass methodsFor: 'testing'! definesVariable: aVariableName ^(self definesClassVariable: aVariableName) or: [self definesInstanceVariable: aVariableName]! ! !RBAbstractClass methodsFor: 'testing'! directlyDefinesClassVariable: aString self subclassResponsibility! ! !RBAbstractClass methodsFor: 'testing'! directlyDefinesInstanceVariable: aString ^self instanceVariableNames includes: aString! ! !RBAbstractClass methodsFor: 'testing'! directlyDefinesMethod: aSelector self isDefined ifTrue: [(self hasRemoved: aSelector) ifTrue: [^false]. (self realClass includesSelector: aSelector) ifTrue: [^true]]. ^newMethods notNil and: [newMethods includesKey: aSelector]! ! !RBAbstractClass methodsFor: 'testing'! directlyDefinesPoolDictionary: aString self subclassResponsibility! ! !RBAbstractClass methodsFor: 'testing'! directlyDefinesVariable: aVariableName ^(self directlyDefinesClassVariable: aVariableName) or: [self directlyDefinesInstanceVariable: aVariableName]! ! !RBAbstractClass methodsFor: 'testing'! hasRemoved: aSelector ^removedMethods notNil and: [removedMethods includes: aSelector]! ! !RBAbstractClass methodsFor: 'testing'! hierarchyDefinesClassVariable: aString (self definesClassVariable: aString) ifTrue: [^true]. ^(self allSubclasses detect: [:each | each directlyDefinesClassVariable: aString] ifNone: [nil]) notNil! ! !RBAbstractClass methodsFor: 'testing'! hierarchyDefinesInstanceVariable: aString (self definesInstanceVariable: aString) ifTrue: [^true]. ^(self allSubclasses detect: [:each | each directlyDefinesInstanceVariable: aString] ifNone: [nil]) notNil! ! !RBAbstractClass methodsFor: 'testing'! hierarchyDefinesMethod: aSelector (self definesMethod: aSelector) ifTrue: [^true]. ^self subclassRedefines: aSelector! ! !RBAbstractClass methodsFor: 'testing'! hierarchyDefinesPoolDictionary: aString (self definesPoolDictionary: aString) ifTrue: [^true]. ^(self allSubclasses detect: [:each | each directlyDefinesPoolDictionary: aString] ifNone: [nil]) notNil! ! !RBAbstractClass methodsFor: 'testing'! hierarchyDefinesVariable: aString (self definesVariable: aString) ifTrue: [^true]. ^(self allSubclasses detect: [:each | each directlyDefinesVariable: aString] ifNone: [nil]) notNil! ! !RBAbstractClass methodsFor: 'testing'! includesClass: aRBClass | currentClass | currentClass := self. [currentClass notNil and: [currentClass ~= aRBClass]] whileTrue: [currentClass := currentClass superclass]. ^currentClass = aRBClass! ! !RBAbstractClass methodsFor: 'testing'! inheritsPoolDictionaries ^false! ! !RBAbstractClass methodsFor: 'testing'! isAbstract (self whichSelectorsReferToSymbol: #subclassResponsibility) isEmpty ifFalse: [^true]. model allReferencesToClass: self do: [:each | ^false]. ^true! ! !RBAbstractClass methodsFor: 'testing'! isDefined ^self realClass notNil! ! !RBAbstractClass methodsFor: 'testing'! isMeta self subclassResponsibility! ! !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'! addInstanceVariable: aString self privateInstanceVariableNames add: aString. model addInstanceVariable: aString to: self! ! !RBAbstractClass methodsFor: 'variable accessing'! removeInstanceVariable: aString self privateInstanceVariableNames remove: aString. model removeInstanceVariable: aString from: self! ! !RBAbstractClass methodsFor: 'variable accessing'! 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: 'variable accessing'! typeOfClassVariable: aSymbol ^model classNamed: #Object! ! !RBAbstractClass methodsFor: 'variable accessing'! whoDefinesClassVariable: aString | sprClass | (self directlyDefinesClassVariable: aString) ifTrue: [^self]. sprClass := self superclass. ^sprClass isNil ifTrue: [nil] ifFalse: [sprClass whoDefinesClassVariable: aString]! ! !RBAbstractClass methodsFor: 'variable accessing'! whoDefinesInstanceVariable: aString | sprClass | (self directlyDefinesInstanceVariable: aString) ifTrue: [^self]. sprClass := self superclass. ^sprClass isNil ifTrue: [nil] ifFalse: [sprClass whoDefinesInstanceVariable: aString]! ! !RBAbstractClass methodsFor: 'private'! addSubclass: aRBClass self subclasses add: aRBClass! ! !RBAbstractClass methodsFor: 'private'! privateInstanceVariableNames instanceVariableNames isNil ifTrue: [self isDefined ifTrue: [self instanceVariableNames: self realClass instVarNames] ifFalse: [instanceVariableNames := OrderedCollection new]]. ^instanceVariableNames! ! !RBAbstractClass methodsFor: 'private'! superclass: aRBClass self superclass notNil ifTrue: [self superclass removeSubclass: self]. superclass := aRBClass. superclass notNil ifTrue: [superclass addSubclass: self].! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBAbstractClass class instanceVariableNames: ''! !RBAbstractClass class methodsFor: 'class initialization'! initialize LookupSuperclass := Object new! ! RBBlockLintRule subclass: #RBAbstractClassRule instanceVariableNames: 'subclassResponsibilitySymbol' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBAbstractClassRule commentStamp: '' prior: 0! See my #rationale.! !RBAbstractClassRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 11:22'! category ^ 'Potential Bugs'! ! !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: '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 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: '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 instanceVariableNames: ''! !RBAbstractClassRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBVariableRefactoring subclass: #RBAbstractClassVariableRefactoring instanceVariableNames: 'accessorsRefactoring' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBAbstractClassVariableRefactoring methodsFor: 'preconditions'! 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: '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: '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! ! !RBAbstractClassVariableRefactoring methodsFor: 'transforming'! createAccessors self performComponentRefactoring: self accessorsRefactoring! ! !RBAbstractClassVariableRefactoring methodsFor: 'transforming'! transform self createAccessors. self abstractInstanceReferences. self abstractClassReferences! ! !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]! ! RBRefactoringTest subclass: #RBAbstractClassVariableTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !RBAbstractClassVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testInheritedName self shouldFail: (RBAbstractClassVariableRefactoring variable: #DependentsFields class: RBBasicLintRuleTest)! ! !RBAbstractClassVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testMetaClassFailure self shouldFail: (RBAbstractClassVariableRefactoring variable: #RecursiveSelfRule class: RBTransformationRuleTest class)! ! !RBAbstractClassVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testNonExistantName self shouldFail: (RBAbstractClassVariableRefactoring variable: #Foo class: RBBasicLintRuleTest)! ! !RBAbstractClassVariableTest methodsFor: 'set up' stamp: 'md 7/25/2005 15:17'! setUp super setUp. model := Compiler evaluate: self abstractVariableTestData.! ! !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: '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: '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')! ! Object subclass: #RBAbstractCondition instanceVariableNames: 'errorMacro' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Conditions'! !RBAbstractCondition methodsFor: 'accessing'! errorBlock ^self errorBlockFor: false! ! !RBAbstractCondition methodsFor: 'accessing'! errorString ^self errorStringFor: false! ! !RBAbstractCondition methodsFor: 'checking'! check self subclassResponsibility! ! !RBAbstractCondition methodsFor: 'logical operations'! & aCondition ^RBConjunctiveCondition new left: self right: aCondition! ! !RBAbstractCondition methodsFor: 'logical operations'! not ^RBNegationCondition on: self! ! !RBAbstractCondition methodsFor: 'logical operations'! | aCondition "(A | B) = (A not & B not) not" ^(self not & aCondition not) not! ! !RBAbstractCondition methodsFor: 'private'! errorBlockFor: aBoolean ^nil! ! !RBAbstractCondition methodsFor: 'private'! errorMacro ^errorMacro isNil ifTrue: ['unknown'] ifFalse: [errorMacro]! ! !RBAbstractCondition methodsFor: 'private'! errorMacro: aString errorMacro := aString! ! !RBAbstractCondition methodsFor: 'private'! errorStringFor: aBoolean ^self errorMacro expandMacrosWith: aBoolean! ! RBVariableRefactoring subclass: #RBAbstractInstanceVariableRefactoring instanceVariableNames: 'accessorsRefactoring' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBAbstractInstanceVariableRefactoring methodsFor: 'preconditions'! preconditions ^RBCondition directlyDefinesInstanceVariable: variableName in: class! ! !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'! createAccessors self performComponentRefactoring: self accessorsRefactoring! ! !RBAbstractInstanceVariableRefactoring methodsFor: 'transforming'! transform self createAccessors. self abstractReferences! ! !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]! ! RBRefactoringTest subclass: #RBAbstractInstanceVariableTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !RBAbstractInstanceVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testInheritedName self shouldFail: (RBAbstractInstanceVariableRefactoring variable: 'name' class: RBBasicLintRuleTest)! ! !RBAbstractInstanceVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testNonExistantName self shouldFail: (RBAbstractInstanceVariableRefactoring variable: 'foo' class: RBBasicLintRuleTest)! ! !RBAbstractInstanceVariableTest methodsFor: 'set up' stamp: 'md 7/25/2005 15:17'! setUp super setUp. model := Compiler evaluate: self abstractVariableTestData.! ! !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: '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: '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'! 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')! ! RBRefactoring subclass: #RBAbstractVariablesRefactoring instanceVariableNames: 'tree fromClass instVarReaders instVarWriters classVarReaders classVarWriters toClasses ignore' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBAbstractVariablesRefactoring methodsFor: 'accessing'! parseTree ^tree! ! !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: 'preconditions'! preconditions ^RBCondition empty! ! !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 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: '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 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: '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 10/26/2009 22:08'! classVariableNames | nonMetaClass | nonMetaClass := fromClass theNonMetaClass. ^ (nonMetaClass allClassVariableNames collect: [ :each | each asString ]) asSet! ! !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'! instanceVariableNames ^fromClass allInstanceVariableNames asSet! ! !RBAbstractVariablesRefactoring methodsFor: 'transforming'! 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'! 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: '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'! 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 class instanceVariableNames: ''! !RBAbstractVariablesRefactoring class methodsFor: 'instance creation'! model: aRBSmalltalk abstractVariablesIn: aBRProgramNode from: fromBehavior toAll: behaviorCollection ^self model: aRBSmalltalk abstractVariablesIn: aBRProgramNode from: fromBehavior toAll: behaviorCollection ignoring: nil! ! !RBAbstractVariablesRefactoring class methodsFor: 'instance creation'! model: aRBSmalltalk abstractVariablesIn: aBRProgramNode from: fromBehavior toAll: behaviorCollection ignoring: aVariableName ^(self new) model: aRBSmalltalk; abstractVariablesIn: aBRProgramNode from: fromBehavior toAll: behaviorCollection ignoring: aVariableName; yourself! ! RBClassRefactoring subclass: #RBAccessorClassRefactoring instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NautilusRefactoring-Refactorings'! !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: 'preconditions'! preconditions ^ self refactorings inject: RBCondition empty into: [ :result :each | result & each preconditions ]! ! !RBAccessorClassRefactoring methodsFor: 'transforming'! transform self refactorings do: [ :each | self performComponentRefactoring: each ]! ! RBRefactoryDefinitionChange subclass: #RBAddClassChange instanceVariableNames: 'superclassName instanceVariableNames classVariableNames poolDictionaryNames category' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Changes'! !RBAddClassChange methodsFor: '*NautilusRefactoring'! nameToDisplay ^ self changeString! ! !RBAddClassChange methodsFor: '*NautilusRefactoring'! textToDisplay ^ self definition! ! !RBAddClassChange methodsFor: 'accessing' stamp: 'lr 9/30/2010 18:52'! category ^ category! ! !RBAddClassChange methodsFor: 'accessing' stamp: 'lr 9/30/2010 18:52'! classVariableNames ^ classVariableNames! ! !RBAddClassChange methodsFor: 'accessing' stamp: 'lr 9/30/2010 18:52'! instanceVariableNames ^ instanceVariableNames! ! !RBAddClassChange methodsFor: 'accessing' stamp: 'lr 9/30/2010 18:52'! poolDictionaryNames ^ poolDictionaryNames! ! !RBAddClassChange methodsFor: 'accessing' stamp: 'lr 9/30/2010 18:52'! superclassName ^ superclassName! ! !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 methodsFor: 'private' stamp: 'lr 10/2/2010 13:37'! definitionClass ^ Smalltalk globals at: (self superclassName ifNil: [ ^ ProtoObject ])! ! !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 class instanceVariableNames: ''! !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' ]! ! RBClassRefactoring subclass: #RBAddClassRefactoring instanceVariableNames: 'category superclass subclasses' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBAddClassRefactoring methodsFor: 'initialize-release'! 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'! 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'! 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 instanceVariableNames: ''! !RBAddClassRefactoring class methodsFor: 'instance creation'! addClass: aName superclass: aClass subclasses: aCollection category: aSymbol ^self new addClass: aName superclass: aClass subclasses: aCollection category: aSymbol! ! !RBAddClassRefactoring class methodsFor: 'instance creation'! model: aRBSmalltalk addClass: aName superclass: aClass subclasses: aCollection category: aSymbol ^(self new) model: aRBSmalltalk; addClass: aName superclass: aClass subclasses: aCollection category: aSymbol; yourself! ! RBRefactoringTest subclass: #RBAddClassTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !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: '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: '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'! testModelExistingName | refactoring | refactoring := RBAddClassRefactoring model: model addClass: #Foo superclass: Object subclasses: #() category: #'Refactory-Testing'. self shouldFail: refactoring! ! !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: 'set up' stamp: 'md 7/25/2005 15:17'! setUp super setUp. model := Compiler evaluate: self abstractVariableTestData.! ! !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: '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)! ! RBRefactoryDefinitionChange subclass: #RBAddClassTraitChange instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Changes'! !RBAddClassTraitChange methodsFor: 'converting' stamp: 'lr 9/30/2010 19:47'! asUndoOperation ^ self class definition: self changeClass classTrait definition! ! !RBAddClassTraitChange methodsFor: 'initialization' stamp: 'lr 10/1/2010 14:36'! fillOutDefinition: aDictionary className := (aDictionary at: '`traitName') asSymbol! ! !RBAddClassTraitChange methodsFor: 'private' stamp: 'lr 9/30/2010 19:47'! definitionClass ^ self changeClass! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBAddClassTraitChange class instanceVariableNames: ''! !RBAddClassTraitChange class methodsFor: 'private' stamp: 'lr 9/30/2010 19:46'! definitionPatterns ^ #('`traitName classTrait uses: `@traitComposition')! ! RBRefactoryVariableChange subclass: #RBAddClassVariableChange instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Changes'! !RBAddClassVariableChange methodsFor: 'accessing' stamp: 'lr 10/15/2010 08:31'! changeClass: aBehavior super changeClass: aBehavior. isMeta := false! ! !RBAddClassVariableChange methodsFor: 'converting' stamp: 'lr 9/8/2011 20:10'! asUndoOperation ^ RBRemoveClassVariableChange remove: self variable from: self changeClass! ! !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: 'private' stamp: 'lr 3/20/2011 11:27'! changeSymbol ^ #addClassVarNamed:! ! RBVariableRefactoring subclass: #RBAddClassVariableRefactoring instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBAddClassVariableRefactoring methodsFor: 'preconditions'! 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'! transform class addClassVariable: variableName! ! RBRefactoringTest subclass: #RBAddClassVariableTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !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'! testMetaClassFailure self shouldFail: (RBAddClassVariableRefactoring variable: #VariableName class: RBTransformationRuleTest class)! ! !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: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testModelAlreadyExistingName | refactoring | refactoring := RBAddClassVariableRefactoring model: model variable: #ClassVarName2 class: (model classNamed: #Bar). self shouldFail: refactoring! ! !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: 'set up' stamp: 'md 7/25/2005 15:17'! setUp super setUp. model := Compiler evaluate: self abstractVariableTestData.! ! !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: '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)! ! RBRefactoryVariableChange subclass: #RBAddInstanceVariableChange instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Changes'! !RBAddInstanceVariableChange methodsFor: 'converting' stamp: 'lr 9/8/2011 20:10'! asUndoOperation ^ RBRemoveInstanceVariableChange remove: self variable from: self changeClass! ! !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:! ! RBVariableRefactoring subclass: #RBAddInstanceVariableRefactoring instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBAddInstanceVariableRefactoring methodsFor: 'preconditions'! preconditions ^(RBCondition isValidInstanceVariableName: variableName for: class) & (RBCondition hierarchyOf: class definesVariable: variableName) not & (RBCondition isGlobal: variableName in: self model) not! ! !RBAddInstanceVariableRefactoring methodsFor: 'transforming'! transform class addInstanceVariable: variableName! ! RBRefactoringTest subclass: #RBAddInstanceVariableTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !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: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testModelAlreadyExistingName | refactoring | refactoring := RBAddInstanceVariableRefactoring model: model variable: 'instVarName1' class: (model classNamed: #Bar). 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'! 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'! 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: 'set up' stamp: 'md 7/25/2005 15:17'! setUp super setUp. model := Compiler evaluate: self abstractVariableTestData.! ! !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: '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')! ! RBRefactoryDefinitionChange subclass: #RBAddMetaclassChange instanceVariableNames: 'classInstanceVariableNames' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Changes'! !RBAddMetaclassChange methodsFor: 'accessing' stamp: 'lr 9/30/2010 18:57'! classInstanceVariableNames ^ classInstanceVariableNames! ! !RBAddMetaclassChange methodsFor: 'converting' stamp: 'lr 9/30/2010 14:32'! asUndoOperation ^ self class definition: self changeClass class definition! ! !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: 'private' stamp: 'lr 9/30/2010 14:21'! definitionClass ^ self changeClass! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBAddMetaclassChange class instanceVariableNames: ''! !RBAddMetaclassChange class methodsFor: 'private' stamp: 'lr 9/30/2010 19:19'! definitionPatterns ^ #('`className class instanceVariableNames: `#instanceVariableNames' '`className class uses: `@traitComposition instanceVariableNames: `#instanceVariableNames')! ! RBRefactoryClassChange subclass: #RBAddMethodChange instanceVariableNames: 'source selector protocols controller definedSelector' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Changes'! !RBAddMethodChange methodsFor: '*NautilusRefactoring'! accept: aText notifying: aController "Just to make sure that it compiles, try with the standard compiler." | compilerClass | compilerClass := self changeClass ifNil: [ Object compilerClass ] ifNotNil: [:changeClass | changeClass compilerClass ]. compilerClass new compile: aText asString in: self changeClass classified: nil notifying: aController ifFail: [ ^ false ]. self class: self changeClass protocol: self protocol source: aText asString. ^ true! ! !RBAddMethodChange methodsFor: '*NautilusRefactoring'! oldVersionTextToDisplay | class | class := Smalltalk at: className asSymbol ifAbsent: [ ^ super oldVersionTextToDisplay ]. ^ class methodDict at: self selector ifPresent: [:method | method sourceCode ] ifAbsent: [ super oldVersionTextToDisplay ]! ! !RBAddMethodChange methodsFor: '*NautilusRefactoring'! textToDisplay ^ self source! ! !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: '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: 'accessing' stamp: 'lr 9/30/2010 20:02'! definedSelector ^ definedSelector! ! !RBAddMethodChange methodsFor: 'accessing' stamp: 'lr 9/7/2010 19:10'! protocol ^ self protocols first! ! !RBAddMethodChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 21:24'! protocols ^ protocols! ! !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: 'accessing' stamp: 'lr 11/1/2009 23:25'! source ^ source! ! !RBAddMethodChange methodsFor: 'comparing' stamp: 'lr 9/6/2010 21:24'! = anAddMethodChange super = anAddMethodChange ifFalse: [ ^ false ]. ^ self parseTree = anAddMethodChange parseTree! ! !RBAddMethodChange methodsFor: 'comparing' stamp: 'lr 9/6/2010 21:25'! hash ^ self parseTree hash! ! !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 methodsFor: 'initialize-release'! class: aClass protocol: aProtocol source: aString self changeClass: aClass. self protocols: aProtocol. source := aString! ! !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: '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: 'initialize-release' stamp: 'lr 9/30/2010 20:02'! controller: aController controller := aController! ! !RBAddMethodChange methodsFor: 'initialize-release' stamp: 'lr 9/7/2010 19:10'! protocols: aCollection protocols := aCollection isString ifTrue: [ Array with: aCollection ] ifFalse: [ aCollection ]. protocols isNil ifTrue: [ protocols := #(accessing) ]! ! !RBAddMethodChange methodsFor: 'printing' stamp: 'lr 4/7/2010 08:22'! changeString ^ self displayClassName , '>>' , self selector! ! !RBAddMethodChange methodsFor: 'printing' stamp: 'lr 12/29/2011 17:42'! printOn: aStream aStream nextPut: $!!; nextPutAll: self displayClassName; nextPutAll: ' methodsFor: '''; nextPutAll: self protocol; nextPutAll: ''' stamp: '; print: RBPlatform current changeStamp; nextPut: $!!; cr; nextPutAll: (source copyReplaceAll: '!!' with: '!!!!'); nextPutAll: '!! !!'! ! !RBAddMethodChange methodsFor: 'private' stamp: 'lr 9/30/2010 20:02'! controller ^ controller! ! !RBAddMethodChange methodsFor: 'private' stamp: 'lr 9/6/2010 21:27'! parseTree ^ RBParser parseMethod: source onError: [ :str :pos | ^ nil ]! ! !RBAddMethodChange methodsFor: 'private' stamp: 'lr 10/14/2010 20:50'! primitiveExecute definedSelector := self changeClass compile: self source classified: self protocol notifying: self controller! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBAddMethodChange class instanceVariableNames: ''! !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: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: 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:04'! compile: aString in: aClass for: aController ^ self new class: aClass source: aString contoller: aController! ! RBMethodRefactoring subclass: #RBAddMethodRefactoring instanceVariableNames: 'protocols source' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBAddMethodRefactoring methodsFor: 'initialize-release'! 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'! 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'! transform class compile: source classified: protocols! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBAddMethodRefactoring class instanceVariableNames: ''! !RBAddMethodRefactoring class methodsFor: 'instance creation'! addMethod: aString toClass: aClass inProtocols: protocolList ^self new addMethod: aString toClass: aClass inProtocols: protocolList! ! !RBAddMethodRefactoring class methodsFor: 'instance creation'! model: aRBSmalltalk addMethod: aString toClass: aClass inProtocols: protocolList ^(self new) model: aRBSmalltalk; addMethod: aString toClass: aClass inProtocols: protocolList; yourself! ! RBRefactoringTest subclass: #RBAddMethodTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !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'! testExistingSelector self shouldFail: (RBAddMethodRefactoring addMethod: 'printString ^super printString' toClass: RBBasicLintRuleTest inProtocols: #(#accessing ))! ! !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: '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: 'md 7/25/2005 15:17'! setUp super setUp. model := Compiler evaluate: self abstractVariableTestData.! ! !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: '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')! ! RBChangeMethodNameRefactoring subclass: #RBAddParameterRefactoring instanceVariableNames: 'initializer senders' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !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'! 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: '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: '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: '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: 'printing'! 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: '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: 'private'! 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 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: 'private'! 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 methodsFor: 'private'! senders senders isNil ifTrue: [senders := Set new. self model allReferencesTo: oldSelector do: [:each | senders add: each modelClass]]. ^senders! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBAddParameterRefactoring class instanceVariableNames: ''! !RBAddParameterRefactoring class methodsFor: 'instance creation'! addParameterToMethod: aSelector in: aClass newSelector: newSelector initializer: init ^self new addParameterToMethod: aSelector in: aClass newSelector: newSelector initializer: init! ! !RBAddParameterRefactoring class methodsFor: 'instance creation'! model: aRBSmalltalk addParameterToMethod: aSelector in: aClass newSelector: newSelector initializer: init ^(self new) model: aRBSmalltalk; addParameterToMethod: aSelector in: aClass newSelector: newSelector initializer: init; yourself! ! RBRefactoringTest subclass: #RBAddParameterTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !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: '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'! 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'! testNonExistantName self shouldFail: (RBAddParameterRefactoring addParameterToMethod: #name1 in: RBLintRuleTest newSelector: #name1: initializer: 'nil')! ! !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: 'set up' stamp: 'md 7/25/2005 15:17'! setUp super setUp. model := Compiler evaluate: self abstractVariableTestData.! ! !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: '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)! ! !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: '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)! ! RBRefactoryVariableChange subclass: #RBAddPoolVariableChange instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Changes'! !RBAddPoolVariableChange methodsFor: 'accessing' stamp: 'lr 10/15/2010 08:31'! changeClass: aBehavior super changeClass: aBehavior. isMeta := false! ! !RBAddPoolVariableChange methodsFor: 'converting' stamp: 'lr 9/8/2011 20:10'! asUndoOperation ^ RBRemovePoolVariableChange remove: self variable from: self changeClass! ! !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: 'private' stamp: 'lr 9/6/2010 21:30'! changeSymbol ^ #addSharedPool:! ! RBBlockLintRule subclass: #RBAddRemoveDependentsRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBAddRemoveDependentsRule commentStamp: '' prior: 0! See my #rationale.! !RBAddRemoveDependentsRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 14:11'! category ^ 'Potential Bugs'! ! !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: '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 9/8/2011 20:32'! resultClass ^ RBClassEnvironment! ! !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 instanceVariableNames: ''! !RBAddRemoveDependentsRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBRefactoryDefinitionChange subclass: #RBAddTraitChange instanceVariableNames: 'category' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Changes'! !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 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: 'private' stamp: 'lr 9/30/2010 19:39'! definitionClass ^ Trait! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBAddTraitChange class instanceVariableNames: ''! !RBAddTraitChange class methodsFor: 'private' stamp: 'lr 9/30/2010 19:46'! definitionPatterns ^ #('Trait named: `#traitName uses: `@traitComposition category: `#category')! ! RBTransformationRule subclass: #RBAllAnyNoneSatisfyRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-TransformationRules'! !RBAllAnyNoneSatisfyRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:47'! category ^ 'Coding Idiom Violation'! ! !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: '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 class instanceVariableNames: ''! !RBAllAnyNoneSatisfyRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBBrowserEnvironmentWrapper subclass: #RBAndEnvironment instanceVariableNames: 'andedEnvironment' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Environment'! !RBAndEnvironment methodsFor: 'accessing'! classesDo: aBlock environment classesDo: [:each | (self includesClass: each) ifTrue: [aBlock value: each]]! ! !RBAndEnvironment methodsFor: 'accessing'! numberSelectors | total | total := 0. environment classesAndSelectorsDo: [:each :sel | (andedEnvironment includesSelector: sel in: each) ifTrue: [total := total + 1]]. ^total! ! !RBAndEnvironment methodsFor: 'accessing'! problemCount ^environment isClassEnvironment ifTrue: [self numberClasses] ifFalse: [super problemCount]! ! !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'! selectorsForClass: aClass do: aBlock environment selectorsForClass: aClass do: [:each | (andedEnvironment includesSelector: each in: aClass) ifTrue: [aBlock value: each]]! ! !RBAndEnvironment methodsFor: 'initialize-release'! andedEnvironment: aBrowserEnvironment andedEnvironment := aBrowserEnvironment! ! !RBAndEnvironment methodsFor: 'printing'! storeOn: aStream aStream nextPut: $(. environment storeOn: aStream. aStream nextPutAll: ' & '. andedEnvironment storeOn: aStream. aStream nextPut: $)! ! !RBAndEnvironment methodsFor: 'testing'! includesCategory: aCategory ^(self classNamesFor: aCategory) isEmpty not! ! !RBAndEnvironment methodsFor: 'testing'! 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: 'testing'! includesProtocol: aProtocol in: aClass ^(self selectorsFor: aProtocol in: aClass) isEmpty not! ! !RBAndEnvironment methodsFor: 'testing'! includesSelector: aSelector in: aClass ^(environment includesSelector: aSelector in: aClass) and: [andedEnvironment includesSelector: aSelector in: aClass]! ! !RBAndEnvironment methodsFor: 'private'! andedEnvironment ^andedEnvironment! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBAndEnvironment class instanceVariableNames: ''! !RBAndEnvironment class methodsFor: 'instance creation'! onEnvironment: anEnvironment and: anotherEnvironment ^(self onEnvironment: anEnvironment) andedEnvironment: anotherEnvironment; yourself! ! RBLocalBinding subclass: #RBArgumentBinding instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AST-Semantic-Binding'! !RBArgumentBinding methodsFor: 'testing' stamp: 'lr 4/27/2010 15:28'! isReadonly ^ true! ! !RBArgumentBinding methodsFor: 'testing-type' stamp: 'lr 4/28/2010 09:36'! isArgumentBinding ^ true! ! RBVariableNode subclass: #RBArgumentNode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Nodes'! !RBArgumentNode commentStamp: '' prior: 0! 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: 'visitor' stamp: 'CamilloBruni 12/15/2011 14:23'! accept: aProgramNodeVisitor ^aProgramNodeVisitor visitArgumentNode: self! ! !RBArgumentNode methodsFor: 'visitor' stamp: 'CamilloBruni 12/15/2011 14:22'! acceptVisitor: aProgramNodeVisitor ^aProgramNodeVisitor acceptArgumentNode: self! ! RBSpellingRule subclass: #RBArgumentVariableNamesSpellingRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Spelling'! !RBArgumentVariableNamesSpellingRule commentStamp: '' prior: 0! See #name for the area where I check spelling.! !RBArgumentVariableNamesSpellingRule methodsFor: 'accessing' stamp: 'lr 2/24/2009 07:57'! name ^ 'Argument variable names'! ! !RBArgumentVariableNamesSpellingRule methodsFor: 'running' stamp: 'lr 1/21/2010 21:31'! checkMethod: aContext aContext parseTree allArgumentVariables do: [ :name | (self checkIdentifier: name) do: [ :each | result addSearchString: each; addClass: aContext selectedClass selector: aContext selector ] ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBArgumentVariableNamesSpellingRule class instanceVariableNames: ''! !RBArgumentVariableNamesSpellingRule 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" ^'ArgumentVariableNamesSpellingRule'! ! RBValueNode subclass: #RBArrayNode instanceVariableNames: 'left right statements periods' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Nodes'! !RBArrayNode commentStamp: '' prior: 0! 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: 'accessing' stamp: 'lr 11/1/2009 18:36'! children ^ self statements! ! !RBArrayNode methodsFor: 'accessing' stamp: 'lr 4/26/2010 20:44'! precedence ^0! ! !RBArrayNode methodsFor: 'accessing' stamp: 'lr 11/1/2009 19:52'! startWithoutParentheses ^ left! ! !RBArrayNode methodsFor: 'accessing' stamp: 'lr 11/1/2009 20:25'! statementComments ^self comments! ! !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: '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-token' stamp: 'lr 11/1/2009 19:52'! left: anInteger left := anInteger! ! !RBArrayNode methodsFor: 'accessing-token' stamp: 'lr 11/1/2009 20:44'! periods ^ periods! ! !RBArrayNode methodsFor: 'accessing-token' stamp: 'lr 2/12/2010 19:23'! periods: anArray periods := anArray! ! !RBArrayNode methodsFor: 'accessing-token' stamp: 'lr 11/1/2009 19:52'! right ^ right! ! !RBArrayNode methodsFor: 'accessing-token' stamp: 'lr 11/1/2009 19:52'! right: anInteger right := anInteger! ! !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: '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: 'adding nodes' stamp: 'lr 1/4/2012 21:42'! addNodeFirst: aNode statements := statements asOrderedCollection addFirst: aNode; yourself. aNode parent: self. ^ aNode! ! !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:44'! addNodes: aCollection before: anotherNode aCollection do: [ :each | self addNode: each before: anotherNode ]. ^ aCollection! ! !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: '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: '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: 'comparing' stamp: 'lr 3/7/2010 13:48'! hash ^ self hashForCollection: self statements! ! !RBArrayNode methodsFor: 'copying' stamp: 'lr 11/1/2009 22:36'! postCopy super postCopy. self statements: (self statements collect: [ :each | each copy ])! ! !RBArrayNode methodsFor: 'initialize-release' stamp: 'lr 8/14/2011 12:01'! initialize super initialize. statements := periods := #()! ! !RBArrayNode methodsFor: 'matching' stamp: 'lr 11/24/2009 23:35'! copyInContext: aDictionary ^ self class statements: (self copyList: self statements inContext: aDictionary)! ! !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: '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: 'testing' stamp: 'lr 10/18/2009 16:11'! isArray ^ true! ! !RBArrayNode methodsFor: 'testing' stamp: 'ls 1/24/2000 00:28'! lastIsReturn statements isEmpty ifTrue:[ ^false ]. ^statements last lastIsReturn! ! !RBArrayNode methodsFor: 'testing' stamp: 'lr 11/1/2009 20:24'! needsParenthesis ^ false! ! !RBArrayNode methodsFor: 'testing' stamp: 'lr 11/1/2009 18:39'! references: aVariableName ^ statements anySatisfy: [ :each | each references: aVariableName ]! ! !RBArrayNode methodsFor: 'testing' stamp: 'lr 11/1/2009 18:40'! uses: aNode ^ (statements anySatisfy: [ :each | each == aNode ]) or: [ self isUsed ]! ! !RBArrayNode methodsFor: 'visitor' stamp: 'CamilloBruni 2/3/2012 16:32'! accept: aProgramNodeVisitor ^ aProgramNodeVisitor visitArrayNode: self! ! !RBArrayNode methodsFor: 'visitor' stamp: 'ajh 3/17/2003 00:25'! acceptVisitor: aProgramNodeVisitor ^ aProgramNodeVisitor acceptArrayNode: 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 class instanceVariableNames: ''! !RBArrayNode class methodsFor: 'instance creation' stamp: 'ajh 3/4/2003 02:03'! statements: statements ^ self new statements: statements! ! RBParseTreeLintRule subclass: #RBAsOrderedCollectionNotNeededRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBAsOrderedCollectionNotNeededRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 16:19'! category ^'Optimization'! ! !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: '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: 'initialization' stamp: 'lr 5/15/2010 17:43'! initialize super initialize. self matcher matchesAnyOf: #( '`@node addAll: `{ :node | node isMessage and: [ #(asOrderedCollection asArray) includes: node selector ] }' '`@node withAll: `{ :node | node isMessage and: [ #(asOrderedCollection asArray) includes: node selector ] }' ) do: [ :node :answer | node ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBAsOrderedCollectionNotNeededRule class instanceVariableNames: ''! !RBAsOrderedCollectionNotNeededRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBParseTreeLintRule subclass: #RBAssignmentInBlockRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBAssignmentInBlockRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 16:20'! category ^'Coding Idiom Violation'! ! !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: '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: '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 class instanceVariableNames: ''! !RBAssignmentInBlockRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBTransformationRule subclass: #RBAssignmentInIfTrueRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-TransformationRules'! !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 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: 'accessing' stamp: 'lr 9/7/2010 20:25'! rationale ^ 'Moving assignements outside blocks leads to shorter and more efficient code.'! ! !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 class instanceVariableNames: ''! !RBAssignmentInIfTrueRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBValueNode subclass: #RBAssignmentNode instanceVariableNames: 'variable assignment value' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Nodes'! !RBAssignmentNode commentStamp: '' prior: 0! 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: 'accessing' stamp: 'lr 11/2/2009 20:50'! assignmentOperator ^ (self assignmentPosition notNil and: [ self source notNil and: [ (self source at: self assignmentPosition ifAbsent: [ nil ]) = $_ ] ]) ifTrue: [ '_' ] ifFalse: [ ':=' ]! ! !RBAssignmentNode methodsFor: 'accessing' stamp: 'lr 11/2/2009 20:50'! assignmentPosition ^ assignment! ! !RBAssignmentNode methodsFor: 'accessing'! children ^Array with: value with: variable! ! !RBAssignmentNode methodsFor: 'accessing'! precedence ^5! ! !RBAssignmentNode methodsFor: 'accessing'! startWithoutParentheses ^variable start! ! !RBAssignmentNode methodsFor: 'accessing'! stopWithoutParentheses ^value stop! ! !RBAssignmentNode methodsFor: 'accessing'! value ^value! ! !RBAssignmentNode methodsFor: 'accessing'! value: aValueNode value := aValueNode. value parent: self! ! !RBAssignmentNode methodsFor: 'accessing'! variable ^variable! ! !RBAssignmentNode methodsFor: 'accessing'! variable: varNode variable := varNode. variable parent: self! ! !RBAssignmentNode methodsFor: 'accessing-token' stamp: 'lr 2/12/2010 19:23'! assignment ^ assignment! ! !RBAssignmentNode methodsFor: 'accessing-token' stamp: 'lr 2/12/2010 19:24'! assignment: anInteger assignment := anInteger! ! !RBAssignmentNode methodsFor: 'comparing'! = anObject self == anObject ifTrue: [^true]. self class = anObject class ifFalse: [^false]. ^self variable = anObject variable and: [self value = anObject value]! ! !RBAssignmentNode methodsFor: 'comparing'! 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: 'comparing'! hash ^self variable hash bitXor: self value hash! ! !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: 'initialize-release'! variable: aVariableNode value: aValueNode position: anInteger self variable: aVariableNode. self value: aValueNode. assignment := anInteger! ! !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: '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: 'querying'! bestNodeFor: anInterval (self intersectsInterval: anInterval) ifFalse: [^nil]. (self containedBy: anInterval) ifTrue: [^self]. assignment isNil ifTrue: [^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: 'replacing'! replaceNode: aNode withNode: anotherNode value == aNode ifTrue: [self value: anotherNode]. variable == aNode ifTrue: [self variable: anotherNode]! ! !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'! assigns: aVariableName ^variable name = aVariableName or: [value assigns: aVariableName]! ! !RBAssignmentNode methodsFor: 'testing'! directlyUses: aNode ^aNode = value ifTrue: [true] ifFalse: [self isDirectlyUsed]! ! !RBAssignmentNode methodsFor: 'testing'! isAssignment ^true! ! !RBAssignmentNode methodsFor: 'testing'! needsParenthesis ^parent isNil ifTrue: [false] ifFalse: [self precedence > parent precedence]! ! !RBAssignmentNode methodsFor: 'testing'! uses: aNode ^aNode = value ifTrue: [true] ifFalse: [self isUsed]! ! !RBAssignmentNode methodsFor: 'visitor' stamp: 'CamilloBruni 2/3/2012 16:33'! accept: aProgramNodeVisitor ^aProgramNodeVisitor visitAssignmentNode: self! ! !RBAssignmentNode methodsFor: 'visitor' stamp: 'CamilloBruni 12/14/2011 16:10'! acceptIgnoreResult: visitor ^ visitor visitAssignmentStatement: self! ! !RBAssignmentNode methodsFor: 'visitor'! acceptVisitor: aProgramNodeVisitor ^aProgramNodeVisitor acceptAssignmentNode: self! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBAssignmentNode class instanceVariableNames: ''! !RBAssignmentNode class methodsFor: 'instance creation'! variable: aVariableNode value: aValueNode ^self variable: aVariableNode value: aValueNode position: nil! ! !RBAssignmentNode class methodsFor: 'instance creation'! variable: aVariableNode value: aValueNode position: anInteger ^(self new) variable: aVariableNode value: aValueNode position: anInteger; yourself! ! RBToken subclass: #RBAssignmentToken instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Tokens'! !RBAssignmentToken commentStamp: 'md 8/9/2005 14:51' prior: 0! RBAssignmentToken is the first-class representation of the assignment token ':=' ! !RBAssignmentToken methodsFor: 'testing'! isAssignment ^true! ! !RBAssignmentToken methodsFor: 'private'! length ^2! ! RBParseTreeLintRule subclass: #RBAssignmentWithoutEffectRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !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'! group ^ 'Unnecessary code'! ! !RBAssignmentWithoutEffectRule methodsFor: 'accessing' stamp: 'lr 3/13/2009 13:55'! name ^ 'Assignment has no effect'! ! !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 5/15/2010 15:09'! severity ^ #information! ! !RBAssignmentWithoutEffectRule methodsFor: 'initialization' stamp: 'lr 3/13/2009 13:56'! initialize super initialize. self matcher matches: '`var := `var' do: [ :node :answer | node ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBAssignmentWithoutEffectRule class instanceVariableNames: ''! !RBAssignmentWithoutEffectRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBTransformationRule subclass: #RBAtIfAbsentRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-TransformationRules'! !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 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: 'accessing' stamp: 'lr 9/7/2010 20:26'! rationale ^ 'The use of #at:ifAbsentPut: leads to more readable and faster code.'! ! !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 class instanceVariableNames: ''! !RBAtIfAbsentRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBBlockLintRule subclass: #RBBadMessageRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBBadMessageRule commentStamp: '' prior: 0! 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: '*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'! group ^ 'Miscellaneous'! ! !RBBadMessageRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Sends "questionable" message'! ! !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: 'running' stamp: 'lr 2/24/2009 00:10'! checkClass: aContext | selectors | selectors := self badSelectors inject: Set new into: [ :set :each | set addAll: (aContext selectedClass whichSelectorsReferTo: each); yourself ]. selectors do: [ :each | result addClass: aContext selectedClass selector: each ]. selectors isEmpty ifFalse: [ result searchStrings: self badSelectors ]! ! !RBBadMessageRule methodsFor: 'private' stamp: 'StephaneDucasse 12/22/2012 22:24'! badSelectors ^ #( #become: #isKindOf: #changeClassToThatOf: #respondsTo: #isMemberOf: #performMethod: #performMethod:arguments: #performMethod:with: #performMethod:with:with: #performMethod:with:with:with: #allOwners #instVarAt: #instVarAt:put: #nextInstance instVarsInclude: #nextObject #halt caseOf: caseOf:otherwise: caseError isThisEverCalled isThisEverCalled: becomeForward: instVarNamed: instVarNamed:put: someObject primitiveChangeClassTo:)! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBBadMessageRule class instanceVariableNames: ''! !RBBadMessageRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBLintRule subclass: #RBBasicLintRule instanceVariableNames: 'result' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics'! !RBBasicLintRule commentStamp: '' prior: 0! 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 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'! problemCount ^ self result problemCount! ! !RBBasicLintRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 21:40'! result ^ result! ! !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: 'running' stamp: 'lr 2/23/2009 21:39'! resetResult result := self resultClass new. result label: self name! ! !RBBasicLintRule methodsFor: 'testing' stamp: 'lr 2/23/2009 21:37'! isEmpty ^ self result isEmpty! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBBasicLintRule class instanceVariableNames: ''! !RBBasicLintRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBLintRuleTest subclass: #RBBasicLintRuleTest instanceVariableNames: 'classBlock methodBlock result' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core-Data'! !RBBasicLintRuleTest methodsFor: 'accessing'! checkClass: aSmalllintContext ^classBlock value: aSmalllintContext value: result! ! !RBBasicLintRuleTest methodsFor: 'accessing'! checkMethod: aSmalllintContext ^methodBlock value: aSmalllintContext value: result! ! !RBBasicLintRuleTest methodsFor: 'accessing' stamp: 'bh 4/3/2000 10:19'! foobar ^#( true false )! ! !RBBasicLintRuleTest methodsFor: 'accessing'! problemCount ^result problemCount! ! !RBBasicLintRuleTest methodsFor: 'accessing'! result ^result! ! !RBBasicLintRuleTest methodsFor: 'initialize-release'! classBlock: aBlock classBlock := aBlock testMethod1! ! !RBBasicLintRuleTest methodsFor: 'initialize-release' stamp: 'lr 9/8/2011 20:32'! initialize super initialize. classBlock := [:context :aResult | ]. methodBlock := [:context :aResult | ]. self resultClass: RBSelectorEnvironment! ! !RBBasicLintRuleTest methodsFor: 'initialize-release'! methodBlock: aBlock methodBlock := aBlock! ! !RBBasicLintRuleTest methodsFor: 'initialize-release'! resetResult result := result copyEmpty. result label: name! ! !RBBasicLintRuleTest methodsFor: 'initialize-release'! result: aResult result := aResult copyEmpty! ! !RBBasicLintRuleTest methodsFor: 'initialize-release'! resultClass: aClass result := aClass new! ! !RBBasicLintRuleTest methodsFor: 'testing'! isEmpty ^result isEmpty! ! !RBBasicLintRuleTest methodsFor: 'private'! viewResults result openEditor! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBBasicLintRuleTest class instanceVariableNames: ''! !RBBasicLintRuleTest class methodsFor: 'accessing'! protocols ^#('bugs' 'possible bugs' 'unnecessary code' 'intention revealing' 'miscellaneous')! ! !RBBasicLintRuleTest class methodsFor: 'bugs'! 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: '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: 'bugs'! 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: 'bugs'! 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'! 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: 'instance creation'! 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: 'instance creation'! createParseTreeRule: codeStrings name: aName ^self createParseTreeRule: codeStrings method: false name: aName! ! !RBBasicLintRuleTest class methodsFor: 'intention revealing'! 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: 'intention revealing'! 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: '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'! 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: 'intention revealing'! 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'! 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: 'intention revealing'! 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: 'intention revealing'! 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: 'intention revealing' stamp: 'lr 11/2/2009 00:14'! 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 isLiteral and: [{true. false} includes: node value]) or: [node := aNode statements last value. node isLiteral 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: '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: '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: 'intention revealing'! 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: '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: 'intention revealing'! 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: '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: 'miscellaneous'! 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: '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: '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: '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: 'miscellaneous'! 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: '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: '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: '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: '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: '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: 'miscellaneous' stamp: 'lr 11/2/2009 00:14'! 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 isLiteral]]. tree := defClass parseTreeFor: selector. tree notNil ifTrue: [(searcher executeTree: tree initialAnswer: nil) == true ifTrue: [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: '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: '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: '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 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/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: '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: '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: 'possible bugs' stamp: 'lr 11/2/2009 00:14'! 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 isLiteral 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 isLiteral and: [({true. false} includes: each value) not]]]]. hasSelf & hasBool ifTrue: [result addClass: context selectedClass selector: context selector]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'possible bugs'! returnsIfTrue ^self createParseTreeRule: #('^`@condition ifTrue: [| `@temps | `@.statements]' '^`@condition ifFalse: [| `@temps | `@.statements]') name: 'Returns value of ifTrue:/ifFalse: without ifFalse:/ifTrue: block'! ! !RBBasicLintRuleTest class methodsFor: 'possible bugs'! 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: 'possible bugs'! 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: 'possible bugs'! 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 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: '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: '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: '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: '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: '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'! 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: 'unnecessary code'! 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! ! !RBBasicLintRuleTest class methodsFor: 'unnecessary code'! 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: 'unnecessary code'! 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: '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: 'unnecessary code' stamp: 'lr 4/29/2010 19:35'! 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 whichSelectorsReallyRead: each) isEmpty not]. writes ifFalse: [writes := (class whichSelectorsWrite: each) isEmpty not]. reads & writes] ifNone: [result addInstVar: each for: context selectedClass]]]. ^detector! ! !RBBasicLintRuleTest class methodsFor: 'unnecessary code'! 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'! 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: 'private'! badSelectors ^#(#become: #isKindOf: #changeClassToThatOf: #respondsTo: #isMemberOf: #performMethod: #performMethod:arguments: #performMethod:with: #performMethod:with:with: #performMethod:with:with:with: #allOwners #allOwnersWeakly: #firstOwner #instVarAt: #instVarAt:put: #nextInstance #nextObject #ownerAfter: #primBecome: #halt)! ! !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: 'private'! classShouldNotOverride ^#(#== #class)! ! !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: 'private'! longMethodSize ^10! ! !RBBasicLintRuleTest class methodsFor: 'private'! metaclassShouldNotOverride ^#(#name #comment)! ! !RBBasicLintRuleTest class methodsFor: 'private' stamp: 'nk 2/23/2005 16:09'! new ^super new! ! !RBBasicLintRuleTest class methodsFor: 'private'! 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: 'private'! superMessages ^#(#release #postCopy #postBuildWith: #preBuildWith: #postOpenWith: #noticeOfWindowClose: #initialize)! ! !RBBasicLintRuleTest class methodsFor: 'private'! utilityProtocols "If a method is defined in one of these protocols, then don't check if its a utility method." ^#('*utilit*')! ! RBTransformationRule subclass: #RBBetweenAndRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-TransformationRules'! !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 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: '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 class instanceVariableNames: ''! !RBBetweenAndRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBValueToken subclass: #RBBinarySelectorToken instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Tokens'! !RBBinarySelectorToken commentStamp: 'md 8/9/2005 14:51' prior: 0! RBBinarySelectorToken is the first-class representation of a binary selector (e.g. +) ! !RBBinarySelectorToken methodsFor: 'testing'! isBinary ^true! ! RBBasicLintRule subclass: #RBBlockLintRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics'! !RBBlockLintRule commentStamp: '' prior: 0! 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 instanceVariableNames: ''! !RBBlockLintRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! !RBBlockLintRule class methodsFor: 'testing' stamp: 'lr 2/24/2009 17:09'! isVisible ^ self name ~= #RBBlockLintRule! ! RBValueNode subclass: #RBBlockNode instanceVariableNames: 'left right colons arguments bar body scope' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Nodes'! !RBBlockNode commentStamp: '' prior: 0! 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: 'accessing'! allArgumentVariables ^(self argumentNames asOrderedCollection) addAll: super allArgumentVariables; yourself! ! !RBBlockNode methodsFor: 'accessing'! allDefinedVariables ^(self argumentNames asOrderedCollection) addAll: super allDefinedVariables; yourself! ! !RBBlockNode methodsFor: 'accessing'! argumentNames ^self arguments collect: [:each | each name]! ! !RBBlockNode methodsFor: 'accessing'! arguments ^arguments! ! !RBBlockNode methodsFor: 'accessing'! arguments: argCollection arguments := argCollection. arguments do: [:each | each parent: self]! ! !RBBlockNode methodsFor: 'accessing'! blockVariables | vars | vars := super blockVariables asOrderedCollection. vars addAll: self argumentNames. ^vars! ! !RBBlockNode methodsFor: 'accessing'! body ^body! ! !RBBlockNode methodsFor: 'accessing'! body: stmtsNode body := stmtsNode. body parent: self! ! !RBBlockNode methodsFor: 'accessing'! children ^self arguments copyWith: self body! ! !RBBlockNode methodsFor: 'accessing'! precedence ^0! ! !RBBlockNode methodsFor: 'accessing' stamp: 'CamilloBruni 12/15/2011 16:28'! scope ^ scope! ! !RBBlockNode methodsFor: 'accessing' stamp: 'CamilloBruni 12/15/2011 16:28'! scope: aScopedNode scope := aScopedNode! ! !RBBlockNode methodsFor: 'accessing'! startWithoutParentheses ^left! ! !RBBlockNode methodsFor: 'accessing'! statementComments ^self comments! ! !RBBlockNode methodsFor: 'accessing' stamp: 'CamilloBruni 2/3/2012 16:43'! statements ^ self body statements! ! !RBBlockNode methodsFor: 'accessing'! stopWithoutParentheses ^right! ! !RBBlockNode methodsFor: 'accessing' stamp: 'CamilloBruni 2/3/2012 17:18'! temporaries ^ self body temporaries! ! !RBBlockNode methodsFor: 'accessing' stamp: 'CamilloBruni 12/8/2011 15:17'! temporaryNames ^ self body temporaryNames! ! !RBBlockNode methodsFor: 'accessing-token' stamp: 'lr 2/12/2010 19:25'! bar ^ bar! ! !RBBlockNode methodsFor: 'accessing-token' stamp: 'lr 2/12/2010 19:25'! bar: anInteger bar := anInteger! ! !RBBlockNode methodsFor: 'accessing-token' stamp: 'lr 2/12/2010 19:25'! colons ^ colons! ! !RBBlockNode methodsFor: 'accessing-token' stamp: 'lr 2/12/2010 19:25'! colons: anArray colons := anArray! ! !RBBlockNode methodsFor: 'accessing-token' stamp: 'lr 2/12/2010 19:25'! left ^ left! ! !RBBlockNode methodsFor: 'accessing-token' stamp: 'lr 2/12/2010 19:25'! left: anInteger left := anInteger! ! !RBBlockNode methodsFor: 'accessing-token' stamp: 'lr 2/12/2010 19:25'! right ^ right! ! !RBBlockNode methodsFor: 'accessing-token' stamp: 'lr 2/12/2010 19:25'! right: anInteger right := anInteger! ! !RBBlockNode methodsFor: 'comparing'! = 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: 'comparing'! 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: 'comparing' stamp: 'lr 3/7/2010 13:48'! hash ^ (self hashForCollection: self arguments) bitXor: self body hash! ! !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: '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: '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: 'replacing'! replaceNode: aNode withNode: anotherNode body == aNode ifTrue: [self body: anotherNode]. self arguments: (arguments collect: [:each | each == aNode ifTrue: [anotherNode] ifFalse: [each]])! ! !RBBlockNode methodsFor: 'testing'! defines: aName ^arguments anySatisfy: [:each | each name = aName]! ! !RBBlockNode methodsFor: 'testing'! directlyUses: aNode ^false! ! !RBBlockNode methodsFor: 'testing' stamp: 'CamilloBruni 12/15/2011 16:42'! hasArgumentNamed: aString ^ self arguments anySatisfy: [ :argument| argument name = aString ]! ! !RBBlockNode methodsFor: 'testing' stamp: 'CamilloBruni 12/15/2011 16:42'! hasTemporaryNamed: aString ^ self temporaries anySatisfy: [ :temp| temp name = aString ]! ! !RBBlockNode methodsFor: 'testing'! isBlock ^true! ! !RBBlockNode methodsFor: 'testing'! isImmediateNode ^true! ! !RBBlockNode methodsFor: 'testing'! isLast: aNode ^body isLast: aNode! ! !RBBlockNode methodsFor: 'testing'! needsParenthesis ^false! ! !RBBlockNode methodsFor: 'testing'! references: aVariableName ^body references: aVariableName! ! !RBBlockNode methodsFor: 'testing'! 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: 'visitor' stamp: 'CamilloBruni 2/3/2012 16:33'! accept: aProgramNodeVisitor ^aProgramNodeVisitor visitBlockNode: self! ! !RBBlockNode methodsFor: 'visitor'! acceptVisitor: aProgramNodeVisitor ^aProgramNodeVisitor acceptBlockNode: self! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBBlockNode class instanceVariableNames: ''! !RBBlockNode class methodsFor: 'instance creation'! arguments: argNodes body: sequenceNode ^(self new) arguments: argNodes; body: sequenceNode; yourself! ! !RBBlockNode class methodsFor: 'instance creation'! body: sequenceNode ^self arguments: #() body: sequenceNode! ! RBReplaceRule subclass: #RBBlockReplaceRule instanceVariableNames: 'replaceBlock' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Matching'! !RBBlockReplaceRule commentStamp: 'md 8/9/2005 14:55' prior: 0! 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: 'initialize-release'! initialize super initialize. replaceBlock := [:aNode | aNode]! ! !RBBlockReplaceRule methodsFor: 'initialize-release'! searchFor: searchString replaceWith: aBlock self searchString: searchString. replaceBlock := aBlock! ! !RBBlockReplaceRule methodsFor: 'initialize-release'! searchFor: searchString replaceWith: replBlock when: verifyBlock self searchFor: searchString replaceWith: replBlock. verificationBlock := verifyBlock! ! !RBBlockReplaceRule methodsFor: 'initialize-release'! searchForMethod: searchString replaceWith: aBlock self methodSearchString: searchString. replaceBlock := aBlock! ! !RBBlockReplaceRule methodsFor: 'initialize-release'! searchForMethod: searchString replaceWith: replBlock when: verifyBlock self searchForMethod: searchString replaceWith: replBlock. verificationBlock := verifyBlock! ! !RBBlockReplaceRule methodsFor: 'initialize-release'! searchForTree: aBRProgramNode replaceWith: aBlock searchTree := aBRProgramNode. replaceBlock := aBlock! ! !RBBlockReplaceRule methodsFor: 'initialize-release'! searchForTree: aBRProgramNode replaceWith: replBlock when: verifyBlock self searchForTree: aBRProgramNode replaceWith: replBlock. verificationBlock := verifyBlock! ! !RBBlockReplaceRule methodsFor: 'matching'! foundMatchFor: aProgramNode | newNode | newNode := replaceBlock value: aProgramNode. aProgramNode replaceMethodSource: newNode. ^newNode! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBBlockReplaceRule class instanceVariableNames: ''! !RBBlockReplaceRule class methodsFor: 'instance creation'! searchFor: searchString replaceWith: replaceBlock ^self new searchFor: searchString replaceWith: replaceBlock! ! !RBBlockReplaceRule class methodsFor: 'instance creation'! searchFor: searchString replaceWith: replaceBlock when: aBlock ^self new searchFor: searchString replaceWith: replaceBlock when: aBlock! ! !RBBlockReplaceRule class methodsFor: 'instance creation'! searchForMethod: searchString replaceWith: replaceBlock ^self new searchForMethod: searchString replaceWith: replaceBlock! ! !RBBlockReplaceRule class methodsFor: 'instance creation'! searchForMethod: searchString replaceWith: replaceBlock when: aBlock ^self new searchForMethod: searchString replaceWith: replaceBlock when: aBlock! ! !RBBlockReplaceRule class methodsFor: 'instance creation'! searchForTree: aRBProgramNode replaceWith: replaceBlock ^self new searchForTree: aRBProgramNode replaceWith: replaceBlock! ! !RBBlockReplaceRule class methodsFor: 'instance creation'! searchForTree: aRBProgramNode replaceWith: replaceBlock when: aBlock ^self new searchForTree: aRBProgramNode replaceWith: replaceBlock when: aBlock! ! RBNodedScope subclass: #RBBlockScope instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AST-Semantic-Scope'! !RBBlockScope methodsFor: 'testing' stamp: 'lr 5/11/2010 19:12'! isBlockScope ^ true! ! RBParseTreeLintRule subclass: #RBBooleanPrecedenceRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBBooleanPrecedenceRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 16:21'! category ^ 'Potential Bugs'! ! !RBBooleanPrecedenceRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Bugs'! ! !RBBooleanPrecedenceRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Uses A | B = C instead of A | (B = C)'! ! !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 5/15/2010 15:03'! severity ^ #error! ! !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 class instanceVariableNames: ''! !RBBooleanPrecedenceRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! Object subclass: #RBBrowserEnvironment instanceVariableNames: 'label searchStrings' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Environment'! !RBBrowserEnvironment methodsFor: '*NautilusCommon' stamp: 'BenjaminVanRyseghem 5/13/2012 19:51'! asSystemNavigationEnvironment | env globalsNames | 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: '*NautilusCommon' stamp: 'BenjaminVanRyseghem 3/27/2011 15:45'! packageOrganizer ^ RPackageOrganizer default! ! !RBBrowserEnvironment methodsFor: '*NautilusCommon' stamp: 'BenjaminVanRyseghem 3/22/2011 18:16'! packages ^ self packageOrganizer packages! ! !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: '*NautilusCommon' stamp: 'BenjaminVanRyseghem 5/13/2012 19:49'! traitsDo: aBlock self systemDictionary allTraitsDo: [ :each | aBlock value: each ]! ! !RBBrowserEnvironment methodsFor: '*manifest-core' stamp: 'SimonAllier 3/30/2012 11:42'! isMultiEnvironment ^ false! ! !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: 'accessing' stamp: 'lr 9/8/2011 20:32'! asSelectorEnvironment ^(RBClassEnvironment onEnvironment: self classes: self classes) asSelectorEnvironment! ! !RBBrowserEnvironment methodsFor: 'accessing' stamp: 'lr 8/9/2011 21:00'! categories ^ self systemDictionary organization categories select: [ :each | self includesCategory: each ]! ! !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: 'accessing'! classVariablesFor: aClass ^aClass classVarNames! ! !RBBrowserEnvironment methodsFor: 'accessing'! classesAndSelectorsDo: aBlock self classesDo: [:class | self selectorsForClass: class do: [:sel | aBlock value: class value: sel]]! ! !RBBrowserEnvironment methodsFor: 'accessing'! instanceVariablesFor: aClass ^aClass instVarNames! ! !RBBrowserEnvironment methodsFor: 'accessing'! numberClasses ^self classNames size! ! !RBBrowserEnvironment methodsFor: 'accessing'! numberSelectors | total | total := 0. self allClassesDo: [:each | self selectorsForClass: each do: [:sel | total := total + 1]]. ^total! ! !RBBrowserEnvironment methodsFor: 'accessing'! problemCount ^self numberSelectors! ! !RBBrowserEnvironment methodsFor: 'accessing'! protocolsFor: aClass ^aClass organization categories select: [:each | self includesProtocol: each in: aClass]! ! !RBBrowserEnvironment methodsFor: 'accessing'! searchStrings ^searchStrings isNil ifTrue: [#()] ifFalse: [searchStrings]! ! !RBBrowserEnvironment methodsFor: 'accessing'! searchStrings: aCollection searchStrings := 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: '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'! selectorsFor: aProtocol in: aClass ^(aClass organization listAtCategoryNamed: aProtocol) select: [:each | self includesSelector: each in: aClass]! ! !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: 'accessing'! 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'! whichCategoryIncludes: aClassName ^ self systemDictionary organization categoryOfElement: aClassName! ! !RBBrowserEnvironment methodsFor: 'accessing'! whichProtocolIncludes: aSelector in: aClass ^aClass organization categoryOfElement: aSelector! ! !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: 'accessing-classes' stamp: 'CamilloBruni 9/14/2012 02:16'! allClassesAndTraits " compatibility method with SystemDictionary " ^ self allClasses! ! !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 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-classes' stamp: 'lr 1/23/2010 17:10'! associationAt: aKey ^ self associationAt: aKey ifAbsent: [ self error: aKey printString , ' not found' ]! ! !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: '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-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-classes' stamp: 'lr 2/26/2009 14:45'! classes | classes | classes := IdentitySet new: 4096. self classesDo: [ :each | classes add: each ]. ^ classes! ! !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-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: 'copying' stamp: 'lr 2/26/2009 14:23'! copyEmpty ^ self class new! ! !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: 'environments' stamp: 'lr 9/8/2011 20:32'! classVarRefsTo: instVarName in: aClass ^ RBVariableEnvironment on: self referencesToClassVariable: instVarName in: aClass! ! !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'! forClass: aClass protocols: protocolCollection ^RBProtocolEnvironment onEnvironment: self class: aClass protocols: protocolCollection! ! !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'! 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: 'environments' stamp: 'lr 9/8/2011 20:32'! forPackageNames: aCollection ^ RBPackageEnvironment onEnvironment: self packageNames: aCollection! ! !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'! forPragmas: aKeywordCollection ^ RBPragmaEnvironment onEnvironment: self keywords: aKeywordCollection! ! !RBBrowserEnvironment methodsFor: 'environments' stamp: 'lr 9/8/2011 20:32'! implementorsMatching: aString ^RBSelectorEnvironment implementorsMatching: aString in: self! ! !RBBrowserEnvironment methodsFor: 'environments' stamp: 'lr 9/8/2011 20:32'! implementorsOf: aSelector ^RBSelectorEnvironment implementorsOf: aSelector in: self! ! !RBBrowserEnvironment methodsFor: 'environments' stamp: 'lr 9/8/2011 20:32'! instVarReadersTo: instVarName in: aClass ^RBVariableEnvironment on: self readersOfInstanceVariable: instVarName in: aClass! ! !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'! 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: 'environments' stamp: 'lr 9/8/2011 20:32'! not self isSystem ifTrue: [^RBSelectorEnvironment new]. ^RBNotEnvironment onEnvironment: self! ! !RBBrowserEnvironment methodsFor: 'environments' stamp: 'lr 9/8/2011 20:32'! referencesTo: aLiteral ^RBSelectorEnvironment referencesTo: aLiteral in: self! ! !RBBrowserEnvironment methodsFor: 'environments'! 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: '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: '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: 'initialize-release'! label: aString label := aString! ! !RBBrowserEnvironment methodsFor: 'printing'! printOn: aStream aStream nextPutAll: self label! ! !RBBrowserEnvironment methodsFor: 'printing'! storeOn: aStream aStream nextPutAll: self class name; nextPutAll: ' new'! ! !RBBrowserEnvironment methodsFor: 'testing' stamp: 'lr 11/25/2009 08:37'! definesClass: aClass ^ true! ! !RBBrowserEnvironment methodsFor: 'testing' stamp: 'lr 3/18/2011 21:08'! includesCategory: aCategory ^ true! ! !RBBrowserEnvironment methodsFor: 'testing' stamp: 'lr 3/18/2011 21:08'! includesClass: aClass ^ true! ! !RBBrowserEnvironment methodsFor: 'testing' stamp: 'lr 3/18/2011 21:08'! includesProtocol: aProtocol in: aClass ^ true! ! !RBBrowserEnvironment methodsFor: 'testing' stamp: 'lr 3/18/2011 21:08'! includesSelector: aSelector in: aClass ^ true! ! !RBBrowserEnvironment methodsFor: 'testing' stamp: 'lr 1/3/2010 11:11'! isClassEnvironment ^ false! ! !RBBrowserEnvironment methodsFor: 'testing' stamp: 'lr 3/18/2011 21:08'! isEmpty ^ false! ! !RBBrowserEnvironment methodsFor: 'testing' stamp: 'lr 8/7/2009 13:00'! isSelectorEnvironment ^ false! ! !RBBrowserEnvironment methodsFor: 'testing' stamp: 'lr 3/18/2011 21:08'! isSystem ^ true! ! !RBBrowserEnvironment methodsFor: 'testing' stamp: 'lr 1/3/2010 11:11'! isVariableEnvironment ^ false! ! !RBBrowserEnvironment methodsFor: 'private' stamp: 'lr 3/20/2011 11:18'! allClassesDo: aBlock self systemDictionary allClassesDo: [ :each | aBlock value: each; value: each class ]! ! !RBBrowserEnvironment methodsFor: 'private' stamp: 'lr 3/18/2011 21:07'! defaultLabel ^ 'Smalltalk'! ! !RBBrowserEnvironment methodsFor: 'private' stamp: 'lr 3/18/2011 21:07'! environment ^ self! ! !RBBrowserEnvironment methodsFor: 'private' stamp: 'lr 3/18/2011 21:07'! label ^ label isNil ifTrue: [ self defaultLabel ] ifFalse: [ label ]! ! !RBBrowserEnvironment methodsFor: 'private' stamp: 'lr 3/20/2011 11:19'! rootEnvironment "The root environment representing everything." ^ self! ! !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! ! TestCase subclass: #RBBrowserEnvironmentTest instanceVariableNames: 'universalEnvironment' classVariableNames: 'ClassVariable' poolDictionaries: '' category: 'Refactoring-Tests-Environment'! !RBBrowserEnvironmentTest methodsFor: 'mockup' stamp: 'lr 9/5/2010 09:55'! classVariableReader ^ ClassVariable! ! !RBBrowserEnvironmentTest methodsFor: 'mockup' stamp: 'lr 9/5/2010 09:55'! classVariableWriter ClassVariable := nil! ! !RBBrowserEnvironmentTest methodsFor: 'running' stamp: 'lr 9/8/2011 20:25'! setUp super setUp. universalEnvironment := RBBrowserEnvironment new! ! !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' 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' 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:25'! testMatches | envEnvironment environmentEnvironment | envEnvironment := RBBrowserEnvironment new matches: '*env*'. environmentEnvironment := RBBrowserEnvironment new referencesTo: #environment. self assert: (envEnvironment referencesTo: #environment) numberSelectors = environmentEnvironment numberSelectors! ! !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' 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: '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: '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 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-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: 'lr 9/8/2011 20:25'! testBrowserEnvironment self universalTestFor: RBBrowserEnvironment new! ! !RBBrowserEnvironmentTest methodsFor: 'testing-environments' stamp: 'lr 9/8/2011 20:31'! testCategoryEnvironment | aCategoryEnvironment | aCategoryEnvironment := RBCategoryEnvironment onEnvironment: RBBrowserEnvironment new categories: #(#'Kernel-Objects'). self universalTestFor: aCategoryEnvironment. self assert: (aCategoryEnvironment implementorsOf: #printString) numberSelectors = 1! ! !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-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/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: 'testing-environments' stamp: 'lr 9/5/2010 09:19'! 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 allMethodsInCategory: each) isEmpty ]) ! ! !RBBrowserEnvironmentTest methodsFor: 'testing-environments' stamp: 'lr 12/29/2011 17:30'! testPackageEnvironment | aPackageEnvironment | aPackageEnvironment := universalEnvironment forPackageNames: (Array with: 'Refactoring-Tests-Environment' with: 'Refactoring-Environment'). self universalTestFor: aPackageEnvironment. self assert: (aPackageEnvironment implementorsOf: #testPackageEnvironment) numberSelectors = 1! ! !RBBrowserEnvironmentTest methodsFor: 'testing-environments' stamp: 'lr 9/5/2010 09:42'! testPragmaEnvironment | aPragmaEnvironment | aPragmaEnvironment := universalEnvironment forPragmas: #(primitive:). self universalTestFor: aPragmaEnvironment! ! !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: '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: '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'! 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: '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: '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: '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: '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: '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/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: 'private' stamp: 'lr 9/4/2010 17:33'! storeStringFor: aBrowserEnvironment | newEnvironment | newEnvironment := Compiler evaluate: aBrowserEnvironment storeString. self assert: newEnvironment numberSelectors = aBrowserEnvironment numberSelectors. self assert: (newEnvironment not & aBrowserEnvironment) numberSelectors = 0 ! ! !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: '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 class instanceVariableNames: ''! !RBBrowserEnvironmentTest class methodsFor: 'as yet unclassified' stamp: 'lr 9/5/2010 09:37'! packageNamesUnderTest ^ #('Refactoring-Environment')! ! RBBrowserEnvironment subclass: #RBBrowserEnvironmentWrapper instanceVariableNames: 'environment' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Environment'! !RBBrowserEnvironmentWrapper methodsFor: '*NautilusCommon' stamp: 'BenjaminVanRyseghem 3/10/2012 20:30'! packages ^ (self classes gather: [:each | each packages]) asSet! ! !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: 'initialize-release'! onEnvironment: anEnvironment environment := anEnvironment! ! !RBBrowserEnvironmentWrapper methodsFor: 'printing'! storeOn: aStream aStream nextPutAll: '('; nextPutAll: self class name; nextPutAll: ' onEnvironment: '. environment storeOn: aStream. aStream nextPut: $)! ! !RBBrowserEnvironmentWrapper methodsFor: 'testing' stamp: 'lr 11/25/2009 08:38'! definesClass: aClass ^ environment definesClass: aClass! ! !RBBrowserEnvironmentWrapper methodsFor: 'testing'! includesCategory: aCategory ^environment includesCategory: aCategory! ! !RBBrowserEnvironmentWrapper methodsFor: 'testing'! includesClass: aClass ^environment includesClass: aClass! ! !RBBrowserEnvironmentWrapper methodsFor: 'testing'! includesProtocol: aProtocol in: aClass ^(self includesClass: aClass) and: [environment includesProtocol: aProtocol in: aClass]! ! !RBBrowserEnvironmentWrapper methodsFor: 'testing'! includesSelector: aSelector in: aClass ^(self includesClass: aClass) and: [environment includesSelector: aSelector in: aClass]! ! !RBBrowserEnvironmentWrapper methodsFor: 'testing'! isEmpty self classesDo: [:each | ^false]. ^true! ! !RBBrowserEnvironmentWrapper methodsFor: 'testing'! isSystem ^false! ! !RBBrowserEnvironmentWrapper methodsFor: 'private' stamp: 'lr 3/18/2011 21:07'! environment ^ environment! ! !RBBrowserEnvironmentWrapper methodsFor: 'private' stamp: 'lr 3/20/2011 11:17'! rootEnvironment ^ environment rootEnvironment! ! !RBBrowserEnvironmentWrapper methodsFor: 'private' stamp: 'lr 3/20/2011 11:18'! systemDictionary ^ environment systemDictionary! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBBrowserEnvironmentWrapper class instanceVariableNames: ''! !RBBrowserEnvironmentWrapper class methodsFor: 'instance creation' stamp: 'lr 9/8/2011 20:25'! new ^ self onEnvironment: RBBrowserEnvironment new! ! !RBBrowserEnvironmentWrapper class methodsFor: 'instance creation'! onEnvironment: anEnvironment ^(self basicNew) initialize; onEnvironment: anEnvironment; yourself! ! RBValueNode subclass: #RBCascadeNode instanceVariableNames: 'messages semicolons' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Nodes'! !RBCascadeNode commentStamp: '' prior: 0! 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: 'accessing'! children ^self messages! ! !RBCascadeNode methodsFor: 'accessing'! messages ^messages! ! !RBCascadeNode methodsFor: 'accessing'! messages: messageNodeCollection messages := messageNodeCollection. messages do: [:each | each parent: self]! ! !RBCascadeNode methodsFor: 'accessing'! precedence ^4! ! !RBCascadeNode methodsFor: 'accessing'! receiver ^self messages first receiver! ! !RBCascadeNode methodsFor: 'accessing'! startWithoutParentheses ^messages first start! ! !RBCascadeNode methodsFor: 'accessing'! 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 methodsFor: 'accessing'! stopWithoutParentheses ^messages last stop! ! !RBCascadeNode methodsFor: 'accessing-token' stamp: 'lr 2/12/2010 19:26'! semicolons ^ semicolons! ! !RBCascadeNode methodsFor: 'accessing-token' stamp: 'lr 2/12/2010 19:26'! semicolons: anArray semicolons := anArray! ! !RBCascadeNode methodsFor: 'comparing'! = 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: '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: 'comparing' stamp: 'lr 3/7/2010 13:49'! hash ^ self hashForCollection: self messages! ! !RBCascadeNode methodsFor: 'copying' stamp: 'lr 11/1/2009 22:36'! postCopy super postCopy. self messages: (self messages collect: [ :each | each copy ])! ! !RBCascadeNode methodsFor: 'initialize-release'! messages: messageNodes semicolons: integerCollection self messages: messageNodes. semicolons := integerCollection! ! !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: '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: 'querying'! 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: 'querying'! 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: 'replacing'! replaceNode: aNode withNode: anotherNode self messages: (messages collect: [:each | each == aNode ifTrue: [anotherNode] ifFalse: [each]])! ! !RBCascadeNode methodsFor: 'testing'! directlyUses: aNode ^messages last = aNode and: [self isDirectlyUsed]! ! !RBCascadeNode methodsFor: 'testing'! isCascade ^true! ! !RBCascadeNode methodsFor: 'testing'! needsParenthesis ^parent isNil ifTrue: [false] ifFalse: [self precedence > parent precedence]! ! !RBCascadeNode methodsFor: 'testing'! uses: aNode ^messages last = aNode and: [self isUsed]! ! !RBCascadeNode methodsFor: 'visitor' stamp: 'CamilloBruni 2/3/2012 16:33'! accept: aProgramNodeVisitor ^aProgramNodeVisitor visitCascadeNode: self! ! !RBCascadeNode methodsFor: 'visitor'! acceptVisitor: aProgramNodeVisitor ^aProgramNodeVisitor acceptCascadeNode: self! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBCascadeNode class instanceVariableNames: ''! !RBCascadeNode class methodsFor: 'instance creation'! messages: messageNodes ^self new messages: messageNodes! ! !RBCascadeNode class methodsFor: 'instance creation'! messages: messageNodes semicolons: integerCollection ^self new messages: messageNodes semicolons: integerCollection! ! RBTransformationRule subclass: #RBCascadedNextPutAllsRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-TransformationRules'! !RBCascadedNextPutAllsRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:50'! category ^ 'Coding Idiom Violation'! ! !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: '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 class instanceVariableNames: ''! !RBCascadedNextPutAllsRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBBrowserEnvironmentWrapper subclass: #RBCategoryEnvironment instanceVariableNames: 'categories' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Environment'! !RBCategoryEnvironment methodsFor: 'accessing'! 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: 'adding' stamp: 'lr 2/8/2009 10:46'! addCategory: aSymbol categories add: aSymbol! ! !RBCategoryEnvironment methodsFor: 'copying' stamp: 'lr 2/26/2009 14:21'! postCopy super postCopy. categories := categories copy! ! !RBCategoryEnvironment methodsFor: 'initialize-release' stamp: 'lr 2/26/2009 14:25'! categories: aCollection categories addAll: aCollection! ! !RBCategoryEnvironment methodsFor: 'initialize-release' stamp: 'lr 2/26/2009 14:25'! initialize super initialize. categories := IdentitySet new! ! !RBCategoryEnvironment methodsFor: 'printing'! storeOn: aStream aStream nextPut: $(. super storeOn: aStream. aStream nextPutAll: ' categories: '. categories asArray storeOn: aStream. aStream nextPut: $)! ! !RBCategoryEnvironment methodsFor: 'testing'! includesCategory: aCategory ^(categories includes: aCategory) and: [super includesCategory: aCategory]! ! !RBCategoryEnvironment methodsFor: 'testing' stamp: 'lr 11/25/2009 08:31'! includesClass: aClass ^ (super includesClass: aClass) and: [ categories includes: aClass theNonMetaClass category ]! ! !RBCategoryEnvironment methodsFor: 'testing'! isEmpty ^categories isEmpty! ! !RBCategoryEnvironment methodsFor: 'private'! defaultLabel | stream | stream := String new writeStream. categories do: [:each | stream nextPutAll: each; nextPut: $ ]. ^stream contents! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBCategoryEnvironment class instanceVariableNames: ''! !RBCategoryEnvironment class methodsFor: 'instance creation'! onEnvironment: anEnvironment categories: aCollection ^(self onEnvironment: anEnvironment) categories: aCollection; yourself! ! RBRegexRefactoring subclass: #RBCategoryRegexRefactoring instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NautilusRefactoring-Refactorings'! !RBCategoryRegexRefactoring methodsFor: 'transforming'! 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 ] ] ]! ! RBMethodRefactoring subclass: #RBChangeMethodNameRefactoring instanceVariableNames: 'newSelector oldSelector permutation implementors' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBChangeMethodNameRefactoring methodsFor: 'accessing'! newSelector ^newSelector! ! !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: 'preconditions'! myConditions ^self subclassResponsibility! ! !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: 'testing'! hasPermutedArguments oldSelector numArgs = newSelector numArgs ifFalse: [^true]. 1 to: oldSelector numArgs do: [:i | (permutation at: i) = i ifFalse: [^true]]. ^false! ! !RBChangeMethodNameRefactoring methodsFor: 'testing'! implementorsCanBePrimitives ^false! ! !RBChangeMethodNameRefactoring methodsFor: 'transforming' stamp: 'lr 12/23/2009 19:59'! removeRenamedImplementors oldSelector = newSelector ifTrue: [ ^ self ]. self implementors do: [ :each | each removeMethod: oldSelector ]! ! !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: 'transforming'! renameMessageSends self convertAllReferencesTo: oldSelector using: self parseTreeRewriter! ! !RBChangeMethodNameRefactoring methodsFor: 'transforming' stamp: 'lr 12/23/2009 20:00'! transform self renameImplementors. self renameMessageSends. self removeRenamedImplementors! ! !RBChangeMethodNameRefactoring methodsFor: 'private'! implementors implementors isNil ifTrue: [implementors := self model allImplementorsOf: oldSelector]. ^implementors! ! !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! ! RBClassRefactoring subclass: #RBChildrenToSiblingsRefactoring instanceVariableNames: 'parent subclasses' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBChildrenToSiblingsRefactoring methodsFor: 'initialize-release'! name: aClassName class: aClass subclasses: subclassCollection className := aClassName asSymbol. parent := self model classFor: aClass. subclasses := subclassCollection collect: [:each | self model classFor: each]! ! !RBChildrenToSiblingsRefactoring methodsFor: 'preconditions'! 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: 'printing'! 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: '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 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 7/17/2010 23:24'! pullUpMethods self pushUpMethodsFrom: parent. self pushUpMethodsFrom: parent theMetaClass! ! !RBChildrenToSiblingsRefactoring methodsFor: 'transforming'! pushUpVariables self pullUpInstanceVariables. self pullUpClassInstanceVariables. self pullUpClassVariables. self pullUpPoolVariables! ! !RBChildrenToSiblingsRefactoring methodsFor: 'transforming'! reparentSubclasses self model reparentClasses: subclasses to: self abstractSuperclass! ! !RBChildrenToSiblingsRefactoring methodsFor: 'transforming' stamp: 'lr 7/17/2010 23:24'! transform self addSuperclass; pushUpVariables; pullUpMethods; changeIsKindOfReferences; reparentSubclasses! ! !RBChildrenToSiblingsRefactoring methodsFor: 'private-accessing'! abstractSuperclass ^self model classNamed: className asSymbol! ! !RBChildrenToSiblingsRefactoring methodsFor: 'private-methods'! computeSubclassSupersOf: aClass | selectors | selectors := Set new. aClass subclasses do: [:each | each selectors do: [:sel | selectors addAll: (each parseTreeFor: sel) superMessages]]. ^selectors! ! !RBChildrenToSiblingsRefactoring methodsFor: 'private-methods'! 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: 'private-methods'! pushUp: aSelector in: aClass | source | source := aClass sourceCodeFor: aSelector. source isNil ifFalse: [aClass superclass compile: source classified: (aClass protocolsFor: aSelector)]! ! !RBChildrenToSiblingsRefactoring methodsFor: 'private-methods'! 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-methods'! selectorsToPushUpFrom: aClass | superSelectors | superSelectors := self computeSubclassSupersOf: aClass. ^aClass selectors select: [:each | (superSelectors includes: each) or: [self shouldPushUp: each from: aClass]]! ! !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: 'private-methods'! 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-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: '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: '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-variables'! pullUpPoolVariables "Don't remove the pool variables from the subclass since they might be referenced there." | newSuperclass | newSuperclass := self abstractSuperclass. parent poolDictionaryNames do: [:each | newSuperclass addPoolDictionary: each]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBChildrenToSiblingsRefactoring class instanceVariableNames: ''! !RBChildrenToSiblingsRefactoring class methodsFor: 'instance creation'! model: aRBSmalltalk name: aClassName class: aClass subclasses: subclassCollection ^(self new) model: aRBSmalltalk; name: aClassName class: aClass subclasses: subclassCollection; yourself! ! !RBChildrenToSiblingsRefactoring class methodsFor: 'instance creation'! name: aClassName class: aClass subclasses: subclassCollection ^(self new) name: aClassName class: aClass subclasses: subclassCollection; yourself! ! RBRefactoringTest subclass: #RBChildrenToSiblingsTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !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: '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))! ! !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: '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: 'set up' stamp: 'lr 2/26/2009 16:47'! setUp super setUp. model := Compiler evaluate: self childrenToSiblingTestData! ! !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')! ! RBAbstractClass subclass: #RBClass instanceVariableNames: 'classVariableNames poolDictionaryNames category comment' classVariableNames: 'LookupComment' poolDictionaries: '' category: 'Refactoring-Core-Model'! !RBClass methodsFor: 'accessing'! allClassVariableNames | sprClass | sprClass := self superclass. ^sprClass isNil ifTrue: [self classVariableNames] ifFalse: [sprClass allClassVariableNames , self classVariableNames]! ! !RBClass methodsFor: 'accessing'! allPoolDictionaryNames | sprClass | sprClass := self superclass. ^sprClass isNil ifTrue: [self poolDictionaryNames] ifFalse: [sprClass allPoolDictionaryNames , self poolDictionaryNames]! ! !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: 'accessing'! category: aSymbol category := aSymbol! ! !RBClass methodsFor: 'accessing'! classVariableNames ^self privateClassVariableNames copy! ! !RBClass methodsFor: 'accessing'! classVariableNames: aCollectionOfStrings classVariableNames := (aCollectionOfStrings collect: [:each | each asSymbol]) asOrderedCollection! ! !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: 'accessing' stamp: 'lr 7/1/2008 10:55'! comment: aString model comment: (comment := aString) in: self! ! !RBClass methodsFor: 'accessing' stamp: 'bh 11/8/2000 14:38'! 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 poolDictionaryNames do: [:each | definitionStream nextPutAll: each; nextPut: $ ]. definitionStream nextPutAll: ''' category: #'''. definitionStream nextPutAll: self category asString. definitionStream nextPut: $'. ^definitionStream contents! ! !RBClass methodsFor: 'accessing'! poolDictionaryNames ^self privatePoolDictionaryNames copy! ! !RBClass methodsFor: 'accessing'! poolDictionaryNames: aCollectionOfStrings poolDictionaryNames := (aCollectionOfStrings collect: [:each | each asSymbol]) asOrderedCollection! ! !RBClass methodsFor: 'accessing' stamp: 'lr 7/23/2010 08:03'! sharedPools ^ self allPoolDictionaryNames collect: [ :each | Smalltalk globals at: each asSymbol ifAbsent: [ Dictionary new ] ]! ! !RBClass methodsFor: 'accessing' stamp: 'lr 10/26/2009 22:08'! theNonMetaClass ^ self! ! !RBClass methodsFor: 'initialize-release' stamp: 'lr 7/1/2008 10:58'! initialize super initialize. comment := LookupComment! ! !RBClass methodsFor: 'initialize-release' stamp: 'lr 7/23/2010 07:49'! realName: aSymbol self realClass: (self class environment at: aSymbol)! ! !RBClass methodsFor: 'testing'! directlyDefinesClassVariable: aString ^self classVariableNames includes: aString asSymbol! ! !RBClass methodsFor: 'testing'! directlyDefinesPoolDictionary: aString ^self poolDictionaryNames includes: aString asSymbol! ! !RBClass methodsFor: 'testing'! isMeta ^false! ! !RBClass methodsFor: 'variable accessing'! addClassVariable: aString self privateClassVariableNames add: aString asSymbol. model addClassVariable: aString to: self! ! !RBClass methodsFor: 'variable accessing'! addPoolDictionary: aString self privatePoolDictionaryNames add: aString asSymbol. model addPool: aString to: self! ! !RBClass methodsFor: 'variable accessing'! removeClassVariable: aString self privateClassVariableNames remove: aString asSymbol. model removeClassVariable: aString from: self! ! !RBClass methodsFor: 'variable accessing'! removePoolDictionary: aString self privatePoolDictionaryNames remove: aString asSymbol! ! !RBClass methodsFor: 'variable accessing'! 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: 'private'! privateClassVariableNames (self isDefined and: [classVariableNames isNil]) ifTrue: [self classVariableNames: self realClass classVarNames]. ^classVariableNames! ! !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 class instanceVariableNames: ''! !RBClass class methodsFor: 'class initialization' stamp: 'lr 7/1/2008 10:57'! initialize LookupComment := Object new! ! !RBClass class methodsFor: 'instance creation'! existingNamed: aSymbol ^(self named: aSymbol) realName: aSymbol; yourself! ! !RBClass class methodsFor: 'instance creation'! named: aSymbol ^(self new) name: aSymbol; yourself! ! RBSpellingRule subclass: #RBClassCategoriesSpellingRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Spelling'! !RBClassCategoriesSpellingRule commentStamp: '' prior: 0! See #name for the area where I check spelling.! !RBClassCategoriesSpellingRule methodsFor: 'accessing' stamp: 'lr 2/24/2009 07:57'! name ^ 'Class categories'! ! !RBClassCategoriesSpellingRule methodsFor: 'accessing' stamp: 'lr 9/8/2011 20:31'! resultClass ^ RBCategoryEnvironment! ! !RBClassCategoriesSpellingRule methodsFor: 'running' stamp: 'lr 1/21/2010 21:31'! checkClass: aContext | category | aContext selectedClass isMeta ifTrue: [ ^ self ]. category := aContext selectedClass category. (self checkSelector: category) do: [ :each | result addSearchString: each; addCategory: category ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBClassCategoriesSpellingRule class instanceVariableNames: ''! !RBClassCategoriesSpellingRule 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" ^'ClassCategoriesSpellingRule'! ! RBSpellingRule subclass: #RBClassCommentsSpellingRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Spelling'! !RBClassCommentsSpellingRule commentStamp: '' prior: 0! See #name for the area where I check spelling.! !RBClassCommentsSpellingRule methodsFor: 'accessing' stamp: 'lr 2/24/2009 07:57'! name ^ 'Class comments'! ! !RBClassCommentsSpellingRule methodsFor: 'accessing' stamp: 'lr 9/8/2011 20:32'! resultClass ^ RBClassEnvironment! ! !RBClassCommentsSpellingRule methodsFor: 'running' stamp: 'lr 7/10/2011 16:28'! checkClass: aContext | comment | aContext selectedClass isMeta ifTrue: [ ^ self ]. comment := aContext selectedClass organization classComment asString. (self check: comment) do: [ :each | (self ignore: each in: aContext) ifFalse: [ result addSearchString: each; addClass: aContext selectedClass; addClass: aContext selectedClass class ] ]! ! !RBClassCommentsSpellingRule methodsFor: 'private' stamp: 'lr 7/10/2011 16:48'! ignore: aString in: aContext ^ (aContext selectedClass bindingOf: aString) notNil or: [ (aContext selectedClass instVarNames includes: aString) or: [ (aContext literals includes: aString asSymbol) ] ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBClassCommentsSpellingRule class instanceVariableNames: ''! !RBClassCommentsSpellingRule 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" ^'ClassCommentsSpellingRule'! ! RBBrowserEnvironmentWrapper subclass: #RBClassEnvironment instanceVariableNames: 'classes metaClasses' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Environment'! !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: 'accessing'! problemCount ^self numberClasses! ! !RBClassEnvironment methodsFor: 'accessing-classes' stamp: 'lr 2/26/2009 14:24'! classNames ^ IdentitySet new addAll: classes; addAll: metaClasses; yourself! ! !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: '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: 'copying' stamp: 'lr 2/26/2009 14:24'! postCopy super postCopy. classes := classes copy. metaClasses := metaClasses copy! ! !RBClassEnvironment methodsFor: 'initialize-release' stamp: 'lr 9/14/2010 13:06'! classes: aCollection aCollection do: [ :each | self addClass: each ]! ! !RBClassEnvironment methodsFor: 'initialize-release' 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: '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: 'printing'! 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: 'removing'! removeClass: aClass aClass isMeta ifTrue: [metaClasses remove: aClass soleInstance name ifAbsent: []] ifFalse: [classes remove: aClass name ifAbsent: []]! ! !RBClassEnvironment 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: [ | class | class := self systemDictionary at: each ifAbsent: [ nil ]. class notNil and: [ (self includesClass: class) or: [ self includesClass: class class ] ] ] ] ]! ! !RBClassEnvironment methodsFor: 'testing'! includesClass: aClass ^(aClass isMeta ifTrue: [metaClasses includes: aClass soleInstance name] ifFalse: [classes includes: aClass name]) and: [super includesClass: aClass]! ! !RBClassEnvironment methodsFor: 'testing'! isClassEnvironment ^true! ! !RBClassEnvironment methodsFor: 'testing'! isEmpty ^classes isEmpty and: [metaClasses isEmpty]! ! !RBClassEnvironment methodsFor: 'private'! defaultLabel | stream | stream := String new writeStream. classes do: [:each | stream nextPutAll: each; nextPut: $ ]. ^stream contents! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBClassEnvironment class instanceVariableNames: ''! !RBClassEnvironment class methodsFor: 'instance creation'! onEnvironment: anEnvironment classes: aCollection ^(self onEnvironment: anEnvironment) classes: aCollection; yourself! ! RBBlockLintRule subclass: #RBClassInstVarNotInitializedRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBClassInstVarNotInitializedRule commentStamp: '' prior: 0! See my #rationale.! !RBClassInstVarNotInitializedRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 10:00'! category ^ 'Potential Bugs'! ! !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: '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 9/8/2011 20:32'! resultClass ^ RBClassEnvironment! ! !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 instanceVariableNames: ''! !RBClassInstVarNotInitializedRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBBlockLintRule subclass: #RBClassNameInSelectorRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBClassNameInSelectorRule commentStamp: '' prior: 0! See my #rationale.! !RBClassNameInSelectorRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 10:01'! category ^ 'Style'! ! !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 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: '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: '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 class instanceVariableNames: ''! !RBClassNameInSelectorRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBSpellingRule subclass: #RBClassNamesSpellingRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Spelling'! !RBClassNamesSpellingRule commentStamp: '' prior: 0! See #name for the area where I check spelling.! !RBClassNamesSpellingRule methodsFor: 'accessing' stamp: 'lr 2/24/2009 07:57'! name ^ 'Class names'! ! !RBClassNamesSpellingRule methodsFor: 'accessing' stamp: 'lr 9/8/2011 20:32'! resultClass ^ RBClassEnvironment! ! !RBClassNamesSpellingRule methodsFor: 'running' stamp: 'lr 8/11/2010 18:47'! checkClass: aContext | name | aContext selectedClass isMeta ifTrue: [ ^ self ]. name := aContext selectedClass name. (self checkIdentifier: name) do: [ :each | result addSearchString: each; addClass: aContext selectedClass; addClass: aContext selectedClass class ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBClassNamesSpellingRule class instanceVariableNames: ''! !RBClassNamesSpellingRule 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" ^'ClassNamesSpellingRule'! ! RBBlockLintRule subclass: #RBClassNotReferencedRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBClassNotReferencedRule commentStamp: '' prior: 0! See my #rationale.! !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'! group ^ 'Unnecessary code'! ! !RBClassNotReferencedRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Class not referenced'! ! !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 9/8/2011 20:32'! resultClass ^ RBClassEnvironment! ! !RBClassNotReferencedRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:09'! severity ^ #information! ! !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 instanceVariableNames: ''! !RBClassNotReferencedRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBRefactoring subclass: #RBClassRefactoring instanceVariableNames: 'className' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBClassRefactoring methodsFor: 'initialize-release'! className: aName className := aName! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBClassRefactoring class instanceVariableNames: ''! !RBClassRefactoring class methodsFor: 'instance creation'! className: aName ^self new className: aName! ! !RBClassRefactoring class methodsFor: 'instance creation'! model: aRBSmalltalk className: aName ^(self new) model: aRBSmalltalk; className: aName; yourself! ! RBVariableNode subclass: #RBClassReference instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Nodes'! !RBClassReference commentStamp: '' prior: 0! I am a specific variable node used for ClassReferences! RBRegexRefactoring subclass: #RBClassRegexRefactoring instanceVariableNames: 'rootClass mode' classVariableNames: '' poolDictionaries: '' category: 'NautilusRefactoring-Refactorings'! !RBClassRegexRefactoring methodsFor: 'accessing'! rootClass ^ rootClass ifNil: [ Object ]! ! !RBClassRegexRefactoring methodsFor: 'actions'! copyClasses mode := #copy:name:! ! !RBClassRegexRefactoring methodsFor: 'actions'! createClasses mode := #create:name:! ! !RBClassRegexRefactoring methodsFor: 'actions'! renameClasses mode := #rename:name:! ! !RBClassRegexRefactoring methodsFor: 'initialization'! initialize super initialize. self createClasses! ! !RBClassRegexRefactoring methodsFor: 'initialization'! rootClass: aClass rootClass := aClass theNonMetaClass! ! !RBClassRegexRefactoring methodsFor: 'transforming'! copy: aClass name: aSymbol ^ self duplicate: aClass name: aSymbol deep: true! ! !RBClassRegexRefactoring methodsFor: 'transforming'! create: aClass name: aSymbol ^ self duplicate: aClass name: aSymbol deep: false! ! !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'! 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: 'private'! copyFrom: aSourceClass to: aTargetClass aSourceClass instanceVariableNames do: [ :each | aTargetClass addInstanceVariable: each ]. aSourceClass isMeta ifFalse: [ aSourceClass allClassVariableNames do: [ :each | aTargetClass addClassVariable: each ]. aSourceClass poolDictionaryNames do: [ :each | aTargetClass addPoolDictionary: each ] ]. aSourceClass selectors do: [ :each | aTargetClass compile: (aSourceClass sourceCodeFor: each) classified: (aSourceClass protocolsFor: each) ]! ! !RBClassRegexRefactoring methodsFor: 'private'! 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! ! RBOwnedScope subclass: #RBClassScope instanceVariableNames: 'class' classVariableNames: '' poolDictionaries: '' category: 'AST-Semantic-Scope'! !RBClassScope methodsFor: 'accessing' stamp: 'lr 4/27/2010 13:48'! theClass ^ class! ! !RBClassScope methodsFor: 'initialization' stamp: 'lr 4/27/2010 13:48'! setClass: aBehavior class := aBehavior! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBClassScope class instanceVariableNames: ''! !RBClassScope class methodsFor: 'instance creation' stamp: 'lr 6/7/2010 14:58'! owner: aLexicalScope class: aBehavior ^ (self owner: aLexicalScope) setClass: aBehavior! ! RBRefactoringBrowserTest subclass: #RBClassTest instanceVariableNames: 'objectClass newClass messageNodeClass' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !RBClassTest methodsFor: 'method tests'! 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: 'method tests'! 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'! 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: '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: '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! ! !RBClassTest methodsFor: 'tests' stamp: 'CamilloBruni 1/28/2013 17:29'! testObjectIsNotAbstract self deny: objectClass isAbstract. self deny: objectClass theMetaClass isAbstract.! ! Model subclass: #RBClassToRename instanceVariableNames: 'rewriteRule builder class' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core-Data'! !RBClassToRename methodsFor: 'performing'! method1 ^self method2! ! !RBClassToRename methodsFor: 'performing'! method2 ^self method1! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBClassToRename class instanceVariableNames: 'notUsed'! RBBlockLintRule subclass: #RBClassVariableCapitalizationRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBClassVariableCapitalizationRule commentStamp: '' prior: 0! 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: '*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 2/23/2009 23:17'! group ^ 'Intention revealing'! ! !RBClassVariableCapitalizationRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Class variable capitalization'! ! !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 9/8/2011 20:32'! resultClass ^ RBVariableEnvironment! ! !RBClassVariableCapitalizationRule methodsFor: 'running' stamp: 'lr 1/21/2010 23:42'! checkClass: aContext aContext selectedClass isMeta ifTrue: [ ^ self ]. aContext selectedClass classVarNames do: [ :each | each first isUppercase ifFalse: [ result addClass: aContext selectedClass classVariable: each ] ]. aContext selectedClass poolDictionaryNames do: [ :each | each first isUppercase ifFalse: [ result addClass: aContext selectedClass classVariable: each ] ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBClassVariableCapitalizationRule class instanceVariableNames: ''! !RBClassVariableCapitalizationRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBSpellingRule subclass: #RBClassVariableNamesSpellingRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Spelling'! !RBClassVariableNamesSpellingRule commentStamp: '' prior: 0! See #name for the area where I check spelling.! !RBClassVariableNamesSpellingRule methodsFor: 'accessing' stamp: 'lr 2/24/2009 07:57'! name ^ 'Class variable names'! ! !RBClassVariableNamesSpellingRule methodsFor: 'accessing' stamp: 'lr 9/8/2011 20:32'! resultClass ^ RBClassEnvironment! ! !RBClassVariableNamesSpellingRule methodsFor: 'running' stamp: 'lr 1/21/2010 23:42'! checkClass: aContext aContext selectedClass isMeta ifTrue: [ ^ self ]. aContext selectedClass classVarNames do: [ :name | (self checkIdentifier: name) do: [ :each | result addSearchString: each; addClass: aContext selectedClass ] ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBClassVariableNamesSpellingRule class instanceVariableNames: ''! !RBClassVariableNamesSpellingRule 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" ^'ClassVariableNamesSpellingRule'! ! RBParseTreeLintRule subclass: #RBCodeCruftLeftInMethodsRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBCodeCruftLeftInMethodsRule methodsFor: '*Manifest-Core' stamp: 'Simon 8/30/2012 14:49'! category ^ 'Bugs'! ! !RBCodeCruftLeftInMethodsRule methodsFor: '*Manifest-Core' stamp: 'Simon 8/30/2012 14:47'! 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.'! ! !RBCodeCruftLeftInMethodsRule methodsFor: 'accessing' stamp: 'lr 3/17/2010 17:54'! group ^ 'Pharo bugs'! ! !RBCodeCruftLeftInMethodsRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Debugging code left in methods'! ! !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 5/15/2010 15:11'! severity ^ #error! ! !RBCodeCruftLeftInMethodsRule methodsFor: 'initialization' stamp: 'lr 2/24/2009 20:19'! initialize super initialize. self matcher matchesAnyOf: #( '`@object checkHaltCountExpired' '`@object clearHaltOnce' '`@object decrementAndCheckHaltCount' '`@object decrementHaltCount' '`@object doExpiredHaltCount' '`@object doExpiredHaltCount: `@object1' '`@object doOnlyOnce: `@object1' '`@object halt' '`@object halt: `@object1 onCount: `@object2' '`@object haltOnCount: `@object1' '`@object haltOnce' '`@object haltOnce: `@object1' '`@object haltOnceEnabled' '`@object hasHaltCount' '`@object hatIf: `@object1' '`@object inspectOnCount: `@object1' '`@object inspectOnce' '`@object inspectUntilCount: `@object1' '`@object rearmOneShot' '`@object removeHaltCount' '`@object setHaltCountTo: `@object1' '`@object setHaltOnce' '`@object toggleHaltOnce' '`@object flag: `@object1' '`@object isThisEverCalled' '`@object isThisEverCalled: `@object1' '`@object logEntry' '`@object logExecution' '`@object logExit' '`@object needsWork' 'true ifTrue: `@object1' 'false ifTrue: `@object1' 'true ifTrue: `@object1 ifFalse: `@object2' 'false ifTrue: `@object1 ifFalse: `@object2' 'true ifFalse: `@object1' 'false ifFalse: `@object1' 'true ifFalse: `@object1 ifTrue: `@object2' 'false ifFalse: `@object1 ifTrue: `@object2' 'Transcript `@message: `@object1' ) do: [ :node :answer | node ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBCodeCruftLeftInMethodsRule class instanceVariableNames: ''! !RBCodeCruftLeftInMethodsRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBParseTreeLintRule subclass: #RBCollectSelectNotUsedRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBCollectSelectNotUsedRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 16:24'! category ^ 'Optimization'! ! !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: 'accessing' stamp: 'lr 5/15/2010 17:34'! rationale ^ 'Checks for senders of typical collection enumeration methods that return an unused result.'! ! !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 class instanceVariableNames: ''! !RBCollectSelectNotUsedRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBBlockLintRule subclass: #RBCollectionCopyEmptyRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBCollectionCopyEmptyRule commentStamp: '' prior: 0! See my #rationale.! !RBCollectionCopyEmptyRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 10:04'! category ^ 'Potential Bugs'! ! !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: '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 9/8/2011 20:32'! resultClass ^ RBClassEnvironment! ! !RBCollectionCopyEmptyRule methodsFor: 'running' stamp: 'lr 10/11/2009 11:30'! checkClass: aContext (aContext selectedClass isVariable and: [ (aContext selectedClass includesSelector: #copyEmpty) not and: [ aContext selectedClass instVarNames isEmpty not and: [ aContext selectedClass inheritsFrom: Collection ] ] ]) ifTrue: [ result addClass: aContext selectedClass ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBCollectionCopyEmptyRule class instanceVariableNames: ''! !RBCollectionCopyEmptyRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBParseTreeLintRule subclass: #RBCollectionMessagesToExternalObjectRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBCollectionMessagesToExternalObjectRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 16:21'! category ^'Coding Idiom Violation'! ! !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: '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: '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 class instanceVariableNames: ''! !RBCollectionMessagesToExternalObjectRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBParseTreeLintRule subclass: #RBCollectionProtocolRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBCollectionProtocolRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 16:22'! category ^'Coding Idiom Violation'! ! !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: '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: '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 class instanceVariableNames: ''! !RBCollectionProtocolRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBRefactoryClassChange subclass: #RBCommentChange instanceVariableNames: 'comment' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Changes'! !RBCommentChange methodsFor: 'accessing' stamp: 'lr 7/1/2008 10:44'! changeClass: aBehavior super changeClass: aBehavior. isMeta := false! ! !RBCommentChange methodsFor: 'accessing' stamp: 'lr 7/1/2008 10:41'! comment ^ comment! ! !RBCommentChange methodsFor: 'accessing' stamp: 'lr 7/1/2008 10:41'! comment: aString comment := aString! ! !RBCommentChange methodsFor: 'converting' stamp: 'lr 9/6/2010 10:48'! asUndoOperation ^ self copy comment: self changeClass organization classComment; yourself! ! !RBCommentChange methodsFor: 'printing' stamp: 'lr 7/1/2008 10:48'! changeString ^ 'Comment ' , self displayClassName! ! !RBCommentChange methodsFor: 'printing' stamp: 'lr 12/29/2011 17:42'! printOn: aStream aStream nextPutAll: self displayClassName; nextPutAll: ' classComment: '; print: (self comment copyReplaceAll: '!!' with: '!!!!'); nextPutAll: ' stamp: '; print: (RBPlatform current changeStamp); nextPutAll: '!!'! ! !RBCommentChange methodsFor: 'private' stamp: 'EstebanLorenzano 7/27/2012 16:30'! primitiveExecute self changeClass classComment: comment stamp: RBPlatform current changeStamp. SystemAnnouncer uniqueInstance classCommented: self changeClass! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBCommentChange class instanceVariableNames: ''! !RBCommentChange class methodsFor: 'instance creation' stamp: 'lr 7/1/2008 10:50'! comment: aString in: aClass ^ self new changeClass: aClass; comment: aString; yourself! ! RBLintRule subclass: #RBCompositeLintRule instanceVariableNames: 'rules name' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics'! !RBCompositeLintRule commentStamp: '' prior: 0! A RBCompositeLintRule is a composite rule holding rules.! !RBCompositeLintRule methodsFor: '*Manifest-Core' stamp: 'StephaneDucasse 11/21/2012 18:25'! leaves ^ rules gather: [ :rule | rule leaves ] ! ! !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: '*Manifest-CriticBrowser' stamp: 'StephaneDucasse 11/21/2012 18:25'! 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:09'! changes ^ rules gather: [ :each | each changes ]! ! !RBCompositeLintRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 21:32'! name ^ name! ! !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: 'accessing' stamp: 'lr 2/23/2009 21:11'! rules ^ rules! ! !RBCompositeLintRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 21:32'! rules: aCollection rules := aCollection! ! !RBCompositeLintRule methodsFor: 'initialization' stamp: 'lr 2/23/2009 21:11'! resetResult rules do: [ :each | each resetResult ]! ! !RBCompositeLintRule methodsFor: 'running' stamp: 'lr 2/23/2009 21:10'! checkClass: aContext rules do: [ :each | each checkClass: aContext ]! ! !RBCompositeLintRule methodsFor: 'running' stamp: 'lr 2/23/2009 21:10'! checkMethod: aContext rules do: [ :each | each checkMethod: aContext ]! ! !RBCompositeLintRule methodsFor: 'testing' stamp: 'lr 2/23/2009 21:11'! hasConflicts ^ rules anySatisfy: [ :each | each hasConflicts ]! ! !RBCompositeLintRule methodsFor: 'testing' stamp: 'lr 2/23/2009 21:11'! isComposite ^ true! ! !RBCompositeLintRule methodsFor: 'testing' stamp: 'lr 2/23/2009 21:12'! isEmpty ^ rules allSatisfy: [ :each | each isEmpty ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBCompositeLintRule class instanceVariableNames: ''! !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: '*Manifest-Core'! 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! ! !RBCompositeLintRule class methodsFor: '*Manifest-Core' stamp: 'SimonAllier 1/31/2013 14:05'! removedRules ^ {(RBCompositeLintRule new name: 'Spelling'). RBMissingTranslationsInMenusRule new. RBGuardingClauseRule new. RBMethodModifierOverrideRule new. RBMethodModifierSuperRule new. RBMethodModifierFinalRule new. RBAssignmentWithoutEffectRule new. RBUtilityMethodsRule new. } "this rule is contains a bug" ! ! !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: '*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: '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: 'accessing' stamp: 'lr 2/23/2009 22:48'! transformations ^ self rules: (self rulesGroupedFor: RBTransformationRule) name: 'Transformations'! ! !RBCompositeLintRule class methodsFor: 'instance creation' stamp: 'lr 2/23/2009 21:55'! rules: aCollection ^ self new rules: aCollection; yourself! ! !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/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! ! !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! ! RBLintRuleTest subclass: #RBCompositeLintRuleTest instanceVariableNames: 'rules' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core-Data'! !RBCompositeLintRuleTest methodsFor: 'accessing'! checkClass: aSmalllintContext rules do: [:each | each checkClass: aSmalllintContext. Processor yield]! ! !RBCompositeLintRuleTest methodsFor: 'accessing'! checkMethod: aSmalllintContext rules do: [:each | each checkMethod: aSmalllintContext. Processor yield]! ! !RBCompositeLintRuleTest methodsFor: 'accessing'! failedRules ^rules inject: OrderedCollection new into: [:oc :each | oc addAll: each failedRules; yourself]! ! !RBCompositeLintRuleTest methodsFor: 'accessing'! problemCount ^rules inject: 0 into: [:count :each | count + each problemCount]! ! !RBCompositeLintRuleTest methodsFor: 'accessing'! rules ^rules! ! !RBCompositeLintRuleTest methodsFor: 'initialize-release'! resetResult rules do: [:each | each resetResult]! ! !RBCompositeLintRuleTest methodsFor: 'initialize-release'! rules: aCollection rules := aCollection! ! !RBCompositeLintRuleTest methodsFor: 'testing'! hasConflicts ^(rules detect: [:each | each hasConflicts] ifNone: [nil]) notNil! ! !RBCompositeLintRuleTest methodsFor: 'testing'! isComposite ^true! ! !RBCompositeLintRuleTest methodsFor: 'testing'! isEmpty ^(rules detect: [:each | each isEmpty not] ifNone: [nil]) isNil! ! !RBCompositeLintRuleTest methodsFor: 'private'! viewResults rules do: [:each | each viewResults]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBCompositeLintRuleTest class instanceVariableNames: ''! !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'! ! !RBCompositeLintRuleTest class methodsFor: 'all checks' stamp: 'lr 2/26/2009 14:51'! transformations ^ self ruleFor: RBTransformationRuleTest protocol: 'transformations'! ! !RBCompositeLintRuleTest class methodsFor: 'instance creation'! allRules ^self ruleFor: self protocol: 'all checks'! ! !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'! rules: aCollection ^self new rules: aCollection! ! !RBCompositeLintRuleTest class methodsFor: 'instance creation'! rules: aCollection name: aString ^(self new) rules: aCollection; name: aString; yourself! ! RBRefactoryChange subclass: #RBCompositeRefactoryChange instanceVariableNames: 'changes' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Changes'! !RBCompositeRefactoryChange methodsFor: '*NautilusRefactoring'! whatToDisplayIn: aBrowser ^ self changes gather: [:each | each whatToDisplayIn: aBrowser ]! ! !RBCompositeRefactoryChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 17:27'! addChange: aRefactoryChange changes add: aRefactoryChange. ^ aRefactoryChange! ! !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: '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: 'accessing' stamp: 'lr 9/6/2010 17:27'! changesSize ^ changes inject: 0 into: [ :sum :each | sum + each changesSize ]! ! !RBCompositeRefactoryChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 17:27'! problemCount ^ self changesSize! ! !RBCompositeRefactoryChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 17:29'! removeChange: aChange ^ changes remove: aChange ifAbsent: [ nil ]! ! !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: '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: 'comparing' stamp: 'lr 9/6/2010 17:31'! hash ^ self class hash bitXor: self changes size hash! ! !RBCompositeRefactoryChange methodsFor: 'copying' stamp: 'lr 9/6/2010 17:27'! postCopy super postCopy. changes := changes collect: [ :each | each copy ]! ! !RBCompositeRefactoryChange methodsFor: 'initialize-release'! initialize super initialize. changes := OrderedCollection new! ! !RBCompositeRefactoryChange methodsFor: 'printing' stamp: 'lr 9/6/2010 17:28'! printOn: aStream name isNil ifTrue: [ ^ super printOn: aStream ]. aStream nextPutAll: name! ! !RBCompositeRefactoryChange methodsFor: 'refactory-changes' stamp: 'lr 9/8/2011 20:10'! addClassVariable: variableName to: aClass ^ self addChange: (RBAddClassVariableChange add: variableName to: aClass)! ! !RBCompositeRefactoryChange methodsFor: 'refactory-changes' stamp: 'lr 9/8/2011 20:10'! addInstanceVariable: variableName to: aClass ^ self addChange: (RBAddInstanceVariableChange add: variableName to: aClass)! ! !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'! comment: aString in: aClass ^ self addChange: (RBCommentChange comment: aString in: aClass)! ! !RBCompositeRefactoryChange methodsFor: 'refactory-changes' stamp: 'lr 9/8/2011 20:10'! compile: source in: class ^ self addChange: (RBAddMethodChange compile: source in: class)! ! !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: 'refactory-changes' stamp: 'lr 9/8/2011 20:10'! defineClass: aString ^ self addChange: (RBAddClassChange definition: aString)! ! !RBCompositeRefactoryChange methodsFor: 'refactory-changes' stamp: 'lr 9/8/2011 20:10'! removeClass: aClass ^ self addChange: (RBRemoveClassChange removeClassName: aClass name)! ! !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'! removeClassVariable: variableName from: aClass ^ self addChange: (RBRemoveClassVariableChange remove: variableName from: aClass)! ! !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'! removeMethod: aSelector from: aClass ^ self addChange: (RBRemoveMethodChange remove: aSelector from: aClass)! ! !RBCompositeRefactoryChange methodsFor: 'refactory-changes' stamp: 'lr 9/8/2011 20:10'! removePool: aPoolVariable from: aClass ^ self addChange: (RBRemovePoolVariableChange remove: aPoolVariable from: 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: '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: '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: 'private-inspector accessing' stamp: 'lr 9/6/2010 17:28'! changes ^ changes! ! !RBCompositeRefactoryChange methodsFor: 'private-inspector accessing'! changes: aCollection changes := aCollection! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBCompositeRefactoryChange class instanceVariableNames: ''! !RBCompositeRefactoryChange class methodsFor: 'instance creation' stamp: 'lr 9/7/2010 19:43'! named: aString ^ self new name: aString; yourself! ! RBAbstractCondition subclass: #RBCondition instanceVariableNames: 'block type errorBlock' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Conditions'! !RBCondition methodsFor: 'accessing'! errorBlockFor: aBoolean ^errorBlock! ! !RBCondition methodsFor: 'checking'! check ^block value! ! !RBCondition methodsFor: 'initialize-release'! 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: 'initialize-release'! withBlock: aBlock block := aBlock. type := #(#generic)! ! !RBCondition methodsFor: 'printing' stamp: 'bh 4/10/2001 16:51'! printOn: aStream aStream nextPutAll: type asString! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBCondition class instanceVariableNames: ''! !RBCondition class methodsFor: 'instance creation'! canUnderstand: aSelector in: aClass ^self new type: (Array with: #understandsSelector with: aClass with: aSelector) block: [aClass definesMethod: aSelector] errorString: aClass printString , ' <1?:does not >understand<1?s:> ' , aSelector printString! ! !RBCondition class methodsFor: 'instance creation'! 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'! 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'! 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'! 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'! 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: 'instance creation'! 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'! 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'! empty "Returns an empty condition" ^self new type: (Array with: #empty) block: [true] errorString: 'Empty'! ! !RBCondition class methodsFor: 'instance creation'! 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'! hasSuperclass: aClass ^self new type: (Array with: #hasSuperclass with: aClass) block: [aClass superclass isNil not] errorString: aClass printString , ' has <1?a:no> superclass'! ! !RBCondition class methodsFor: 'instance creation'! 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: 'instance creation'! 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: 'instance creation'! 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'! 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: 'instance creation'! isClass: anObject ^self new type: (Array with: #IsClass with: anObject) block: [anObject isBehavior] errorString: anObject printString , ' is <1?:not >a behavior'! ! !RBCondition class methodsFor: 'instance creation'! 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'! 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'! 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'! 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: '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'! 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'! 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'! 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'! 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'! 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'! 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'! 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'! withBlock: aBlock ^self new withBlock: aBlock! ! !RBCondition class methodsFor: 'instance creation'! withBlock: aBlock errorString: aString ^self new type: #unknown block: aBlock errorString: aString! ! !RBCondition class methodsFor: 'utilities'! 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: 'utilities'! 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: 'utilities'! checkMethodName: aName in: aClass ^aName isString and: [RBScanner isSelector: aName]! ! !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: 'utilities'! reservedNames ^#('self' 'true' 'false' 'nil' 'thisContext' 'super')! ! !RBCondition class methodsFor: 'utilities'! validClassName: aString "Class names and class variable names have the same restrictions" ^self checkClassVarName: aString in: self! ! RBProgramNodeVisitor subclass: #RBConfigurableFormatter instanceVariableNames: 'codeStream indent lookaheadCode originalSource lineStart' classVariableNames: 'CascadedMessageInsideParentheses FormatCommentWithStatements IndentString IndentsForKeywords KeepBlockInMessage LineUpBlockBrackets MaxLineLength MethodSignatureOnMultipleLines MinimumNewLinesBetweenStatements MultiLineMessages NewLineAfterCascade NewLineBeforeFirstCascade NewLineBeforeFirstKeyword NewLinesAfterMethodComment NewLinesAfterMethodPattern NewLinesAfterTemporaries NumberOfArgumentsForMultiLine OneLineMessages PeriodsAtEndOfBlock PeriodsAtEndOfMethod RetainBlankLinesBetweenStatements StringFollowingReturn StringInsideBlocks StringInsideParentheses TraditionalBinaryPrecedence UseTraditionalBinaryPrecedenceForParentheses' poolDictionaries: '' category: 'AST-Core-Visitors'! !RBConfigurableFormatter commentStamp: '' prior: 0! 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'! indent: anInteger indent := anInteger! ! !RBConfigurableFormatter methodsFor: 'initialize-release'! initialize super initialize. lineStart := 0. indent := 0. lookaheadCode := IdentityDictionary new. codeStream := WriteStream on: (String new: 256)! ! !RBConfigurableFormatter methodsFor: 'public interface'! format: aParseTree originalSource := aParseTree source. self visitNode: aParseTree. ^codeStream contents! ! !RBConfigurableFormatter methodsFor: 'utility'! 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'! 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: 'visitor-double dispatching' stamp: 'lr 11/2/2009 09:31'! acceptArrayNode: anArrayNode self bracketWith: '{}' around: [ self formatArray: anArrayNode ]! ! !RBConfigurableFormatter methodsFor: 'visitor-double dispatching' stamp: 'lr 11/2/2009 20:53'! acceptAssignmentNode: anAssignmentNode self visitNode: anAssignmentNode variable. codeStream space; nextPutAll: anAssignmentNode assignmentOperator; space. self visitNode: anAssignmentNode value! ! !RBConfigurableFormatter methodsFor: 'visitor-double dispatching'! acceptBlockNode: aBlockNode self bracketWith: '[]' around: [self formatBlock: aBlockNode]! ! !RBConfigurableFormatter methodsFor: 'visitor-double dispatching'! acceptCascadeNode: 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: 'visitor-double dispatching'! acceptLiteralArrayNode: 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: 'visitor-double dispatching'! acceptLiteralNode: aLiteralNode self writeString: aLiteralNode token storeString! ! !RBConfigurableFormatter methodsFor: 'visitor-double dispatching'! acceptMessageNode: aMessageNode self visitNode: aMessageNode receiver. self formatSelectorAndArguments: aMessageNode! ! !RBConfigurableFormatter methodsFor: 'visitor-double dispatching'! acceptMethodNode: aMethodNode self formatMethodPatternFor: aMethodNode. self formatMethodBodyFor: aMethodNode! ! !RBConfigurableFormatter methodsFor: 'visitor-double dispatching'! acceptPatternBlockNode: aRBPatternBlockNode codeStream nextPut: $`. self bracketWith: '{}' around: [self formatBlock: aRBPatternBlockNode]! ! !RBConfigurableFormatter methodsFor: 'visitor-double dispatching'! acceptPatternWrapperBlockNode: aRBPatternWrapperBlockNode self visitNode: aRBPatternWrapperBlockNode wrappedNode. codeStream nextPut: $`. self bracketWith: '{}' around: [self formatBlock: aRBPatternWrapperBlockNode]! ! !RBConfigurableFormatter methodsFor: 'visitor-double dispatching' stamp: 'cwp 10/29/2011 23:07'! acceptPragmaNode: aPragmaNode codeStream nextPut: $<. self formatSelectorAndArguments: aPragmaNode firstSeparator: [ aPragmaNode selector isInfix ifTrue: [ self space ] ] restSeparator: [ self space ]. codeStream nextPut: $>! ! !RBConfigurableFormatter methodsFor: 'visitor-double dispatching' stamp: 'CamilloBruni 10/31/2012 21:41'! acceptReturnNode: aReturnNode codeStream nextPut: $^; nextPutAll: StringFollowingReturn. self visitNode: aReturnNode value! ! !RBConfigurableFormatter methodsFor: 'visitor-double dispatching'! acceptSequenceNode: aSequenceNode self formatTemporariesFor: aSequenceNode. self formatSequenceCommentsFor: aSequenceNode. self formatSequenceNodeStatementsFor: aSequenceNode! ! !RBConfigurableFormatter methodsFor: 'visitor-double dispatching'! acceptVariableNode: aVariableNode codeStream nextPutAll: aVariableNode name! ! !RBConfigurableFormatter methodsFor: 'private'! 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'! bracketWith: bracketString around: aBlock bracketString isEmpty ifTrue: [^aBlock value]. codeStream nextPut: bracketString first. ^aBlock ensure: [codeStream nextPut: bracketString last]! ! !RBConfigurableFormatter methodsFor: 'private'! currentLineLength ^codeStream position - lineStart! ! !RBConfigurableFormatter methodsFor: 'private'! 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'! formattedSourceFor: aNode ^lookaheadCode at: aNode ifAbsentPut: [self class format: aNode withIndents: indent]! ! !RBConfigurableFormatter methodsFor: 'private'! indent: anInteger around: aBlock indent := indent + anInteger. ^aBlock ensure: [indent := indent - anInteger]! ! !RBConfigurableFormatter methodsFor: 'private'! indentAround: aBlock self indent: 1 around: aBlock! ! !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' 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 methodsFor: 'private'! newLine self newLines: 1! ! !RBConfigurableFormatter methodsFor: 'private'! newLines: anInteger anInteger + IndentString size = 0 ifTrue: [codeStream space]. anInteger timesRepeat: [codeStream cr]. lineStart := codeStream position. indent timesRepeat: [codeStream nextPutAll: IndentString]! ! !RBConfigurableFormatter methodsFor: 'private'! 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'! 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'! space codeStream space! ! !RBConfigurableFormatter methodsFor: 'private'! willBeMultiline: aNode ^(self formattedSourceFor: aNode) includes: Character cr! ! !RBConfigurableFormatter methodsFor: 'private'! writeString: aString | index | index := aString lastIndexOf: Character cr ifAbsent: [0]. codeStream nextPutAll: aString. index > 0 ifTrue: [lineStart := codeStream position - (aString size - index)]! ! !RBConfigurableFormatter methodsFor: 'private-formatting' stamp: 'lr 11/2/2009 09:31'! formatArray: anArrayNode self formatSequenceCommentsFor: anArrayNode. self formatSequenceNodeStatementsFor: anArrayNode! ! !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-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'! formatCommentsFor: aNode originalSource isNil ifTrue: [^self]. aNode comments do: [:each | codeStream space; nextPutAll: (originalSource copyFrom: each first to: each last)]! ! !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-formatting'! 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: 'private-formatting'! 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-formatting' stamp: 'lr 11/2/2009 10:09'! formatPragmasFor: aMethodNode aMethodNode pragmas do: [ :each | self visitNode: each; newLine ]! ! !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: 'private-formatting' stamp: 'lr 2/28/2010 21:49'! formatSelectorAndArguments: aMessageNode firstSeparator: firstBlock restSeparator: restBlock | separatorBlock | separatorBlock := firstBlock. aMessageNode isUnary ifTrue: [ (self isLineTooLong: aMessageNode selector) ifTrue: [ self newLine ] ifFalse: [ separatorBlock value ]. codeStream nextPutAll: aMessageNode selector ] ifFalse: [ aMessageNode selectorParts with: aMessageNode arguments do: [ :selector :argument | (self isLineTooLong: selector value) ifTrue: [ self newLine ] ifFalse: [ separatorBlock value ]. 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'! 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'! 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-formatting'! 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: '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 class instanceVariableNames: ''! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 7/25/2011 20:53'! cascadedMessageInsideParentheses ^ CascadedMessageInsideParentheses! ! !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 12/27/2009 13:35'! formatCommentWithStatements: aBoolean FormatCommentWithStatements := aBoolean! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! indentString ^ IndentString! ! !RBConfigurableFormatter class methodsFor: 'accessing'! indentString: aString IndentString := aString! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! indentsForKeywords ^ IndentsForKeywords! ! !RBConfigurableFormatter class methodsFor: 'accessing'! indentsForKeywords: anInteger IndentsForKeywords := anInteger! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 2/28/2010 21:49'! keepBlockInMessage ^ KeepBlockInMessage! ! !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'! lineUpBlockBrackets ^ LineUpBlockBrackets! ! !RBConfigurableFormatter class methodsFor: 'accessing'! lineUpBlockBrackets: aBoolean LineUpBlockBrackets := aBoolean! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! maxLineLength ^ MaxLineLength! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! maxLineLength: anInteger MaxLineLength := anInteger! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! methodSignatureOnMultipleLines ^ MethodSignatureOnMultipleLines! ! !RBConfigurableFormatter class methodsFor: 'accessing'! methodSignatureOnMultipleLines: aBoolean MethodSignatureOnMultipleLines := aBoolean! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! minimumNewLinesBetweenStatements ^ MinimumNewLinesBetweenStatements! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! minimumNewLinesBetweenStatements: anInteger MinimumNewLinesBetweenStatements := anInteger! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 9/11/2010 17:20'! multiLineMessages ^ MultiLineMessages printString! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 9/11/2010 17:19'! multiLineMessages: aString MultiLineMessages := self compilerClass evaluate: aString for: nil logged: false! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! newLineAfterCascade ^ NewLineAfterCascade! ! !RBConfigurableFormatter class methodsFor: 'accessing'! newLineAfterCascade: aBoolean NewLineAfterCascade := aBoolean! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! newLineBeforeFirstCascade ^ NewLineBeforeFirstCascade! ! !RBConfigurableFormatter class methodsFor: 'accessing'! newLineBeforeFirstCascade: aBoolean NewLineBeforeFirstCascade := aBoolean! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! newLineBeforeFirstKeyword ^ NewLineBeforeFirstKeyword! ! !RBConfigurableFormatter class methodsFor: 'accessing'! newLineBeforeFirstKeyword: aBoolean NewLineBeforeFirstKeyword := aBoolean! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! newLinesAfterMethodComment ^ NewLinesAfterMethodComment! ! !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'! newLinesAfterMethodPattern ^ NewLinesAfterMethodPattern! ! !RBConfigurableFormatter class methodsFor: 'accessing'! newLinesAfterMethodPattern: anInteger NewLinesAfterMethodPattern := anInteger! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! newLinesAfterTemporaries ^ NewLinesAfterTemporaries! ! !RBConfigurableFormatter class methodsFor: 'accessing'! newLinesAfterTemporaries: anInteger NewLinesAfterTemporaries := anInteger! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! numberOfArgumentsForMultiLine ^ NumberOfArgumentsForMultiLine! ! !RBConfigurableFormatter class methodsFor: 'accessing'! numberOfArgumentsForMultiLine: anInteger NumberOfArgumentsForMultiLine := anInteger! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 9/11/2010 17:20'! oneLineMessages ^ OneLineMessages printString! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 9/11/2010 17:19'! oneLineMessages: aString OneLineMessages := self compilerClass evaluate: aString for: nil logged: false! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! periodsAsTerminators ^ PeriodsAtEndOfBlock and: [ PeriodsAtEndOfMethod ]! ! !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'! periodsAtEndOfBlock ^ PeriodsAtEndOfBlock! ! !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 ^ PeriodsAtEndOfMethod! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! periodsAtEndOfMethod: aBoolean PeriodsAtEndOfMethod := aBoolean! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! retainBlankLinesBetweenStatements ^ RetainBlankLinesBetweenStatements! ! !RBConfigurableFormatter class methodsFor: 'accessing'! retainBlankLinesBetweenStatements: aBoolean RetainBlankLinesBetweenStatements := aBoolean! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! stringFollowingReturn ^ StringFollowingReturn! ! !RBConfigurableFormatter class methodsFor: 'accessing'! stringFollowingReturn: aString StringFollowingReturn := aString! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! stringInsideBlocks ^ StringInsideBlocks! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! stringInsideBlocks: aString StringInsideBlocks := aString! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! stringInsideParentheses ^ StringInsideParentheses! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! stringInsideParentheses: aString StringInsideParentheses := aString! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 9/11/2010 17:20'! traditionalBinaryPrecedence ^ TraditionalBinaryPrecedence printString! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 9/11/2010 17:20'! traditionalBinaryPrecedence: aString TraditionalBinaryPrecedence := self compilerClass evaluate: aString for: nil logged: false! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! useTraditionalBinaryPrecedenceForParentheses ^ UseTraditionalBinaryPrecedenceForParentheses! ! !RBConfigurableFormatter class methodsFor: 'accessing' stamp: 'lr 12/27/2009 13:35'! useTraditionalBinaryPrecedenceForParentheses: aBoolean UseTraditionalBinaryPrecedenceForParentheses := aBoolean! ! !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: 'public'! format: aParseTree ^self format: aParseTree withIndents: 0! ! !RBConfigurableFormatter class methodsFor: 'public' stamp: 'lr 12/27/2009 13:05'! format: aParseTree withIndents: anInteger ^ self new indent: anInteger; format: aParseTree! ! !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' ]! ! RBAbstractCondition subclass: #RBConjunctiveCondition instanceVariableNames: 'left right failed' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Conditions'! !RBConjunctiveCondition methodsFor: 'checking'! check left check ifFalse: [failed := #leftFailed. ^false]. right check ifFalse: [failed := #rightFailed. ^false]. ^true! ! !RBConjunctiveCondition methodsFor: 'initialize-release'! left: aCondition right: aCondition2 left := aCondition. right := aCondition2. failed := #unknownFailed! ! !RBConjunctiveCondition methodsFor: 'printing' stamp: 'bh 4/10/2001 16:52'! printOn: aStream aStream nextPutAll: left asString; nextPutAll: ' & '; nextPutAll: right asString ! ! !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'! errorMacro ^errorMacro isNil ifTrue: [self longMacro] ifFalse: [super errorMacro]! ! !RBConjunctiveCondition methodsFor: 'private'! errorStringFor: aBoolean ^aBoolean ifTrue: [self neitherFailed] ifFalse: [self perform: failed]! ! !RBConjunctiveCondition methodsFor: 'private'! leftFailed ^left errorStringFor: false! ! !RBConjunctiveCondition methodsFor: 'private'! longMacro ^'(' , left errorMacro , ') <1?AND:OR> (' , right errorMacro , ')'! ! !RBConjunctiveCondition methodsFor: 'private'! neitherFailed ^(left errorStringFor: true) , ' AND ' , (right errorStringFor: true)! ! !RBConjunctiveCondition methodsFor: 'private'! rightFailed ^right errorStringFor: false! ! !RBConjunctiveCondition methodsFor: 'private'! unknownFailed ^(left errorStringFor: false) , ' OR ' , (right errorStringFor: false)! ! RBParseTreeLintRule subclass: #RBConsistencyCheckRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBConsistencyCheckRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 16:24'! category ^'Coding Idiom Violation'! ! !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: '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: '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 class instanceVariableNames: ''! !RBConsistencyCheckRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBParseTreeLintRule subclass: #RBContainsRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBContainsRule methodsFor: '*Manifest-Core' stamp: 'Simon 8/30/2012 14:51'! category ^ 'Optimization'! ! !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: '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: 'initialization' stamp: 'lr 2/24/2009 20:24'! 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 class instanceVariableNames: ''! !RBContainsRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBSpecialBinding subclass: #RBContextBinding instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AST-Semantic-Binding'! !RBContextBinding methodsFor: 'accessing' stamp: 'lr 4/27/2010 14:34'! name ^ 'thisContext'! ! !RBContextBinding methodsFor: 'testing-type' stamp: 'lr 4/28/2010 09:29'! isContextBinding ^ true! ! RBVariableRefactoring subclass: #RBCreateAccessorsForVariableRefactoring instanceVariableNames: 'getterMethod setterMethod classVariable needsReturn' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBCreateAccessorsForVariableRefactoring methodsFor: '*NautilusRefactoring'! whatToDisplayIn: aBrowser ^ (self changes changes select: [:change | {getterMethod. setterMethod} includes: change selector ]) gather: [:change | change whatToDisplayIn: aBrowser ]! ! !RBCreateAccessorsForVariableRefactoring methodsFor: 'initialize-release'! classVariable: aBoolean classVariable := aBoolean! ! !RBCreateAccessorsForVariableRefactoring methodsFor: 'preconditions'! preconditions ^classVariable ifTrue: [RBCondition definesClassVariable: variableName asSymbol in: class] ifFalse: [RBCondition definesInstanceVariable: variableName in: class]! ! !RBCreateAccessorsForVariableRefactoring methodsFor: 'printing'! 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: 'testing'! needsReturnForSetter needsReturn isNil ifTrue: [needsReturn := self usesAssignmentOf: variableName in: class classVariable: classVariable]. ^needsReturn! ! !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'! createGetterAccessor getterMethod := self findGetterMethod. getterMethod isNil ifTrue: [getterMethod := self defineGetterMethod]! ! !RBCreateAccessorsForVariableRefactoring methodsFor: 'transforming'! createSetterAccessor setterMethod := self findSetterMethod. setterMethod isNil ifTrue: [setterMethod := self defineSetterMethod]! ! !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: '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: 'transforming'! transform self createGetterAccessor; createSetterAccessor! ! !RBCreateAccessorsForVariableRefactoring methodsFor: 'private-accessing' stamp: 'lr 10/26/2009 22:09'! definingClass ^ classVariable ifTrue: [ class theMetaClass ] ifFalse: [ class ]! ! !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: '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 methodsFor: 'private-accessing'! getterMethod ^getterMethod! ! !RBCreateAccessorsForVariableRefactoring methodsFor: 'private-accessing'! methodsReferencingVariable ^classVariable ifTrue: [self definingClass whichSelectorsReferToClassVariable: variableName] ifFalse: [self definingClass whichSelectorsReferToInstanceVariable: variableName]! ! !RBCreateAccessorsForVariableRefactoring methodsFor: 'private-accessing'! possibleGetterSelectors ^self methodsReferencingVariable select: [:each | each numArgs == 0]! ! !RBCreateAccessorsForVariableRefactoring methodsFor: 'private-accessing'! possibleSetterSelectors ^self methodsReferencingVariable select: [:each | each numArgs == 1]! ! !RBCreateAccessorsForVariableRefactoring methodsFor: 'private-accessing'! setterMethod ^setterMethod! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBCreateAccessorsForVariableRefactoring class instanceVariableNames: ''! !RBCreateAccessorsForVariableRefactoring class methodsFor: 'instance creation'! model: aRBSmalltalk variable: aVarName class: aClass classVariable: aBoolean ^(self model: aRBSmalltalk variable: aVarName class: aClass) classVariable: aBoolean; yourself! ! !RBCreateAccessorsForVariableRefactoring class methodsFor: 'instance creation'! variable: aVarName class: aClass classVariable: aBoolean ^(self variable: aVarName class: aClass) classVariable: aBoolean; yourself! ! RBRefactoringTest subclass: #RBCreateAccessorsForVariableTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !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: 'set up' stamp: 'md 7/25/2005 15:17'! setUp super setUp. model := Compiler evaluate: self abstractVariableTestData.! ! !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: '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')! ! !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')! ! RBMethodRefactoring subclass: #RBCreateCascadeRefactoring instanceVariableNames: 'selector selectedInterval parseTree sequenceNode statementNodes transformedNode' classVariableNames: '' poolDictionaries: '' category: 'NautilusRefactoring-Refactorings'! !RBCreateCascadeRefactoring commentStamp: '' prior: 0! 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: '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: 'accessing'! selectedSource ^ self parseTree source copyFrom: selectedInterval first to: selectedInterval last! ! !RBCreateCascadeRefactoring methodsFor: 'initialization'! combine: anInterval from: aSelector in: aClass class := self classObjectFor: aClass. selector := aSelector. selectedInterval := anInterval! ! !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'! 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 methodsFor: 'preconditions'! 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: 'preconditions'! preconditions ^ (RBCondition definesSelector: selector in: class) & (RBCondition withBlock: [ self findSequenceNode; findStatementNodes; findReceiverNode. true ])! ! !RBCreateCascadeRefactoring methodsFor: 'transforming'! 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: 'transforming'! compileCode class compileTree: (RBParseTreeRewriter replaceStatements: sequenceNode formattedCode with: transformedNode formattedCode in: self parseTree onInterval: selectedInterval)! ! !RBCreateCascadeRefactoring methodsFor: 'transforming'! transform self combineMessages. self compileCode! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBCreateCascadeRefactoring class instanceVariableNames: ''! !RBCreateCascadeRefactoring class methodsFor: 'instance-creation'! combine: anInterval from: aSelector in: aClass ^ self new combine: anInterval from: aSelector in: aClass; yourself! ! !RBCreateCascadeRefactoring class methodsFor: 'instance-creation'! model: aNamespace combine: anInterval from: aSelector in: aClass ^ self new model: aNamespace; combine: anInterval from: aSelector in: aClass; yourself! ! RBBlockLintRule subclass: #RBDefinesEqualNotHashRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBDefinesEqualNotHashRule commentStamp: '' prior: 0! 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: '*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'! group ^ 'Possible bugs'! ! !RBDefinesEqualNotHashRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Defines = but not 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 9/8/2011 20:32'! resultClass ^ RBClassEnvironment! ! !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 instanceVariableNames: ''! !RBDefinesEqualNotHashRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBParseTreeLintRule subclass: #RBDetectContainsRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBDetectContainsRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 16:24'! category ^'Coding Idiom Violation'! ! !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: '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: '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 class instanceVariableNames: ''! !RBDetectContainsRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBTransformationRule subclass: #RBDetectIfNoneRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-TransformationRules'! !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 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: '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 class instanceVariableNames: ''! !RBDetectIfNoneRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBParseTreeLintRule subclass: #RBEmptyExceptionHandlerRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBEmptyExceptionHandlerRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 16:25'! category ^'Potential Bugs'! ! !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: '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: '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 class instanceVariableNames: ''! !RBEmptyExceptionHandlerRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBParseTreeLintRule subclass: #RBEndTrueFalseRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !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'! group ^ 'Unnecessary code'! ! !RBEndTrueFalseRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Check for same statements at end of ifTrue:ifFalse: blocks'! ! !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 5/15/2010 15:09'! severity ^ #information! ! !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 class instanceVariableNames: ''! !RBEndTrueFalseRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBTransformationRule subclass: #RBEqualNilRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-TransformationRules'! !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 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: '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 class instanceVariableNames: ''! !RBEqualNilRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBParseTreeLintRule subclass: #RBEqualNotUsedRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBEqualNotUsedRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 16:27'! category ^'Potential Bugs'! ! !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: 'accessing' stamp: 'lr 5/15/2010 17:53'! rationale ^ 'Checks for senders of comparator messages that do not use the result.'! ! !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 class instanceVariableNames: ''! !RBEqualNotUsedRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBParseTreeLintRule subclass: #RBEqualsTrueRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBEqualsTrueRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 16:27'! category ^'Optimization'! ! !RBEqualsTrueRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Unnecessary code'! ! !RBEqualsTrueRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Unnecessary "= true"'! ! !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 5/15/2010 15:09'! severity ^ #information! ! !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 class instanceVariableNames: ''! !RBEqualsTrueRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBBlockLintRule subclass: #RBEquivalentSuperclassMethodsRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBEquivalentSuperclassMethodsRule commentStamp: '' prior: 0! 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: '*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'! group ^ 'Unnecessary code'! ! !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: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Methods equivalently defined in superclass'! ! !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 5/15/2010 15:09'! severity ^ #information! ! !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 instanceVariableNames: ''! !RBEquivalentSuperclassMethodsRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBBlockLintRule subclass: #RBExcessiveArgumentsRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBExcessiveArgumentsRule commentStamp: '' prior: 0! 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: '*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: '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: '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: 'running' stamp: 'lr 6/15/2009 16:00'! checkMethod: aContext aContext selector numArgs >= self argumentsCount ifTrue: [ result addClass: aContext selectedClass selector: aContext selector ]! ! !RBExcessiveArgumentsRule methodsFor: 'private' stamp: 'lr 6/15/2009 15:59'! argumentsCount ^ 5! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBExcessiveArgumentsRule class instanceVariableNames: ''! !RBExcessiveArgumentsRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBBlockLintRule subclass: #RBExcessiveInheritanceRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBExcessiveInheritanceRule commentStamp: '' prior: 0! 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: '*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: 'lr 6/15/2009 16:03'! group ^ 'Miscellaneous'! ! !RBExcessiveInheritanceRule methodsFor: 'accessing' stamp: 'lr 6/15/2009 16:03'! name ^ 'Excessive inheritance depth'! ! !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: 'accessing' stamp: 'lr 9/8/2011 20:32'! resultClass ^ RBClassEnvironment! ! !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 methodsFor: 'private' stamp: 'lr 6/15/2009 16:22'! inheritanceDepth ^ 10! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBExcessiveInheritanceRule class instanceVariableNames: ''! !RBExcessiveInheritanceRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBBlockLintRule subclass: #RBExcessiveMethodsRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBExcessiveMethodsRule commentStamp: '' prior: 0! 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: '*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:57'! group ^ 'Miscellaneous'! ! !RBExcessiveMethodsRule methodsFor: 'accessing' stamp: 'lr 6/15/2009 15:58'! name ^ 'Excessive number of methods'! ! !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 9/8/2011 20:32'! resultClass ^ RBClassEnvironment! ! !RBExcessiveMethodsRule methodsFor: 'running' stamp: 'lr 6/15/2009 16:14'! checkClass: aContext aContext selectedClass selectors size >= self methodsCount ifTrue: [ result addClass: aContext selectedClass ]! ! !RBExcessiveMethodsRule methodsFor: 'private' stamp: 'lr 6/15/2009 16:23'! methodsCount ^ 40! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBExcessiveMethodsRule class instanceVariableNames: ''! !RBExcessiveMethodsRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBBlockLintRule subclass: #RBExcessiveVariablesRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBExcessiveVariablesRule commentStamp: '' prior: 0! 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: '*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: '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: '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 9/8/2011 20:32'! resultClass ^ RBClassEnvironment! ! !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 methodsFor: 'private' stamp: 'lr 6/15/2009 16:23'! variablesCount ^ 10! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBExcessiveVariablesRule class instanceVariableNames: ''! !RBExcessiveVariablesRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBRefactoring subclass: #RBExpandReferencedPoolsRefactoring instanceVariableNames: 'pools fromClass parseTree toClasses' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBExpandReferencedPoolsRefactoring methodsFor: 'initialize-release'! forMethod: aParseTree fromClass: aClass toClasses: classCollection fromClass := self model classFor: aClass. parseTree := aParseTree. toClasses := classCollection collect: [:each | self model classFor: each]! ! !RBExpandReferencedPoolsRefactoring methodsFor: 'preconditions'! preconditions ^RBCondition empty! ! !RBExpandReferencedPoolsRefactoring methodsFor: 'testing'! hasPoolsToMove ^pools isEmpty not! ! !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: '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: 'transforming'! movePoolVariables pools do: [:poolDict | toClasses do: [:each | self movePool: poolDict toClass: each]]! ! !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'! 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'! whichPoolDefines: varName | currentClass | currentClass := fromClass. [currentClass isNil] whileFalse: [currentClass allPoolDictionaryNames do: [:each | ((self poolVariableNamesIn: each) includes: varName) ifTrue: [^each]]. currentClass := currentClass superclass]. ^nil! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBExpandReferencedPoolsRefactoring class instanceVariableNames: ''! !RBExpandReferencedPoolsRefactoring class methodsFor: 'instance creation'! forMethod: aParseTree fromClass: aClass toClasses: classCollection ^(self new) forMethod: aParseTree fromClass: aClass toClasses: classCollection; yourself! ! !RBExpandReferencedPoolsRefactoring class methodsFor: 'instance creation'! model: aRBNamespace forMethod: aParseTree fromClass: aClass toClasses: classCollection ^(self new) model: aRBNamespace; forMethod: aParseTree fromClass: aClass toClasses: classCollection; yourself! ! RBParser subclass: #RBExplicitVariableParser instanceVariableNames: 'currentVariableNodeClass currentScope' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Parser'! !RBExplicitVariableParser commentStamp: '' prior: 0! I am a specialized version of the RBParser that takes the specialized sublcasses of RBVariableNode into account.! !RBExplicitVariableParser methodsFor: 'scoping' stamp: 'CamilloBruni 12/15/2011 16:27'! popScope currentScope := currentScope scope! ! !RBExplicitVariableParser methodsFor: 'scoping' stamp: 'CamilloBruni 12/15/2011 16:27'! pushScope: aNode aNode scope: currentScope. currentScope := aNode! ! !RBExplicitVariableParser methodsFor: 'private-classes' stamp: 'CamilloBruni 12/15/2011 16:16'! argumentNodeClass ^ RBArgumentNode! ! !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'! selfNodeClass ^ RBSelfNode! ! !RBExplicitVariableParser methodsFor: 'private-classes' stamp: 'CamilloBruni 12/15/2011 16:16'! superNodeClass ^ RBSuperNode! ! !RBExplicitVariableParser methodsFor: 'private-classes' stamp: 'CamilloBruni 12/15/2011 16:16'! temporaryNodeClass ^ RBTemporaryNode! ! !RBExplicitVariableParser methodsFor: 'private-classes' stamp: 'CamilloBruni 12/15/2011 16:16'! thisContextNodeClass ^ RBThisContextNode! ! !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:15'! variableNodeClass ^ currentVariableNodeClass ifNil: [ RBVariableNode ]! ! !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: 'private-parsing' stamp: 'CamilloBruni 12/15/2011 16:40'! 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 isNil ifFalse: [ methodNode pragmas: pragmas ]. ^methodNode! ! !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-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! ! RBParseTreeLintRule subclass: #RBExtraBlockRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !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'! group ^ 'Unnecessary code'! ! !RBExtraBlockRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Block immediately evaluated'! ! !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 5/15/2010 15:09'! severity ^ #information! ! !RBExtraBlockRule methodsFor: 'initialization' stamp: 'lr 2/24/2009 20:27'! 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 class instanceVariableNames: ''! !RBExtraBlockRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBMethodRefactoring subclass: #RBExtractMethodRefactoring instanceVariableNames: 'selector extractionInterval extractedParseTree modifiedParseTree parameters needsReturn' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBExtractMethodRefactoring methodsFor: 'initialize-release'! extract: anInterval from: aSelector in: aClass class := self classObjectFor: aClass. selector := aSelector. extractionInterval := anInterval! ! !RBExtractMethodRefactoring methodsFor: 'preconditions'! preconditions ^(RBCondition definesSelector: selector in: class) & (RBCondition withBlock: [self extractMethod. self checkSpecialExtractions. self checkReturn. needsReturn ifTrue: [extractedParseTree addReturn]. self checkTemporaries. true])! ! !RBExtractMethodRefactoring methodsFor: 'printing'! 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'! 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'! 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: '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/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: '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: 'transforming'! 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 methodsFor: 'transforming'! createTemporariesInExtractedMethodFor: assigned assigned do: [:each | extractedParseTree body addTemporaryNamed: each]! ! !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: '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: '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'! isMethodEquivalentTo: aSelector selector == aSelector ifTrue: [^false]. aSelector numArgs ~~ parameters size ifTrue: [^false]. (self isParseTreeEquivalentTo: aSelector) ifFalse: [^false]. self reorderParametersToMatch: aSelector. ^true! ! !RBExtractMethodRefactoring methodsFor: 'transforming'! 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'! methodDelimiter ^'#''place.holder.for.method'''! ! !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: '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'! remainingTemporaries | temps | temps := modifiedParseTree allDefinedVariables asSet. extractedParseTree allDefinedVariables do: [:each | temps remove: each ifAbsent: []]. ^temps! ! !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: '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 class instanceVariableNames: ''! !RBExtractMethodRefactoring class methodsFor: 'instance creation'! extract: anInterval from: aSelector in: aClass ^self new extract: anInterval from: aSelector in: aClass! ! !RBExtractMethodRefactoring class methodsFor: 'instance creation'! model: aRBSmalltalk extract: anInterval from: aSelector in: aClass ^(self new) model: aRBSmalltalk; extract: anInterval from: aSelector in: aClass; yourself! ! RBRefactoringTest subclass: #RBExtractMethodTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !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: '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: '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'! 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: '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'! 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'! 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: $).')! ! !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'! 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.'))! ! RBMethodRefactoring subclass: #RBExtractMethodToComponentRefactoring instanceVariableNames: 'selector extractionInterval extractedMethodSelector' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBExtractMethodToComponentRefactoring methodsFor: 'initialize-release'! extract: anInterval from: aSelector in: aClass class := self classObjectFor: aClass. selector := aSelector. extractionInterval := anInterval! ! !RBExtractMethodToComponentRefactoring methodsFor: 'preconditions'! preconditions ^RBCondition empty! ! !RBExtractMethodToComponentRefactoring methodsFor: 'printing'! 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: '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: '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: '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: 'transforming'! transform self extractMethod; moveMethod; inlineForwarder! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBExtractMethodToComponentRefactoring class instanceVariableNames: ''! !RBExtractMethodToComponentRefactoring class methodsFor: 'instance creation'! extract: anInterval from: aSelector in: aClass ^self new extract: anInterval from: aSelector in: aClass! ! !RBExtractMethodToComponentRefactoring class methodsFor: 'instance creation'! model: aRBSmalltalk extract: anInterval from: aSelector in: aClass ^(self new) model: aRBSmalltalk; extract: anInterval from: aSelector in: aClass; yourself! ! RBRefactoringTest subclass: #RBExtractMethodToComponentTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !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: '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'! testNonExistantSelector self shouldFail: (RBExtractMethodToComponentRefactoring extract: (10 to: 20) from: #checkClass1: in: RBBasicLintRuleTest)! ! !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! ! RBMethodRefactoring subclass: #RBExtractToTemporaryRefactoring instanceVariableNames: 'sourceInterval selector newVariableName parseTree' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBExtractToTemporaryRefactoring methodsFor: 'initialize-release'! extract: anInterval to: aString from: aSelector in: aClass class := self classObjectFor: aClass. selector := aSelector. sourceInterval := anInterval. newVariableName := aString! ! !RBExtractToTemporaryRefactoring methodsFor: 'preconditions'! 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 methodsFor: 'preconditions'! preconditions ^(RBCondition definesSelector: selector in: class) & (RBCondition isValidInstanceVariableName: newVariableName for: class) & (RBCondition withBlock: [self verifySelectedInterval. self checkVariableName. true])! ! !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: 'printing'! 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'! compileNewMethod class compileTree: self parseTree! ! !RBExtractToTemporaryRefactoring methodsFor: 'transforming'! constructAssignmentFrom: aNode | valueNode | valueNode := RBVariableNode named: newVariableName. ^RBAssignmentNode variable: valueNode value: aNode! ! !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'! transform self insertTemporary; compileNewMethod! ! !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: '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 class instanceVariableNames: ''! !RBExtractToTemporaryRefactoring class methodsFor: 'instance creation'! extract: anInterval to: aString from: aSelector in: aClass ^self new extract: anInterval to: aString from: aSelector in: aClass! ! !RBExtractToTemporaryRefactoring class methodsFor: 'instance creation'! model: aRBSmalltalk extract: anInterval to: aString from: aSelector in: aClass ^(self new) model: aRBSmalltalk; extract: anInterval to: aString from: aSelector in: aClass; yourself! ! RBRefactoringTest subclass: #RBExtractToTemporaryTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !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: '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: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testNonExistantSelector self shouldFail: (RBExtractToTemporaryRefactoring extract: (14 to: 23) to: 'asdf' from: #checkClass1: 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: '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]')! ! RBParseTreeLintRule subclass: #RBFileBlocksRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBFileBlocksRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 16:29'! category ^'Potential Bugs'! ! !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: '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: '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 class instanceVariableNames: ''! !RBFileBlocksRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBParseTreeLintRule subclass: #RBFloatEqualityComparisonRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBFloatEqualityComparisonRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 13:58'! category ^ 'Potential Bugs'! ! !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: '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: 'initialization' stamp: 'lr 3/13/2009 14:03'! initialize super initialize. self matcher matchesAnyOf: #( '`{ :node | node isLiteral and: [ node value isFloat ] } = `@expr' '`{ :node | node isLiteral and: [ node value isFloat ] } ~= `@expr' '`@expr = `{ :node | node isLiteral and: [ node value isFloat ] }' '`@expr ~= `{ :node | node isLiteral and: [ node value isFloat ] }' ) do: [ :node :answer | node ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBFloatEqualityComparisonRule class instanceVariableNames: ''! !RBFloatEqualityComparisonRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBLintRuleTest subclass: #RBFooLintRuleTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core-Data'! RBProgramNodeVisitor subclass: #RBFormatter instanceVariableNames: 'codeStream lineStart firstLineLength tabs' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Visitors'! !RBFormatter commentStamp: '' prior: 0! RBFormatter formats a parse tree. It is an example of a Visitor. This is rarely called directly. Sending 'formattedCode' to a parse tree uses this algorithm to return a pretty-printed version. Instance Variables: codeStream The buffer where the output is accumulated. firstLineLength The length of the first line of a message send. lineStart The position of the current line's start. tabs The number of tabs currently indented. ! !RBFormatter methodsFor: 'accessing'! firstLineLength ^firstLineLength isNil ifTrue: [codeStream position] ifFalse: [firstLineLength]! ! !RBFormatter methodsFor: 'accessing'! format: aNode self visitNode: aNode. ^codeStream contents! ! !RBFormatter methodsFor: 'accessing'! isMultiLine ^firstLineLength notNil! ! !RBFormatter methodsFor: 'accessing'! lastLineLength ^codeStream position - (lineStart max: 0)! ! !RBFormatter methodsFor: 'copying'! postCopy super postCopy. lineStart := self lineLength negated. codeStream := WriteStream on: (String new: 60). firstLineLength := nil! ! !RBFormatter methodsFor: 'initialize-release'! initialize super initialize. codeStream := WriteStream on: (String new: 60). tabs := 0. lineStart := 0! ! !RBFormatter methodsFor: 'testing'! startMessageSendOnNewLine: aMessageNode (self selectorsToStartOnNewLine includes: aMessageNode selector) ifTrue: [^true]. (self selectorsToLeaveOnLine includes: aMessageNode selector) ifTrue: [^false]. ^aMessageNode selector numArgs > self maximumArgumentsPerLine! ! !RBFormatter methodsFor: 'visiting'! visitNode: aNode | parenthesis | parenthesis := self needsParenthesisFor: aNode. parenthesis ifTrue: [codeStream nextPut: $(]. aNode acceptVisitor: self. parenthesis ifTrue: [codeStream nextPut: $)]! ! !RBFormatter methodsFor: 'visitor-double dispatching' stamp: 'lr 11/1/2009 20:23'! acceptArrayNode: anArrayNode codeStream nextPut: ${. anArrayNode statements isEmpty ifFalse: [ anArrayNode statements size > 1 ifTrue: [ self indent: 1 while: [ self indent. self formatStatementsFor: anArrayNode ]. self indent ] ifFalse: [ self formatStatementsFor: anArrayNode ] ]. codeStream nextPut: $}! ! !RBFormatter methodsFor: 'visitor-double dispatching' stamp: 'lr 11/2/2009 20:53'! acceptAssignmentNode: anAssignmentNode self indent: 2 while: [self visitNode: anAssignmentNode variable. codeStream space; nextPutAll: anAssignmentNode assignmentOperator; space. self visitNode: anAssignmentNode value]! ! !RBFormatter methodsFor: 'visitor-double dispatching'! acceptBlockNode: aBlockNode self acceptBlockNode: aBlockNode startBlockString: '[' endBlockString: ']'! ! !RBFormatter methodsFor: 'visitor-double dispatching'! acceptBlockNode: aBlockNode startBlockString: startBlockString endBlockString: endBlockString | seqNode multiline formattedBody formatter | seqNode := aBlockNode body. formatter := (self copy) lineStart: 0; yourself. formattedBody := formatter format: seqNode. multiline := self lineLength + formattedBody size > self maxLineSize or: [formatter isMultiLine]. multiline ifTrue: [self indent]. codeStream nextPutAll: startBlockString. aBlockNode arguments do: [:each | codeStream nextPut: $:. self visitNode: each. codeStream nextPut: $ ]. aBlockNode arguments notEmpty ifTrue: [codeStream nextPutAll: '| '. multiline ifTrue: [self indent]]. codeStream nextPutAll: formattedBody; nextPutAll: endBlockString! ! !RBFormatter methodsFor: 'visitor-double dispatching'! acceptCascadeNode: aCascadeNode | messages | messages := aCascadeNode messages. self visitNode: messages first receiver. self indentWhile: [self for: messages do: [:each | self indent; indentWhile: [self formatMessage: each cascade: true]] separatedBy: [codeStream nextPut: $;]]! ! !RBFormatter methodsFor: 'visitor-double dispatching'! acceptLiteralArrayNode: aRBArrayLiteralNode codeStream nextPutAll: (aRBArrayLiteralNode isForByteArray ifTrue: ['#['] ifFalse: ['#(']). self for: aRBArrayLiteralNode contents do: [:each | self visitNode: each] separatedBy: [codeStream nextPut: $ ]. codeStream nextPut: (aRBArrayLiteralNode isForByteArray ifTrue: [$]] ifFalse: [$)])! ! !RBFormatter methodsFor: 'visitor-double dispatching'! acceptLiteralNode: aLiteralNode aLiteralNode token storeOn: codeStream! ! !RBFormatter methodsFor: 'visitor-double dispatching'! acceptMessageNode: aMessageNode | newFormatter code | newFormatter := self copy. code := newFormatter format: aMessageNode receiver. codeStream nextPutAll: code. codeStream nextPut: $ . newFormatter isMultiLine ifTrue: [lineStart := codeStream position - newFormatter lastLineLength]. self indent: (newFormatter isMultiLine ifTrue: [2] ifFalse: [1]) while: [self formatMessage: aMessageNode cascade: false]! ! !RBFormatter methodsFor: 'visitor-double dispatching' stamp: 'lr 11/2/2009 10:10'! acceptMethodNode: aMethodNode self formatMethodPatternFor: aMethodNode. self indentWhile: [ self formatMethodCommentFor: aMethodNode indentBefore: true. self indent. self formatPragmasFor: aMethodNode. aMethodNode body statements notEmpty ifTrue: [ self visitNode: aMethodNode body ] ]! ! !RBFormatter methodsFor: 'visitor-double dispatching'! acceptPatternBlockNode: aRBPatternBlockNode self acceptBlockNode: aRBPatternBlockNode startBlockString: '`{' endBlockString: '}'! ! !RBFormatter methodsFor: 'visitor-double dispatching'! acceptPatternWrapperBlockNode: aRBPatternWrapperBlockNode self visitNode: aRBPatternWrapperBlockNode wrappedNode. self acceptBlockNode: aRBPatternWrapperBlockNode startBlockString: '`{' endBlockString: '}'! ! !RBFormatter methodsFor: 'visitor-double dispatching' stamp: 'cwp 10/29/2011 23:06'! acceptPragmaNode: aPragmaNode codeStream nextPut: $<. aPragmaNode selector isInfix ifTrue: [ codeStream nextPut: $ ]. self formatMessage: aPragmaNode cascade: false. codeStream nextPut: $>! ! !RBFormatter methodsFor: 'visitor-double dispatching'! acceptReturnNode: aReturnNode codeStream nextPut: $^. self visitNode: aReturnNode value! ! !RBFormatter methodsFor: 'visitor-double dispatching' stamp: 'lr 11/1/2009 20:04'! acceptSequenceNode: aSequenceNode self formatMethodCommentFor: aSequenceNode indentBefore: false. self formatTemporariesFor: aSequenceNode. self formatStatementsFor: aSequenceNode! ! !RBFormatter methodsFor: 'visitor-double dispatching'! acceptVariableNode: aVariableNode codeStream nextPutAll: aVariableNode name! ! !RBFormatter methodsFor: 'private'! for: aValue do: doBlock separatedBy: separatorBlock "This is implemented here since IBM Smalltalk doesn't implement a do:separatedBy: method" aValue isEmpty ifTrue: [^self]. 1 to: aValue size - 1 do: [:i | doBlock value: (aValue at: i). separatorBlock value]. doBlock value: aValue last! ! !RBFormatter methodsFor: 'private'! indent firstLineLength isNil ifTrue: [firstLineLength := codeStream position]. codeStream cr. tabs timesRepeat: [codeStream tab]. lineStart := codeStream position! ! !RBFormatter methodsFor: 'private'! indent: anInteger while: aBlock tabs := tabs + anInteger. aBlock value. tabs := tabs - anInteger! ! !RBFormatter methodsFor: 'private'! indentWhile: aBlock self indent: 1 while: aBlock! ! !RBFormatter methodsFor: 'private'! lineLength ^codeStream position - lineStart! ! !RBFormatter methodsFor: 'private'! lineStart: aPosition lineStart := aPosition! ! !RBFormatter methodsFor: 'private'! maxLineSize ^75! ! !RBFormatter methodsFor: 'private'! maximumArgumentsPerLine ^2! ! !RBFormatter methodsFor: 'private' stamp: 'lr 2/18/2010 16:00'! needsParenthesisFor: aNode | parent grandparent | aNode isValue ifFalse: [ ^ false ]. parent := aNode parent ifNil: [ ^ false ]. (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 ]. ^ self precedenceOf: parent selector greaterThan: aNode selector! ! !RBFormatter methodsFor: 'private'! 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 operators | operators := #(#($| $& $?) #($= $~ $< $>) #($- $+) #($* $/ $% $\) #($@)). childIndex := 0. parentIndex := 0. 1 to: operators size do: [:i | ((operators at: i) includes: parentSelector first) ifTrue: [parentIndex := i]. ((operators at: i) includes: childSelector first) ifTrue: [childIndex := i]]. ^childIndex < parentIndex! ! !RBFormatter methodsFor: 'private'! selectorsToLeaveOnLine ^#(#to:do: #to:by: #to:by:do:)! ! !RBFormatter methodsFor: 'private'! selectorsToStartOnNewLine ^#(#ifTrue:ifFalse: #ifFalse:ifTrue: #ifTrue: #ifFalse:)! ! !RBFormatter methodsFor: 'private-formatting'! formatMessage: aMessageNode cascade: cascadeBoolean | selectorParts arguments multiLine formattedArgs indentFirst firstArgLength length | selectorParts := aMessageNode selectorParts. arguments := aMessageNode arguments. formattedArgs := OrderedCollection new. multiLine := aMessageNode selector numArgs > self maximumArgumentsPerLine. length := aMessageNode selector size + arguments size + 1. firstArgLength := 0. self indentWhile: [1 to: arguments size do: [:i | | formatter string | formatter := (self copy) lineStart: (selectorParts at: i) length negated; yourself. string := formatter format: (arguments at: i). formattedArgs add: string. i == 1 ifTrue: [firstArgLength := formatter firstLineLength]. length := length + string size. multiLine := multiLine or: [formatter isMultiLine]]]. multiLine := multiLine or: [length + self lineLength > self maxLineSize]. indentFirst := cascadeBoolean not and: [multiLine and: [(self startMessageSendOnNewLine: aMessageNode) or: [self lineLength + selectorParts first length + 2 + firstArgLength > self maxLineSize]]]. indentFirst ifTrue: [self indent]. self formatMessageSelector: selectorParts withArguments: formattedArgs multiline: multiLine! ! !RBFormatter methodsFor: 'private-formatting' stamp: 'lr 2/6/2010 13:35'! formatMessageSelector: selectorParts withArguments: formattedArgs multiline: multiLine formattedArgs isEmpty ifTrue: [codeStream nextPutAll: selectorParts first value] ifFalse: [1 to: formattedArgs size do: [:i | (i ~= 1 and: [ multiLine not ]) ifTrue: [codeStream nextPut: $ ]. codeStream nextPutAll: (selectorParts at: i) value; nextPut: $ ; nextPutAll: (formattedArgs at: i). (multiLine and: [i < formattedArgs size]) ifTrue: [self indent]]]! ! !RBFormatter methodsFor: 'private-formatting'! formatMethodCommentFor: aNode indentBefore: aBoolean | source | source := aNode source. source isNil ifTrue: [^self]. aNode methodComments do: [:each | aBoolean ifTrue: [self indent]. codeStream nextPutAll: (aNode source copyFrom: each first to: each last); cr. aBoolean ifFalse: [self indent]]! ! !RBFormatter methodsFor: 'private-formatting'! formatMethodPatternFor: aMethodNode | selectorParts arguments | selectorParts := aMethodNode selectorParts. arguments := aMethodNode arguments. arguments isEmpty ifTrue: [codeStream nextPutAll: selectorParts first value] ifFalse: [selectorParts with: arguments do: [:selector :arg | codeStream nextPutAll: selector value; nextPut: $ . self visitArgument: arg. codeStream nextPut: $ ]]! ! !RBFormatter methodsFor: 'private-formatting' stamp: 'lr 11/2/2009 10:08'! formatPragmasFor: aNode aNode pragmas do: [ :each | self visitNode: each; indent ]! ! !RBFormatter methodsFor: 'private-formatting'! formatStatementCommentFor: aNode | source | source := aNode source. source isNil ifTrue: [^self]. aNode statementComments do: [:each | | crs | crs := self newLinesFor: source startingAt: each first. (crs - 1 max: 0) timesRepeat: [codeStream cr]. crs == 0 ifTrue: [codeStream tab] ifFalse: [self indent]. codeStream nextPutAll: (source copyFrom: each first to: each last)]! ! !RBFormatter methodsFor: 'private-formatting'! formatStatementsFor: aSequenceNode | statements | statements := aSequenceNode statements. statements isEmpty ifTrue: [^self]. 1 to: statements size - 1 do: [:i | self visitNode: (statements at: i). codeStream nextPut: $.. self formatStatementCommentFor: (statements at: i). self indent]. self visitNode: statements last. self formatStatementCommentFor: statements last! ! !RBFormatter methodsFor: 'private-formatting'! formatTemporariesFor: aSequenceNode | temps | temps := aSequenceNode temporaries. temps isEmpty ifTrue: [^self]. codeStream nextPutAll: '| '. temps do: [:each | self visitArgument: each. codeStream nextPut: $ ]. codeStream nextPut: $|. self indent! ! !RBFormatter methodsFor: 'private-formatting'! newLinesFor: aString startingAt: anIndex | count cr lf index char | cr := Character value: 13. lf := Character value: 10. count := 0. index := anIndex - 1. [index > 0 and: [char := aString at: index. char isSeparator]] whileTrue: [char == lf ifTrue: [count := count + 1. (aString at: (index - 1 max: 1)) == cr ifTrue: [index := index - 1]]. char == cr ifTrue: [count := count + 1]. index := index - 1]. ^count! ! TestCase subclass: #RBFormatterTests instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AST-Tests-Core'! !RBFormatterTests methodsFor: 'accessing' stamp: 'lr 11/2/2009 09:14'! formatters ^ Array with: RBFormatter with: RBConfigurableFormatter! ! !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: 'lr 9/4/2010 16:57'! formatClass: aClass selector: aSymbol self formatters do: [ :each | self formatClass: aClass selector: aSymbol formatter: each ]! ! !RBFormatterTests methodsFor: 'private' stamp: 'lr 9/4/2010 16:57'! formatClass: aClass selector: aSymbol formatter: aFormatterClass | source tree1 tree2 | source := aClass sourceCodeAt: aSymbol. tree1 := RBParser parseMethod: source. tree2 := RBParser parseMethod: (aFormatterClass new format: tree1) onError: [ :err :pos | self assert: false ]. self assert: tree1 = tree2! ! RBClassRefactoring subclass: #RBGenerateEqualHashRefactoring instanceVariableNames: 'variables' classVariableNames: '' poolDictionaries: '' category: 'NautilusRefactoring-Refactorings'! !RBGenerateEqualHashRefactoring methodsFor: 'accessing'! theClass ^ (self classObjectFor: className) theNonMetaClass! ! !RBGenerateEqualHashRefactoring methodsFor: 'accessing'! variables: anArray variables := anArray! ! !RBGenerateEqualHashRefactoring methodsFor: 'preconditions'! preconditions ^ variables inject: RBCondition empty into: [ :condition :variable | condition & (RBCondition definesInstanceVariable: variable in: self theClass) ]! ! !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'! 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: 'transforming'! 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'! transform self compileHash. self compileEqual! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBGenerateEqualHashRefactoring class instanceVariableNames: ''! !RBGenerateEqualHashRefactoring class methodsFor: 'instance-creation'! className: aClass variables: anArray ^ (self className: aClass) variables: anArray! ! !RBGenerateEqualHashRefactoring class methodsFor: 'instance-creation'! model: aNamespace className: aClass variables: anArray ^ (self model: aNamespace className: aClass) variables: anArray! ! RBClassRefactoring subclass: #RBGeneratePrintStringRefactoring instanceVariableNames: 'variables' classVariableNames: '' poolDictionaries: '' category: 'NautilusRefactoring-Refactorings'! !RBGeneratePrintStringRefactoring methodsFor: 'accessing'! theClass ^ (self classObjectFor: className) theNonMetaClass! ! !RBGeneratePrintStringRefactoring methodsFor: 'accessing'! variables: anArray variables := anArray! ! !RBGeneratePrintStringRefactoring methodsFor: 'preconditions'! preconditions ^ variables inject: RBCondition empty into: [ :condition :variable | condition & (RBCondition definesInstanceVariable: variable in: self theClass) ]! ! !RBGeneratePrintStringRefactoring methodsFor: 'transforming'! 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 class instanceVariableNames: ''! !RBGeneratePrintStringRefactoring class methodsFor: 'instance-creation'! className: aClass variables: anArray ^ (self className: aClass) variables: anArray! ! !RBGeneratePrintStringRefactoring class methodsFor: 'instance-creation'! model: aNamespace className: aClass variables: anArray ^ (self model: aNamespace className: aClass) variables: anArray! ! RBTransformationRule subclass: #RBGuardClauseRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-TransformationRules'! !RBGuardClauseRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:50'! category ^ 'Coding Idiom Violation'! ! !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: '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 class instanceVariableNames: ''! !RBGuardClauseRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBParseTreeLintRule subclass: #RBGuardingClauseRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBGuardingClauseRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 16:31'! category ^ 'Coding Idiom Violation'! ! !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: '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: '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 class instanceVariableNames: ''! !RBGuardingClauseRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBValueToken subclass: #RBIdentifierToken instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Tokens'! !RBIdentifierToken commentStamp: 'md 8/9/2005 14:51' prior: 0! RBIdentifierToken is the first class representation of an identifier token (e.g. Class) ! !RBIdentifierToken methodsFor: 'testing'! isIdentifier ^true! ! !RBIdentifierToken methodsFor: 'testing' stamp: 'lr 11/7/2009 15:30'! isPatternVariable ^value first = RBScanner patternVariableCharacter! ! RBParseTreeLintRule subclass: #RBIfTrueBlocksRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBIfTrueBlocksRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 16:34'! category ^ 'Optimization'! ! !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: '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: '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 class instanceVariableNames: ''! !RBIfTrueBlocksRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBParseTreeLintRule subclass: #RBIfTrueReturnsRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBIfTrueReturnsRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:21'! category ^ 'Optimization'! ! !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: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Checks for common ifTrue: returns that could be simplified using a boolean expression.'! ! !RBIfTrueReturnsRule methodsFor: 'initialization' stamp: 'lr 2/24/2009 20:30'! 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 isLiteral and: [ #(true false) includes: condition value ]) or: [ condition := node statements last value. condition isLiteral and: [ #(true false) includes: condition value ] ]) ifTrue: [ node ] ifFalse: [ nil ] ] ifFalse: [ answer ] ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBIfTrueReturnsRule class instanceVariableNames: ''! !RBIfTrueReturnsRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBBlockLintRule subclass: #RBImplementedNotSentRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBImplementedNotSentRule commentStamp: '' prior: 0! 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'! group ^ 'Unnecessary code'! ! !RBImplementedNotSentRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Methods implemented but not sent'! ! !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 5/15/2010 15:02'! severity ^ #information! ! !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 instanceVariableNames: ''! !RBImplementedNotSentRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBBlockLintRule subclass: #RBInconsistentMethodClassificationRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBInconsistentMethodClassificationRule commentStamp: '' prior: 0! 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: '*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: 'lr 2/23/2009 23:17'! group ^ 'Miscellaneous'! ! !RBInconsistentMethodClassificationRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Inconsistent method classification'! ! !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 9/8/2011 20:15'! resultClass ^ RBMultiEnvironment! ! !RBInconsistentMethodClassificationRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:02'! severity ^ #information! ! !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 instanceVariableNames: ''! !RBInconsistentMethodClassificationRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBRefactoringTest subclass: #RBInlineAllMethodTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !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')! ! RBMethodRefactoring subclass: #RBInlineAllSendersRefactoring instanceVariableNames: 'selector numberReplaced numberNotReplaced' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBInlineAllSendersRefactoring methodsFor: 'accessing'! messagesNotReplaced ^numberNotReplaced! ! !RBInlineAllSendersRefactoring methodsFor: 'initialize-release'! sendersOf: aSelector in: aClass class := self classObjectFor: aClass. selector := aSelector. numberReplaced := numberNotReplaced := 0! ! !RBInlineAllSendersRefactoring methodsFor: 'preconditions'! preconditions ^RBCondition canUnderstand: selector in: class! ! !RBInlineAllSendersRefactoring methodsFor: 'printing'! storeOn: aStream aStream nextPut: $(. self class storeOn: aStream. aStream nextPutAll: ' sendersOf: #'; nextPutAll: selector; nextPutAll: ' in: '. class storeOn: aStream. aStream nextPut: $)! ! !RBInlineAllSendersRefactoring methodsFor: 'transforming' stamp: 'CamilloBruni 10/8/2012 00:10'! checkInlinedMethods numberReplaced = 0 ifTrue: [self refactoringFailure: 'Could not inline any senders']! ! !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'! inlineSelfSends class withAllSubclasses do: [:each | | selectors | selectors := each selectors. selectors remove: selector ifAbsent: []. selectors do: [:sel | self inlineMessagesInClass: each andSelector: sel]]! ! !RBInlineAllSendersRefactoring methodsFor: 'transforming'! messagePattern ^'self ' , (self buildSelectorString: selector)! ! !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: '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: 'transforming'! transform self inlineSelfSends; removeMethod; checkInlinedMethods! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBInlineAllSendersRefactoring class instanceVariableNames: ''! !RBInlineAllSendersRefactoring class methodsFor: 'instance creation'! model: aRBSmalltalk sendersOf: aSelector in: aClass ^(self new) model: aRBSmalltalk; sendersOf: aSelector in: aClass; yourself! ! !RBInlineAllSendersRefactoring class methodsFor: 'instance creation'! sendersOf: aSelector in: aClass ^self new sendersOf: aSelector in: aClass! ! RBInlineMethodRefactoring subclass: #RBInlineMethodFromComponentRefactoring instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !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: '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'! addArgumentToSelector: aSymbol ^aSymbol isInfix ifTrue: [#value:value:] ifFalse: [(aSymbol , 'value:') asSymbol]! ! !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 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: 'transforming'! checkSuperMessages inlineParseTree superMessages isEmpty ifFalse: [self refactoringError: 'Cannot inline method since it sends a super message']! ! !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'! renameSelfReferences self addSelfReferenceToSourceMessage. self addSelfReferenceToInlineParseTree.! ! !RBInlineMethodFromComponentRefactoring methodsFor: 'transforming'! 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'! transform self abstractVariableReferences. self renameSelfReferences. super transform! ! RBRefactoringTest subclass: #RBInlineMethodFromComponentTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !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'! 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'! 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'! 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'! 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')! ! !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'! 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')! ! RBMethodRefactoring subclass: #RBInlineMethodRefactoring instanceVariableNames: 'sourceInterval inlineParseTree sourceParseTree sourceSelector sourceMessage inlineClass' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBInlineMethodRefactoring methodsFor: 'initialize-release'! inline: anInterval inMethod: aSelector forClass: aClass sourceSelector := aSelector. class := self classObjectFor: aClass. sourceInterval := anInterval! ! !RBInlineMethodRefactoring methodsFor: 'preconditions'! 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: 'printing'! 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: '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: 'testing' stamp: 'CamilloBruni 9/13/2012 14:20'! isOverridden | selector| selector := self inlineSelector. class allSubclassesDo: [:each | (each directlyDefinesMethod: selector) ifTrue: [ ^ true ]]. ^ false ! ! !RBInlineMethodRefactoring methodsFor: 'testing'! isPrimitive ^inlineParseTree isPrimitive! ! !RBInlineMethodRefactoring methodsFor: 'transforming'! addSelfReturn inlineParseTree addSelfReturn! ! !RBInlineMethodRefactoring methodsFor: 'transforming'! addTemporary: sourceNode assignedTo: replacementNode | newName | newName := self renameConflictingTemporary: sourceNode name. (inlineParseTree body) addTemporaryNamed: newName; addNodeFirst: (RBAssignmentNode variable: (RBVariableNode named: newName) value: replacementNode)! ! !RBInlineMethodRefactoring methodsFor: 'transforming'! 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'! compileMethod class compileTree: sourceParseTree! ! !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'! inlineClass ^inlineClass isNil ifTrue: [inlineClass := (sourceMessage receiver name = 'super' ifTrue: [class superclass] ifFalse: [class]) whoDefinesMethod: self inlineSelector] ifFalse: [inlineClass]! ! !RBInlineMethodRefactoring methodsFor: 'transforming'! inlineSelector sourceMessage isNil ifTrue: [self findSelectedMessage]. ^sourceMessage selector! ! !RBInlineMethodRefactoring methodsFor: 'transforming'! 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'! 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'! 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 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'! 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: '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: '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: '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'! renameConflictingTemporaries inlineParseTree allDefinedVariables do: [:each | self renameConflictingTemporary: each]! ! !RBInlineMethodRefactoring methodsFor: 'transforming'! 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'! 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: '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: 'transforming' stamp: 'lr 5/9/2010 11:32'! replaceArguments sourceMessage arguments reversed with: inlineParseTree arguments reversed do: [ :replacement :source | (replacement isImmediate or: [ self shouldInlineExpression: replacement newSource ]) ifTrue: [ self replaceArgument: source with: replacement ] ifFalse: [ self addTemporary: source assignedTo: replacement ] ]! ! !RBInlineMethodRefactoring methodsFor: 'transforming'! 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'! rewriteInlinedTree sourceMessage parent isReturn ifTrue: [(sourceParseTree isLast: sourceMessage parent) ifFalse: [self addSelfReturn]] ifFalse: [self writeGuardClauses; normalizeIfTrues; normalizeReturns; addSelfReturn]! ! !RBInlineMethodRefactoring methodsFor: 'transforming'! transform self renameConflictingTemporaries; insertInlinedMethod; compileMethod! ! !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 class instanceVariableNames: ''! !RBInlineMethodRefactoring class methodsFor: 'instance creation'! inline: anInterval inMethod: aSelector forClass: aClass ^self new inline: anInterval inMethod: aSelector forClass: aClass! ! !RBInlineMethodRefactoring class methodsFor: 'instance creation'! model: aRBSmalltalk inline: anInterval inMethod: aSelector forClass: aClass ^(self new) model: aRBSmalltalk; inline: anInterval inMethod: aSelector forClass: aClass; yourself! ! RBRefactoringTest subclass: #RBInlineMethodTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !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: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testInlineMethodForSuperSendThatAlsoSendsSuper | refactoring | model := Compiler evaluate: self inlineMethodTestData. refactoring := RBInlineMethodRefactoring inline: (102 to: 131) inMethod: #executeNotifying: forClass: (model classNamed: #RBRenameInstanceVariableChange). self shouldFail: refactoring! ! !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: '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'! 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'! testReturn self shouldFail: (RBInlineMethodRefactoring inline: (self convertInterval: (418 to: 485) for: (RBBasicLintRuleTest class sourceCodeAt: #utilityMethods)) inMethod: #utilityMethods forClass: RBBasicLintRuleTest class)! ! !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'! 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'! 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'! 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'! 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'! 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: 'tests' stamp: 'lr 9/8/2011 20:11'! testInlineMethodForSuperSend | refactoring | model := Compiler 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: '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: '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')! ! RBRemoveParameterRefactoring subclass: #RBInlineParameterRefactoring instanceVariableNames: 'expressions' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBInlineParameterRefactoring methodsFor: 'initialize-release'! inlineParameter: aString in: aClass selector: aSelector oldSelector := aSelector. class := self classObjectFor: aClass. argument := aString! ! !RBInlineParameterRefactoring methodsFor: 'preconditions'! 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 isLiteral]) errorMacro: 'All values passed must be literal.')! ! !RBInlineParameterRefactoring methodsFor: 'printing'! 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: 'transforming'! 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: 'private'! 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: '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 class instanceVariableNames: ''! !RBInlineParameterRefactoring class methodsFor: 'instance creation'! inlineParameter: aString in: aClass selector: aSelector ^self new inlineParameter: aString in: aClass selector: aSelector! ! !RBInlineParameterRefactoring class methodsFor: 'instance creation'! model: aRBSmalltalk inlineParameter: aString in: aClass selector: aSelector ^(self new) model: aRBSmalltalk; inlineParameter: aString in: aClass selector: aSelector; yourself! ! RBRefactoringTest subclass: #RBInlineParameterTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !RBInlineParameterTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testInlineBlockFailure self shouldFail: (RBInlineParameterRefactoring inlineParameter: 'aBlock' in: RBRefactoryTestDataApp selector: ('inline' , 'Foo:') asSymbol)! ! !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)! ! RBMethodRefactoring subclass: #RBInlineTemporaryRefactoring instanceVariableNames: 'sourceInterval selector sourceTree assignmentNode definingNode' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBInlineTemporaryRefactoring methodsFor: 'initialize-release'! inline: anInterval from: aSelector in: aClass class := self classObjectFor: aClass. selector := aSelector. sourceInterval := anInterval! ! !RBInlineTemporaryRefactoring methodsFor: 'preconditions'! preconditions ^(RBCondition definesSelector: selector in: class) & (RBCondition withBlock: [self verifySelectedInterval. true])! ! !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: 'printing'! 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: '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'! compileMethod class compileTree: sourceTree! ! !RBInlineTemporaryRefactoring methodsFor: 'transforming'! replaceAssignment assignmentNode parent isSequence ifTrue: [assignmentNode parent removeNode: assignmentNode] ifFalse: [assignmentNode replaceWith: assignmentNode value]! ! !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'! transform self replaceAssignment; replaceReferences; compileMethod! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBInlineTemporaryRefactoring class instanceVariableNames: ''! !RBInlineTemporaryRefactoring class methodsFor: 'instance creation'! inline: anInterval from: aSelector in: aClass ^self new inline: anInterval from: aSelector in: aClass! ! !RBInlineTemporaryRefactoring class methodsFor: 'instance creation'! model: aRBSmalltalk inline: anInterval from: aSelector in: aClass ^(self new) model: aRBSmalltalk; inline: anInterval from: aSelector in: aClass; yourself! ! RBRefactoringTest subclass: #RBInlineTemporaryTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !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'! 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'! testInlineTemporaryMutlipleAssignment self shouldFail: (RBInlineTemporaryRefactoring inline: (self convertInterval: (60 to: 83) for: (RBRefactoryTestDataApp sourceCodeAt: #moveDefinition)) from: #moveDefinition in: RBRefactoryTestDataApp)! ! !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)! ! RBBlockLintRule subclass: #RBInstVarInSubclassesRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBInstVarInSubclassesRule commentStamp: '' prior: 0! 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: '*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'! group ^ 'Miscellaneous'! ! !RBInstVarInSubclassesRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Instance variables defined in all subclasses'! ! !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 9/8/2011 20:32'! resultClass ^ RBVariableEnvironment! ! !RBInstVarInSubclassesRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:03'! severity ^ #information! ! !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 instanceVariableNames: ''! !RBInstVarInSubclassesRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBVariableBinding subclass: #RBInstanceBinding instanceVariableNames: 'name index' classVariableNames: '' poolDictionaries: '' category: 'AST-Semantic-Binding'! !RBInstanceBinding methodsFor: 'accessing' stamp: 'lr 4/27/2010 14:14'! index ^ index! ! !RBInstanceBinding methodsFor: 'accessing' stamp: 'lr 4/27/2010 14:14'! name ^ name! ! !RBInstanceBinding methodsFor: 'initialization' stamp: 'lr 4/27/2010 14:15'! initializeName: aString index: anInteger name := aString. index := anInteger! ! !RBInstanceBinding methodsFor: 'testing-type' stamp: 'lr 4/28/2010 09:36'! isInstanceBinding ^ true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBInstanceBinding class instanceVariableNames: ''! !RBInstanceBinding class methodsFor: 'instance creation' stamp: 'lr 4/27/2010 14:29'! name: aString index: anInteger ^ self new initializeName: aString index: anInteger! ! RBBlockLintRule subclass: #RBInstanceVariableCapitalizationRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBInstanceVariableCapitalizationRule commentStamp: '' prior: 0! See my #rationale.! !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: '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: '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 9/8/2011 20:32'! resultClass ^ RBVariableEnvironment! ! !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 instanceVariableNames: ''! !RBInstanceVariableCapitalizationRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBSpellingRule subclass: #RBInstanceVariableNamesSpellingRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Spelling'! !RBInstanceVariableNamesSpellingRule commentStamp: '' prior: 0! See #name for the area where I check spelling.! !RBInstanceVariableNamesSpellingRule methodsFor: 'accessing' stamp: 'lr 2/24/2009 07:57'! name ^ 'Instance variable names'! ! !RBInstanceVariableNamesSpellingRule methodsFor: 'accessing' stamp: 'lr 9/8/2011 20:32'! resultClass ^ RBClassEnvironment! ! !RBInstanceVariableNamesSpellingRule methodsFor: 'running' stamp: 'lr 1/21/2010 21:31'! checkClass: aContext aContext selectedClass instVarNames do: [ :name | (self checkIdentifier: name) do: [ :each | result addSearchString: each; addClass: aContext selectedClass ] ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBInstanceVariableNamesSpellingRule class instanceVariableNames: ''! !RBInstanceVariableNamesSpellingRule 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" ^'InstanceVariableNamesSpellingRule'! ! RBSpellChecker subclass: #RBInternalSpellChecker instanceVariableNames: 'words' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Spelling'! !RBInternalSpellChecker commentStamp: 'lr 2/8/2009 12:47' prior: 0! A stupid spell checker implementation, to be used in case no native spell checker is available. Uses a combined word-list of and .! !RBInternalSpellChecker methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 9/26/2012 16:24'! dataFile ^ self directory / self filename! ! !RBInternalSpellChecker methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 9/26/2012 16:18'! directory ^ FileSystem disk workingDirectory! ! !RBInternalSpellChecker methodsFor: 'accessing' stamp: 'SvenVanCaekenberghe 9/26/2012 16:24'! filename ^ self url asZnUrl file! ! !RBInternalSpellChecker methodsFor: 'accessing' stamp: 'lr 1/22/2010 09:45'! url ^ 'http://www.lukas-renggli.ch/smalltalk/rb-spelling.dat'! ! !RBInternalSpellChecker methodsFor: 'accessing' stamp: 'lr 3/8/2009 20:21'! words ^ words! ! !RBInternalSpellChecker methodsFor: 'initialization' stamp: 'lr 1/22/2010 08:11'! initialize super initialize. words := self loadData! ! !RBInternalSpellChecker methodsFor: 'public' stamp: 'lr 12/22/2010 13:58'! check: aString | input output errors | input := aString readStream. output := WriteStream on: (String new: 128). errors := OrderedCollection new. [ input atEnd ] whileFalse: [ | start stop | start := input position + 1. [ input atEnd not and: [ input peek isLetter or: [ input peek = $' ] ] ] whileTrue: [ output nextPut: input next ]. stop := input position. [ input atEnd not and: [ input peek isLetter not ] ] whileTrue: [ input next ]. (start < stop and: [ (self validate: output contents) not ]) ifTrue: [ errors addLast: (start to: stop) ]. output reset ]. ^ errors! ! !RBInternalSpellChecker methodsFor: 'public' stamp: 'lr 1/21/2010 23:20'! validate: aString "Do a binary search for the word aString. Answer true if the aString is in the list of known words." | check low high index word | check := aString asLowercase. low := 1. high := words size. [ index := low + high // 2. low <= high ] whileTrue: [ word := words at: index. word = check ifTrue: [ ^ true ]. word < check ifTrue: [ low := index + 1 ] ifFalse: [ high := index - 1 ] ]. ^ word = check! ! !RBInternalSpellChecker methodsFor: 'private' stamp: 'SvenVanCaekenberghe 9/26/2012 22:10'! downloadData "Download data from a server." ZnClient new systemPolicy; url: self url; downloadTo: self directory! ! !RBInternalSpellChecker methodsFor: 'private' stamp: 'SvenVanCaekenberghe 9/26/2012 17:24'! loadData "Load data from an external file as fast as possible." | result | self dataFile exists ifFalse: [ self downloadData ]. self dataFile exists ifFalse: [ self error: 'The spelling dictionary cannot be downloaded from <' , self url , '>.' ]. self dataFile readStreamDo: [ :stream | | zstream size | zstream := ZLibReadStream on: stream binary. result := Array new: (size := zstream nextInt32). 1 to: size do: [ :index | result at: index put: (String withAll: (zstream next: zstream next)) ] ]. ^ result! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBInternalSpellChecker class instanceVariableNames: ''! !RBInternalSpellChecker class methodsFor: 'private' stamp: 'GuillermoPolito 1/21/2012 22:55'! createWordList: aString "The input of the wordlist can be something from ." "self createWordList: '/Users/renggli/Desktop/words.txt'" | words input output zipped | words := Set new. input := FileStream fileNamed: aString. input converter: Latin1TextConverter new. [ input atEnd ] whileFalse: [ | word | word := input upTo: Character lf. word isNil ifFalse: [ word := word trimBoth. word size > 1 ifTrue: [ words add: word asLowercase ] ] ]. output := self basicNew directory forceNewFileNamed: self basicNew filename. zipped := ZLibWriteStream on: output binary. zipped nextInt32Put: words size. words asArray sort do: [ :each | zipped nextPut: each size; nextPutAll: (ByteArray withAll: each) ]. zipped close. output close! ! RBBlockLintRule subclass: #RBJustSendsSuperRule instanceVariableNames: 'matcher' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBJustSendsSuperRule commentStamp: '' prior: 0! 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: '*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'! group ^ 'Unnecessary code'! ! !RBJustSendsSuperRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Method just sends super message'! ! !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 5/15/2010 15:10'! severity ^ #information! ! !RBJustSendsSuperRule methodsFor: 'initialization' stamp: 'lr 11/2/2009 00:14'! initialize super initialize. matcher := RBParseTreeSearcher justSendsSuper! ! !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 instanceVariableNames: ''! !RBJustSendsSuperRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBValueToken subclass: #RBKeywordToken instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Tokens'! !RBKeywordToken commentStamp: 'md 8/9/2005 14:52' prior: 0! RBKeywordToken is the first-class representation of a keyword token (e.g. add:)! !RBKeywordToken methodsFor: 'testing'! isKeyword ^true! ! !RBKeywordToken methodsFor: 'testing' stamp: 'lr 11/7/2009 15:30'! isPatternVariable ^value first = RBScanner patternVariableCharacter! ! RBParseTreeLintRule subclass: #RBLawOfDemeterRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBLawOfDemeterRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:21'! category ^ 'Design Flaws'! ! !RBLawOfDemeterRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Intention revealing'! ! !RBLawOfDemeterRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Law of demeter'! ! !RBLawOfDemeterRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'The Law of Demeter is a design guideline for developing software and can be succinctly summarized as "Only talk to your immediate friends". The fundamental notion is that a given object should assume as little as possible about the structure or properties of anything else. If long method chains are used a lot of system knowledge is hardcoded into a single method and might make reusability difficult.'! ! !RBLawOfDemeterRule methodsFor: 'initialization' stamp: 'lr 2/24/2009 20:31'! initialize super initialize. self matcher matches: '(((`@reciver `@msg1: `@arg1) `@msg2: `@arg2) `@msg3: `@arg3) `@msg4: `@arg4' do: [ :node :answer | node ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBLawOfDemeterRule class instanceVariableNames: ''! !RBLawOfDemeterRule class methodsFor: '*Manifest-Core'! 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! ! !RBLawOfDemeterRule 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" ^'LawOfDemeterRule'! ! Object subclass: #RBLexicalScope instanceVariableNames: 'bindings' classVariableNames: '' poolDictionaries: '' category: 'AST-Semantic-Scope'! !RBLexicalScope methodsFor: 'adding' stamp: 'lr 4/28/2010 09:25'! add: aVariableBinding "Add aVariableBinding to the receving scope." ^ bindings at: aVariableBinding name put: (aVariableBinding setScope: self)! ! !RBLexicalScope methodsFor: 'initialization' stamp: 'lr 4/28/2010 09:23'! initialize bindings := RBSmallDictionary new! ! !RBLexicalScope methodsFor: 'querying' stamp: 'lr 4/28/2010 09:25'! bindingOf: aString "Answer the local binding of aString or nil." ^ bindings at: aString ifAbsent: [ | binding | binding := (self basicBindingOf: aString) ifNil: [ ^ nil ]. self add: binding ]! ! !RBLexicalScope methodsFor: 'querying' stamp: 'lr 4/27/2010 15:14'! lookup: aString "Lookup the variable aString in the receiving scope, throw an error if not found." ^ self lookup: aString ifAbsent: [ self error: 'No binding for ' , aString printString , ' found.' ]! ! !RBLexicalScope methodsFor: 'querying' stamp: 'lr 4/28/2010 09:19'! lookup: aString ifAbsent: aBlock "Lookup the variable aString in the receiving scope, evaluate aBlock if not found." self subclassResponsibility! ! !RBLexicalScope methodsFor: 'testing' stamp: 'lr 5/11/2010 19:11'! isBlockScope ^ false! ! !RBLexicalScope methodsFor: 'testing' stamp: 'lr 5/11/2010 19:11'! isLiteralScope ^ false! ! !RBLexicalScope methodsFor: 'testing' stamp: 'lr 5/11/2010 19:11'! isMethodScope ^ false! ! !RBLexicalScope methodsFor: 'testing' stamp: 'lr 5/11/2010 19:11'! isRootScope ^ false! ! !RBLexicalScope methodsFor: 'testing' stamp: 'lr 5/11/2010 19:11'! isVariableScope ^ false! ! !RBLexicalScope methodsFor: 'private' stamp: 'lr 4/27/2010 15:15'! basicBindingOf: aString ^ nil! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBLexicalScope class instanceVariableNames: ''! !RBLexicalScope class methodsFor: 'instance creation' stamp: 'lr 4/28/2010 09:16'! new ^ self basicNew initialize! ! Object subclass: #RBLintRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics'! !RBLintRule commentStamp: '' prior: 0! I represent an executable check applied on an environment (groups of classes, methods... )! !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: '*Manifest-Core' stamp: 'SimonAllier 4/2/2012 11:41'! critics | result | result := self result. result ifNil: [ ^ {} ]. ( result isKindOf: RBMultiEnvironment) ifTrue: [ result := result asSelectorEnvironment ]. result isSelectorEnvironment ifTrue: [ | array | array := OrderedCollection new: result numberSelectors. result classes do: [:cl | result selectorsForClass: cl do: [:sel | array add: (cl>>sel)]]. ^ array ]. ^ result allClasses ! ! !RBLintRule methodsFor: '*Manifest-Core'! isTransformationRule ^ false ! ! !RBLintRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 5/21/2012 14:38'! leaves ^ {self}! ! !RBLintRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 8/22/2012 11:22'! longDescription ^ self rationale ! ! !RBLintRule methodsFor: '*Manifest-Core'! result ^ self subclassResponsibility! ! !RBLintRule methodsFor: 'accessing' stamp: 'lr 2/24/2009 08:29'! changes ^ #()! ! !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: 'accessing' stamp: 'lr 2/23/2009 21:41'! problemCount self subclassResponsibility! ! !RBLintRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 14:59'! rationale "Answer a detailled explanation of the rule." ^ String new! ! !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: '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: 'StephaneDucasse 12/30/2012 16:32'! checkClass: aContext "Is a hook to specify a check that is performed at the class level" ! ! !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: 'lr 2/23/2009 21:35'! resetResult! ! !RBLintRule methodsFor: 'running' stamp: 'lr 9/8/2011 20:15'! run ^ RBSmalllintChecker runRule: self! ! !RBLintRule methodsFor: 'running' stamp: 'lr 9/8/2011 20:15'! runOnEnvironment: anEnvironment ^ RBSmalllintChecker runRule: self onEnvironment: anEnvironment! ! !RBLintRule methodsFor: 'testing' stamp: 'lr 2/23/2009 21:52'! hasConflicts ^ false! ! !RBLintRule methodsFor: 'testing' stamp: 'lr 2/23/2009 21:52'! isComposite ^ false! ! !RBLintRule methodsFor: 'testing' stamp: 'lr 2/23/2009 21:51'! isEmpty 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 class instanceVariableNames: ''! !RBLintRule class methodsFor: '*Manifest-Core'! 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: '*Manifest-Core'! uniqueIdentifierNumber "This number should be unique and should change only when the rule completely change semantics" ^ 0! ! !RBLintRule class methodsFor: 'testing' stamp: 'lr 2/24/2009 17:08'! isVisible "Answer true if the class should be visible in the GUI." ^ false! ! Object subclass: #RBLintRuleTest instanceVariableNames: 'name foo1' classVariableNames: 'Foo1' poolDictionaries: 'TextConstants' category: 'Refactoring-Tests-Core-Data'! !RBLintRuleTest methodsFor: 'accessing'! checkClass: aSmalllintContext! ! !RBLintRuleTest methodsFor: 'accessing'! checkMethod: aSmalllintContext! ! !RBLintRuleTest methodsFor: 'accessing'! displayName | nameStream | nameStream := WriteStream on: (String new: 64). nameStream nextPutAll: self name; nextPutAll: ' ('. self problemCount printOn: nameStream. nameStream nextPut: $). ^nameStream contents! ! !RBLintRuleTest methodsFor: 'accessing'! name ^name! ! !RBLintRuleTest methodsFor: 'accessing'! 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: 'accessing'! problemCount ^self subclassResponsibility! ! !RBLintRuleTest methodsFor: 'accessing'! run ^Object printOn: self! ! !RBLintRuleTest methodsFor: 'accessing'! runOnEnvironment: anEnvironment ^Object printOn: self onEnvironment: anEnvironment! ! !RBLintRuleTest methodsFor: 'initialize-release'! initialize name := ''! ! !RBLintRuleTest methodsFor: 'initialize-release'! resetResult! ! !RBLintRuleTest methodsFor: 'printing'! printOn: aStream name isNil ifTrue: [super printOn: aStream] ifFalse: [aStream nextPutAll: name]! ! !RBLintRuleTest methodsFor: 'testing'! hasConflicts ^false! ! !RBLintRuleTest methodsFor: 'testing'! isComposite ^false! ! !RBLintRuleTest methodsFor: 'testing'! isEmpty self subclassResponsibility! ! !RBLintRuleTest methodsFor: 'testing' stamp: 'lr 2/26/2009 15:07'! junk ^ RBRefactoryTestDataApp printString copyFrom: 1 to: CR! ! !RBLintRuleTest methodsFor: 'private'! failedRules ^self isEmpty ifTrue: [#()] ifFalse: [Array with: self]! ! !RBLintRuleTest methodsFor: 'private'! viewResults self subclassResponsibility! ! RBParseTreeLintRule subclass: #RBLiteralArrayCharactersRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBLiteralArrayCharactersRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:22'! category ^ 'Optimization'! ! !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: 'accessing' stamp: 'lr 5/15/2010 17:35'! rationale ^ 'Literal arrays containing only characters can more efficiently represented as strings.'! ! !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: '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 instanceVariableNames: ''! !RBLiteralArrayCharactersRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBBlockLintRule subclass: #RBLiteralArrayContainsCommaRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBLiteralArrayContainsCommaRule commentStamp: '' prior: 0! See my #rationale.! !RBLiteralArrayContainsCommaRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 14:13'! category ^ 'Coding Idiom Violation'! ! !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: '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: '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 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 class instanceVariableNames: ''! !RBLiteralArrayContainsCommaRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBBlockLintRule subclass: #RBLiteralArrayContainsSuspiciousTrueFalseOrNilRule instanceVariableNames: 'matcher' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBLiteralArrayContainsSuspiciousTrueFalseOrNilRule commentStamp: '' prior: 0! See my #rationale. This smell checks methods having #(#true #false #nil) in their literal frame, which may be a bug. ! !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'! 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: '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: '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: '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 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 class instanceVariableNames: ''! !RBLiteralArrayContainsSuspiciousTrueFalseOrNilRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBLiteralNode subclass: #RBLiteralArrayNode instanceVariableNames: 'isByteArray stop contents start' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Nodes'! !RBLiteralArrayNode commentStamp: '' prior: 0! 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'! children ^contents! ! !RBLiteralArrayNode methodsFor: 'accessing'! contents ^contents! ! !RBLiteralArrayNode methodsFor: 'accessing'! startWithoutParentheses ^start! ! !RBLiteralArrayNode methodsFor: 'accessing'! stopWithoutParentheses ^stop! ! !RBLiteralArrayNode methodsFor: 'accessing'! 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'! = 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: 'comparing'! 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: 'copying' stamp: 'lr 11/1/2009 22:35'! postCopy super postCopy. self contents: (self contents collect: [ :each | each copy ])! ! !RBLiteralArrayNode methodsFor: 'initialize-release'! contents: aRBLiteralNodeCollection contents := aRBLiteralNodeCollection. contents do: [:each | each parent: self]! ! !RBLiteralArrayNode methodsFor: 'initialize-release'! startPosition: startInteger contents: anArray stopPosition: stopInteger isByteArray: aBoolean start := startInteger. self contents: anArray. stop := stopInteger. isByteArray := aBoolean! ! !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: '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: 'replacing'! replaceNode: aNode withNode: anotherNode self contents: (contents collect: [:each | each == aNode ifTrue: [anotherNode] ifFalse: [each]])! ! !RBLiteralArrayNode methodsFor: 'testing'! isForByteArray ^isByteArray! ! !RBLiteralArrayNode methodsFor: 'testing'! isLiteralArray ^true! ! !RBLiteralArrayNode methodsFor: 'visitor' stamp: 'CamilloBruni 2/3/2012 16:34'! accept: aProgramNodeVisitor ^aProgramNodeVisitor visitLiteralArrayNode: self! ! !RBLiteralArrayNode methodsFor: 'visitor'! acceptVisitor: aProgramNodeVisitor ^aProgramNodeVisitor acceptLiteralArrayNode: self! ! !RBLiteralArrayNode methodsFor: 'private-replacing'! 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 class instanceVariableNames: ''! !RBLiteralArrayNode class methodsFor: 'instance creation'! startPosition: startInteger contents: anArray stopPosition: stopInteger isByteArray: aBoolean ^(self new) startPosition: startInteger contents: anArray stopPosition: stopInteger isByteArray: aBoolean; yourself! ! !RBLiteralArrayNode class methodsFor: 'instance creation'! value: aValue ^(self new) startPosition: nil contents: (aValue asArray collect: [:each | RBLiteralNode value: each]) stopPosition: nil isByteArray: aValue class ~~ Array; yourself! ! RBValueToken subclass: #RBLiteralArrayToken instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Tokens'! !RBLiteralArrayToken methodsFor: 'testing'! isForByteArray ^value last = $[! ! !RBLiteralArrayToken methodsFor: 'testing'! isLiteralArrayToken ^true! ! RBVariableBinding subclass: #RBLiteralBinding instanceVariableNames: 'binding' classVariableNames: '' poolDictionaries: '' category: 'AST-Semantic-Binding'! !RBLiteralBinding methodsFor: 'accessing' stamp: 'lr 4/27/2010 14:57'! binding ^ binding! ! !RBLiteralBinding methodsFor: 'accessing' stamp: 'lr 4/27/2010 14:57'! name ^ binding key asString! ! !RBLiteralBinding methodsFor: 'accessing' stamp: 'CamilloBruni 12/5/2011 15:11'! value ^ self binding value! ! !RBLiteralBinding methodsFor: 'initialization' stamp: 'lr 4/27/2010 14:58'! initializeBinding: aBinding binding := aBinding! ! !RBLiteralBinding methodsFor: 'testing-type' stamp: 'lr 4/28/2010 09:36'! isLiteralBinding ^ true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBLiteralBinding class instanceVariableNames: ''! !RBLiteralBinding class methodsFor: 'instance creation' stamp: 'lr 4/27/2010 14:58'! binding: aBinding ^ self new initializeBinding: aBinding! ! RBValueNode subclass: #RBLiteralNode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Nodes'! !RBLiteralNode commentStamp: '' prior: 0! RBLiteralNode is an AST node that represents literals.! !RBLiteralNode methodsFor: 'accessing'! precedence ^0! ! !RBLiteralNode methodsFor: 'accessing'! value ^self subclassResponsibility! ! !RBLiteralNode methodsFor: 'comparing' stamp: 'lr 5/30/2010 11:34'! = anObject self == anObject ifTrue: [^true]. ^self class = anObject class! ! !RBLiteralNode methodsFor: 'comparing'! hash ^self value hash! ! !RBLiteralNode methodsFor: 'testing'! isImmediateNode ^true! ! !RBLiteralNode methodsFor: 'testing'! isLiteralNode ^true! ! !RBLiteralNode methodsFor: 'testing'! needsParenthesis ^false! ! !RBLiteralNode methodsFor: 'private-replacing'! replaceSourceFrom: aNode self addReplacement: (RBStringReplacement replaceFrom: aNode start to: aNode stop with: self formattedCode)! ! !RBLiteralNode methodsFor: 'private-replacing'! replaceSourceWith: aNode self addReplacement: (RBStringReplacement replaceFrom: self start to: self stop with: aNode formattedCode)! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBLiteralNode class instanceVariableNames: ''! !RBLiteralNode class methodsFor: 'instance creation'! 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'! value: aValue ^((aValue class == Array or: [aValue class == ByteArray]) ifTrue: [RBLiteralArrayNode] ifFalse: [RBLiteralValueNode]) value: aValue! ! RBClassScope subclass: #RBLiteralScope instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AST-Semantic-Scope'! !RBLiteralScope methodsFor: 'testing' stamp: 'lr 5/11/2010 19:12'! isLiteralScope ^ true! ! !RBLiteralScope methodsFor: 'private' stamp: 'lr 4/27/2010 15:41'! basicBindingOf: aString ^ (class bindingOf: aString) ifNotNil: [ :binding | RBLiteralBinding binding: binding ]! ! RBValueToken subclass: #RBLiteralToken instanceVariableNames: 'stopPosition' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Tokens'! !RBLiteralToken commentStamp: 'md 8/9/2005 14:52' prior: 0! 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: 'accessing'! realValue ^value! ! !RBLiteralToken methodsFor: 'accessing'! stop: anObject stopPosition := anObject! ! !RBLiteralToken methodsFor: 'initialize-release'! value: aString start: anInteger stop: stopInteger value := aString. sourcePointer := anInteger. stopPosition := stopInteger! ! !RBLiteralToken methodsFor: 'printing'! 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: 'testing'! isLiteralToken ^true! ! !RBLiteralToken methodsFor: 'testing'! isMultiKeyword ^false! ! !RBLiteralToken methodsFor: 'private'! length ^stopPosition - self start + 1! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBLiteralToken class instanceVariableNames: ''! !RBLiteralToken class methodsFor: 'instance creation'! 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'! value: aString start: anInteger stop: stopInteger ^(self new) value: aString start: anInteger stop: stopInteger; yourself! ! RBLiteralNode subclass: #RBLiteralValueNode instanceVariableNames: 'token' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Nodes'! !RBLiteralValueNode commentStamp: '' prior: 0! 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: 'accessing'! startWithoutParentheses ^token start! ! !RBLiteralValueNode methodsFor: 'accessing'! stopWithoutParentheses ^token stop! ! !RBLiteralValueNode methodsFor: 'accessing'! token ^token! ! !RBLiteralValueNode methodsFor: 'accessing'! 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: 'initialize-release'! literalToken: aLiteralToken token := aLiteralToken! ! !RBLiteralValueNode methodsFor: 'matching' stamp: 'lr 11/24/2009 23:36'! copyInContext: aDictionary ^ self class literalToken: self token copy removePositions! ! !RBLiteralValueNode methodsFor: 'visitor' stamp: 'CamilloBruni 2/3/2012 16:34'! accept: aProgramNodeVisitor ^aProgramNodeVisitor visitLiteralNode: self! ! !RBLiteralValueNode methodsFor: 'visitor'! acceptVisitor: aProgramNodeVisitor ^aProgramNodeVisitor acceptLiteralNode: self! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBLiteralValueNode class instanceVariableNames: ''! !RBLiteralValueNode class methodsFor: 'instance creation'! literalToken: aLiteralToken ^(self new) literalToken: aLiteralToken; yourself! ! !RBLiteralValueNode class methodsFor: 'instance creation'! value: aValue ^self literalToken: (RBLiteralToken value: aValue)! ! RBSpellingRule subclass: #RBLiteralValuesSpellingRule instanceVariableNames: 'matcher' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Spelling'! !RBLiteralValuesSpellingRule commentStamp: '' prior: 0! See #name for the area where I check spelling.! !RBLiteralValuesSpellingRule methodsFor: 'accessing' stamp: 'lr 2/24/2009 07:57'! name ^ 'Literal values'! ! !RBLiteralValuesSpellingRule methodsFor: 'initialization' stamp: 'lr 1/12/2010 11:43'! initialize super initialize. matcher := RBParseTreeSearcher new. matcher matches: '`#literal' do: [ :node :answer | self add: node value to: answer ]! ! !RBLiteralValuesSpellingRule methodsFor: 'running' stamp: 'lr 7/10/2011 16:57'! checkMethod: aContext | literals | literals := matcher executeTree: aContext parseTree initialAnswer: Set new. literals do: [ :literal | (self checkLiteral: literal) do: [ :each | result addSearchString: each; addClass: aContext selectedClass selector: aContext selector ] ]! ! !RBLiteralValuesSpellingRule methodsFor: 'private' stamp: 'lr 1/12/2010 11:56'! add: aLiteral to: aCollection aLiteral isString ifTrue: [ aCollection add: aLiteral ] ifFalse: [ aLiteral isArray ifTrue: [ aLiteral do: [ :each | self add: each to: aCollection ] ] ]. ^ aCollection! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBLiteralValuesSpellingRule class instanceVariableNames: ''! !RBLiteralValuesSpellingRule 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" ^'LiteralValuesSpellingRule'! ! RBVariableBinding subclass: #RBLocalBinding instanceVariableNames: 'node' classVariableNames: '' poolDictionaries: '' category: 'AST-Semantic-Binding'! !RBLocalBinding methodsFor: 'accessing' stamp: 'lr 4/27/2010 14:36'! name ^ node name! ! !RBLocalBinding methodsFor: 'accessing' stamp: 'lr 4/27/2010 13:59'! node "Answer the declaring or defining node." ^ node! ! !RBLocalBinding methodsFor: 'initialization' stamp: 'lr 4/27/2010 15:31'! setNode: aNode node := aNode. node propertyAt: #variableBinding put: self! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBLocalBinding class instanceVariableNames: ''! !RBLocalBinding class methodsFor: 'instance creation' stamp: 'lr 4/27/2010 14:07'! node: aNode ^ self new setNode: aNode! ! RBBlockLintRule subclass: #RBLongMethodsRule instanceVariableNames: 'matcher' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBLongMethodsRule commentStamp: '' prior: 0! 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: '*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: 'lr 2/23/2009 23:17'! group ^ 'Miscellaneous'! ! !RBLongMethodsRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Long methods'! ! !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: '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: '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 methodsFor: 'private' stamp: 'lr 2/24/2009 00:12'! longMethodSize ^ 10! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBLongMethodsRule class instanceVariableNames: ''! !RBLongMethodsRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBSpellChecker subclass: #RBMacSpellChecker instanceVariableNames: '' classVariableNames: 'Utf16Converter' poolDictionaries: '' category: 'Refactoring-Spelling'! !RBMacSpellChecker commentStamp: 'lr 2/8/2009 12:48' prior: 0! A native spell checker of the Apple OS X platform. Source code is ripped from JMMMacSpelling.1.cs by John McIntosh .! !RBMacSpellChecker methodsFor: 'public' stamp: 'lr 12/22/2010 13:34'! check: aString | position errors string result | position := 1. errors := OrderedCollection new. string := aString convertToWithConverter: Utf16Converter. [ position <= string size ] whileTrue: [ result := self primitiveCheckSpelling: string startingAt: position. (result first between: 1 and: string size) ifFalse: [ ^ errors ]. errors addLast: (result first to: result first + result second - 1). position := result first + result second ]. ^ errors! ! !RBMacSpellChecker methodsFor: 'private' stamp: 'lr 2/8/2009 11:58'! primitiveCheckSpelling: aString startingAt: anInteger self primitiveFailed! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBMacSpellChecker class instanceVariableNames: ''! !RBMacSpellChecker class methodsFor: 'initialization' stamp: 'lr 2/8/2009 11:15'! initialize Utf16Converter := TextConverter newForEncoding: 'utf-16'! ! !RBMacSpellChecker class methodsFor: 'primitives' stamp: 'lr 2/8/2009 12:08'! primitiveGetUniqueSpellingTag ^ nil! ! !RBMacSpellChecker class methodsFor: 'testing' stamp: 'lr 1/21/2010 19:06'! isSupported ^ self primitiveGetUniqueSpellingTag notNil! ! RBValueNode subclass: #RBMessageNode instanceVariableNames: 'receiver selector selectorParts arguments' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Nodes'! !RBMessageNode commentStamp: 'md 8/9/2005 14:58' prior: 0! 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: 'accessing'! arguments ^arguments isNil ifTrue: [#()] ifFalse: [arguments]! ! !RBMessageNode methodsFor: 'accessing'! arguments: argCollection arguments := argCollection. arguments do: [:each | each parent: self]! ! !RBMessageNode methodsFor: 'accessing'! children ^(OrderedCollection with: self receiver) addAll: self arguments; yourself! ! !RBMessageNode methodsFor: 'accessing'! numArgs ^self selector numArgs! ! !RBMessageNode methodsFor: 'accessing'! precedence ^self isUnary ifTrue: [1] ifFalse: [self isKeyword ifTrue: [3] ifFalse: [2]]! ! !RBMessageNode methodsFor: 'accessing'! receiver ^receiver! ! !RBMessageNode methodsFor: 'accessing'! receiver: aValueNode receiver := aValueNode. receiver parent: self! ! !RBMessageNode methodsFor: 'accessing'! renameSelector: newSelector andArguments: varNodeCollection self arguments: varNodeCollection; selector: newSelector! ! !RBMessageNode methodsFor: 'accessing'! selector ^selector isNil ifTrue: [selector := self buildSelector] ifFalse: [selector]! ! !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: 'accessing' stamp: 'lr 5/30/2010 14:21'! sentMessages ^ super sentMessages add: self selector; yourself! ! !RBMessageNode methodsFor: 'accessing'! startWithoutParentheses ^receiver start! ! !RBMessageNode methodsFor: 'accessing'! stopWithoutParentheses ^arguments isEmpty ifTrue: [selectorParts first stop] ifFalse: [arguments last stop]! ! !RBMessageNode methodsFor: 'comparing'! = 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: 'comparing'! 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: 'comparing' stamp: 'lr 3/7/2010 13:50'! hash ^ (self receiver hash bitXor: self selector hash) bitXor: (self hashForCollection: self arguments)! ! !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: 'initialize-release'! receiver: aValueNode selectorParts: keywordTokens arguments: valueNodes self receiver: aValueNode. selectorParts := keywordTokens. self arguments: valueNodes! ! !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: '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: 'querying'! 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: 'replacing'! 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: 'testing'! isBinary ^(self isUnary or: [self isKeyword]) not! ! !RBMessageNode methodsFor: 'testing'! isCascaded ^parent notNil and: [parent isCascade]! ! !RBMessageNode methodsFor: 'testing'! isFirstCascaded ^self isCascaded and: [parent messages first == self]! ! !RBMessageNode methodsFor: 'testing' stamp: 'lr 11/2/2009 23:37'! isKeyword ^selectorParts first value last = $:! ! !RBMessageNode methodsFor: 'testing'! isMessage ^true! ! !RBMessageNode methodsFor: 'testing' stamp: 'lr 10/20/2009 11:43'! isSelfSend ^ self receiver isVariable and: [ self receiver name = 'self' ]! ! !RBMessageNode methodsFor: 'testing' stamp: 'lr 10/20/2009 11:43'! isSuperSend ^ self receiver isVariable and: [ self receiver name = 'super' ]! ! !RBMessageNode methodsFor: 'testing'! isUnary ^arguments isEmpty! ! !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: 'testing'! needsParenthesis ^parent isNil ifTrue: [false] ifFalse: [self precedence > parent precedence or: [self precedence = parent precedence and: [self isUnary not]]]! ! !RBMessageNode methodsFor: 'visitor' stamp: 'CamilloBruni 2/3/2012 16:34'! accept: aProgramNodeVisitor ^aProgramNodeVisitor visitMessageNode: self! ! !RBMessageNode methodsFor: 'visitor'! acceptVisitor: aProgramNodeVisitor ^aProgramNodeVisitor acceptMessageNode: self! ! !RBMessageNode methodsFor: 'private' stamp: 'lr 5/30/2010 09:36'! buildSelector | selectorStream | selectorStream := WriteStream on: (String new: 50). selectorParts do: [ :each | selectorStream nextPutAll: each value ]. ^ selectorStream contents asSymbol! ! !RBMessageNode methodsFor: 'private' stamp: 'lr 5/30/2010 09:36'! selectorParts ^ selectorParts! ! !RBMessageNode methodsFor: 'private' stamp: 'lr 5/30/2010 09:36'! selectorParts: tokenCollection selectorParts := tokenCollection! ! !RBMessageNode methodsFor: 'private-replacing'! isContainmentReplacement: aNode ^(self mappingFor: self receiver) = aNode or: [self arguments anySatisfy: [:each | (self mappingFor: each) = aNode]]! ! !RBMessageNode methodsFor: 'private-replacing'! 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: 'private-replacing'! replaceSourceWith: aNode (self isContainmentReplacement: aNode) ifTrue: [^self replaceContainmentSourceWith: aNode]. aNode isMessage ifFalse: [^super replaceSourceWith: aNode]. ^self replaceSourceWithMessageNode: aNode! ! !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 class instanceVariableNames: ''! !RBMessageNode class methodsFor: 'instance creation'! receiver: aValueNode selector: aSymbol ^self receiver: aValueNode selector: aSymbol arguments: #()! ! !RBMessageNode class methodsFor: 'instance creation'! receiver: aValueNode selector: aSymbol arguments: valueNodes ^(self new) receiver: aValueNode; arguments: valueNodes; selector: aSymbol; yourself! ! !RBMessageNode class methodsFor: 'instance creation'! receiver: aValueNode selectorParts: keywordTokens arguments: valueNodes ^(self new) receiver: aValueNode selectorParts: keywordTokens arguments: valueNodes; yourself! ! RBAbstractClass subclass: #RBMetaclass instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Model'! !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: 'accessing' stamp: 'lr 10/26/2009 22:09'! theMetaClass ^ self! ! !RBMetaclass methodsFor: 'initialize-release' stamp: 'lr 7/23/2010 08:03'! realName: aSymbol self realClass: (Smalltalk globals at: aSymbol) classSide! ! !RBMetaclass methodsFor: 'printing'! printOn: aStream super printOn: aStream. aStream nextPutAll: ' class'! ! !RBMetaclass methodsFor: 'printing'! storeOn: aStream super storeOn: aStream. aStream nextPutAll: ' class'! ! !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 methodsFor: 'testing'! isMeta ^true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBMetaclass class instanceVariableNames: ''! !RBMetaclass class methodsFor: 'instance creation'! existingNamed: aSymbol ^(self named: aSymbol) realName: aSymbol; yourself! ! !RBMetaclass class methodsFor: 'instance creation'! named: aSymbol ^(self new) name: aSymbol; yourself! ! Object subclass: #RBMethod instanceVariableNames: 'class compiledMethod source selector' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Model'! !RBMethod methodsFor: 'accessing'! method ^compiledMethod! ! !RBMethod methodsFor: 'accessing'! method: aCompiledMethod compiledMethod := aCompiledMethod! ! !RBMethod methodsFor: 'accessing'! modelClass ^class! ! !RBMethod methodsFor: 'accessing'! modelClass: aRBClass class := aRBClass! ! !RBMethod methodsFor: 'accessing'! parseTree ^RBParser parseMethod: self source onError: [:str :pos | ^nil]! ! !RBMethod methodsFor: 'accessing' stamp: 'lr 11/1/2009 23:15'! protocols ^ self modelClass protocolsFor: self selector! ! !RBMethod methodsFor: 'accessing'! selector ^selector! ! !RBMethod methodsFor: 'accessing'! selector: aSymbol selector := aSymbol! ! !RBMethod methodsFor: 'accessing' stamp: 'lr 11/1/2009 23:15'! source ^ source ifNil: [ source := (class realClass sourceCodeAt: selector) asString ]! ! !RBMethod methodsFor: 'accessing'! source: aString source := aString! ! !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: 'printing'! printOn: aStream class printOn: aStream. aStream nextPutAll: '>>'; nextPutAll: self selector! ! !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: '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: '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: '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 class instanceVariableNames: ''! !RBMethod class methodsFor: 'instance creation'! for: aRBClass fromMethod: aCompiledMethod andSelector: aSymbol ^(self new) modelClass: aRBClass; method: aCompiledMethod; selector: aSymbol; yourself! ! !RBMethod class methodsFor: 'instance creation'! for: aRBClass source: aString selector: aSelector ^(self new) modelClass: aRBClass; selector: aSelector; source: aString; yourself! ! RBSpellingRule subclass: #RBMethodCommentsSpellingRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Spelling'! !RBMethodCommentsSpellingRule commentStamp: '' prior: 0! See #name for the area where I check spelling.! !RBMethodCommentsSpellingRule methodsFor: 'accessing' stamp: 'lr 2/24/2009 07:57'! name ^ 'Method comments'! ! !RBMethodCommentsSpellingRule methodsFor: 'running' stamp: 'lr 7/10/2011 16:28'! checkMethod: aContext aContext parseTree nodesDo: [ :node | node comments do: [ :interval | | source | source := aContext sourceCode asString copyFrom: interval first + 1 to: interval last - 1. (self check: source) do: [ :each | (self ignore: each in: aContext) ifFalse: [ result addSearchString: each; addClass: aContext selectedClass selector: aContext selector ] ] ] ]! ! !RBMethodCommentsSpellingRule methodsFor: 'private' stamp: 'lr 7/10/2011 16:48'! ignore: aString in: aContext ^ (aContext selectedClass bindingOf: aString) notNil or: [ (aContext selectedClass instVarNames includes: aString) or: [ (aContext parseTree allDefinedVariables includes: aString) or: [ (aContext literals includes: aString asSymbol) ] ] ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBMethodCommentsSpellingRule class instanceVariableNames: ''! !RBMethodCommentsSpellingRule 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" ^'MethodCommentsSpellingRule'! ! RBBlockLintRule subclass: #RBMethodHasNoTimeStampRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBMethodHasNoTimeStampRule commentStamp: '' prior: 0! See my #rationale.! !RBMethodHasNoTimeStampRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 10:24'! category ^ 'Bugs' ! ! !RBMethodHasNoTimeStampRule methodsFor: 'accessing' stamp: 'lr 3/17/2010 17:54'! group ^ 'Pharo bugs'! ! !RBMethodHasNoTimeStampRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Method has no timeStamp'! ! !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 5/15/2010 15:11'! severity ^ #error! ! !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 class instanceVariableNames: ''! !RBMethodHasNoTimeStampRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBBlockLintRule subclass: #RBMethodModifierFinalRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-Unused'! !RBMethodModifierFinalRule commentStamp: '' prior: 0! See my #rationale.! !RBMethodModifierFinalRule methodsFor: 'accessing' stamp: 'lr 11/4/2010 12:40'! group ^ 'Bugs'! ! !RBMethodModifierFinalRule methodsFor: 'accessing' stamp: 'lr 11/4/2010 12:40'! name ^ 'Overrides a final method'! ! !RBMethodModifierFinalRule methodsFor: 'accessing' stamp: 'SeanDeNigris 1/31/2013 09:20'! rationale ^ 'Checks that methods marked with is never overridden.'! ! !RBMethodModifierFinalRule methodsFor: 'accessing' stamp: 'lr 11/4/2010 12:40'! severity ^ #error! ! !RBMethodModifierFinalRule methodsFor: 'running' stamp: 'lr 11/4/2010 12:43'! checkMethod: aContext | current | current := aContext selectedClass superclass. [ current notNil ] whileTrue: [ current methodDictionary at: aContext selector ifPresent: [ :method | (method pragmas anySatisfy: [ :each | each keyword = #modifier: and: [ each arguments first = #final ] ]) ifTrue: [ result addClass: aContext selectedClass selector: aContext selector ] ]. current := current superclass ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBMethodModifierFinalRule class instanceVariableNames: ''! !RBMethodModifierFinalRule class methodsFor: '*Manifest-Core'! 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! ! !RBMethodModifierFinalRule 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" ^'MethodModifierFinalRule'! ! RBBlockLintRule subclass: #RBMethodModifierOverrideRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-Unused'! !RBMethodModifierOverrideRule commentStamp: '' prior: 0! See my #rationale.! !RBMethodModifierOverrideRule methodsFor: 'accessing' stamp: 'lr 11/4/2010 12:53'! group ^ 'Bugs'! ! !RBMethodModifierOverrideRule methodsFor: 'accessing' stamp: 'lr 11/4/2010 12:56'! name ^ 'Missing super implementation'! ! !RBMethodModifierOverrideRule methodsFor: 'accessing' stamp: 'SeanDeNigris 1/31/2013 09:20'! rationale ^ 'Checks that a method marked with overrides an actual superclass method.'! ! !RBMethodModifierOverrideRule methodsFor: 'accessing' stamp: 'lr 11/4/2010 12:53'! severity ^ #error! ! !RBMethodModifierOverrideRule methodsFor: 'running' stamp: 'lr 11/4/2010 13:06'! checkMethod: aContext (aContext compiledMethod pragmas anySatisfy: [ :each | each keyword = #modifier: and: [ each arguments first = #override ] ]) ifFalse: [ ^ self ]. (aContext selectedClass superclass isNil) ifTrue: [ ^ self ]. (aContext selectedClass superclass whichClassIncludesSelector: aContext selector) isNil ifTrue: [ result addClass: aContext selectedClass selector: aContext selector ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBMethodModifierOverrideRule class instanceVariableNames: ''! !RBMethodModifierOverrideRule class methodsFor: '*Manifest-Core'! 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! ! !RBMethodModifierOverrideRule 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" ^'MethodModifierOverrideRule'! ! RBBlockLintRule subclass: #RBMethodModifierSuperRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-Unused'! !RBMethodModifierSuperRule commentStamp: '' prior: 0! See my #rationale.! !RBMethodModifierSuperRule methodsFor: 'accessing' stamp: 'lr 11/4/2010 12:44'! group ^ 'Bugs'! ! !RBMethodModifierSuperRule methodsFor: 'accessing' stamp: 'lr 11/4/2010 12:45'! name ^ 'Super call required'! ! !RBMethodModifierSuperRule methodsFor: 'accessing' stamp: 'SeanDeNigris 1/31/2013 09:21'! rationale ^ 'Checks that methods marked with are always called when overridden.'! ! !RBMethodModifierSuperRule methodsFor: 'accessing' stamp: 'lr 11/4/2010 12:44'! severity ^ #error! ! !RBMethodModifierSuperRule methodsFor: 'running' stamp: 'lr 11/4/2010 12:46'! checkMethod: aContext | current | (aContext superMessages includes: aContext selector) ifTrue: [ ^ self ]. current := aContext selectedClass superclass. [ current notNil ] whileTrue: [ current methodDictionary at: aContext selector ifPresent: [ :method | (method pragmas anySatisfy: [ :each | each keyword = #modifier: and: [ each arguments first = #super ] ]) ifTrue: [ result addClass: aContext selectedClass selector: aContext selector ] ]. current := current superclass ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBMethodModifierSuperRule class instanceVariableNames: ''! !RBMethodModifierSuperRule class methodsFor: '*Manifest-Core'! 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! ! !RBMethodModifierSuperRule 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" ^'MethodModifierSuperRule'! ! Object subclass: #RBMethodName instanceVariableNames: 'selector arguments' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Support'! !RBMethodName methodsFor: 'accessing'! arguments ^arguments! ! !RBMethodName methodsFor: 'accessing'! arguments: nameCollection arguments := nameCollection. self changed: #arguments! ! !RBMethodName methodsFor: 'accessing'! selector ^selector! ! !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 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 class instanceVariableNames: ''! !RBMethodName class methodsFor: 'instance creation'! selector: aSymbol arguments: stringCollection ^(self new) selector: aSymbol; arguments: stringCollection; yourself! ! RBProgramNode subclass: #RBMethodNode instanceVariableNames: 'scope classBinding selector selectorParts body source arguments pragmas replacements nodeReplacements' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Nodes'! !RBMethodNode commentStamp: '' prior: 0! 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: 'accessing' stamp: 'lr 1/4/2012 21:40'! addNode: aNode ^ body addNode: aNode! ! !RBMethodNode methodsFor: 'accessing' stamp: 'lr 1/4/2012 21:38'! addReturn ^ body addReturn! ! !RBMethodNode methodsFor: 'accessing' stamp: 'lr 1/4/2012 21:38'! addSelfReturn ^ body addSelfReturn! ! !RBMethodNode methodsFor: 'accessing'! allArgumentVariables ^(self argumentNames asOrderedCollection) addAll: super allArgumentVariables; yourself! ! !RBMethodNode methodsFor: 'accessing'! allDefinedVariables ^(self argumentNames asOrderedCollection) addAll: super allDefinedVariables; yourself! ! !RBMethodNode methodsFor: 'accessing'! argumentNames ^self arguments collect: [:each | each name]! ! !RBMethodNode methodsFor: 'accessing'! arguments ^arguments! ! !RBMethodNode methodsFor: 'accessing'! arguments: variableNodes arguments := variableNodes. arguments do: [:each | each parent: self]! ! !RBMethodNode methodsFor: 'accessing'! body ^body! ! !RBMethodNode methodsFor: 'accessing'! body: stmtsNode body := stmtsNode. body parent: self! ! !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: 'accessing' stamp: 'MarcusDenker 11/20/2012 14:40'! classBinding ^classBinding! ! !RBMethodNode methodsFor: 'accessing' stamp: 'MarcusDenker 11/20/2012 14:40'! classBinding: anAssociation classBinding := anAssociation.! ! !RBMethodNode methodsFor: 'accessing' stamp: 'MarcusDenker 11/20/2012 14:41'! methodClass ^classBinding value! ! !RBMethodNode methodsFor: 'accessing'! methodComments | methodComments | methodComments := OrderedCollection withAll: self comments. arguments do: [:each | methodComments addAll: each comments]. ^methodComments asSortedCollection: [:a :b | a first < b first]! ! !RBMethodNode methodsFor: 'accessing'! methodNode ^self! ! !RBMethodNode methodsFor: 'accessing'! newSource replacements isNil ifTrue: [^self formattedCode]. ^[self reformatSource] on: Error do: [:ex | ex return: self formattedCode]! ! !RBMethodNode methodsFor: 'accessing'! numArgs ^self selector numArgs! ! !RBMethodNode methodsFor: 'accessing' stamp: 'lr 11/1/2009 19:34'! pragmas ^ pragmas ifNil: [ #() ]! ! !RBMethodNode methodsFor: 'accessing' stamp: 'lr 11/1/2009 19:34'! pragmas: aCollection pragmas := aCollection. pragmas do: [ :each | each parent: 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: 'accessing'! renameSelector: newSelector andArguments: varNodeCollection | oldSelectorParts oldArguments | oldSelectorParts := selectorParts. oldArguments := arguments. self arguments: varNodeCollection; selector: newSelector. self changeSourceSelectors: oldSelectorParts arguments: oldArguments! ! !RBMethodNode methodsFor: 'accessing' stamp: 'CamilloBruni 12/15/2011 16:28'! scope ^ scope! ! !RBMethodNode methodsFor: 'accessing' stamp: 'CamilloBruni 12/15/2011 16:28'! scope: aScopedNode scope := aScopedNode! ! !RBMethodNode methodsFor: 'accessing'! selector ^selector isNil ifTrue: [selector := self buildSelector] ifFalse: [selector]! ! !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: 'accessing'! source ^source! ! !RBMethodNode methodsFor: 'accessing'! source: anObject source := anObject! ! !RBMethodNode methodsFor: 'accessing'! start ^1! ! !RBMethodNode methodsFor: 'accessing' stamp: 'CamilloBruni 2/3/2012 16:42'! statements ^ self body statements! ! !RBMethodNode methodsFor: 'accessing'! stop ^source size! ! !RBMethodNode methodsFor: 'accessing' stamp: 'CamilloBruni 2/3/2012 16:41'! temporaries ^ self body temporaries! ! !RBMethodNode methodsFor: 'accessing' stamp: 'CamilloBruni 12/8/2011 16:19'! temporaryNames ^ self body temporaryNames! ! !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: '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: '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: '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: 'initialize-release'! 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: 'initialize-release'! selectorParts: tokenCollection arguments: variableNodes selectorParts := tokenCollection. self arguments: variableNodes! ! !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: '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: '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: 'printing'! printOn: aStream aStream nextPutAll: self formattedCode! ! !RBMethodNode methodsFor: 'replacing'! addReplacement: aStringReplacement replacements isNil ifTrue: [^self]. replacements add: aStringReplacement! ! !RBMethodNode methodsFor: 'replacing'! clearReplacements replacements := nil! ! !RBMethodNode methodsFor: 'replacing'! map: oldNode to: newNode nodeReplacements at: oldNode put: newNode! ! !RBMethodNode methodsFor: 'replacing'! mappingFor: oldNode ^nodeReplacements at: oldNode ifAbsent: [oldNode]! ! !RBMethodNode methodsFor: 'replacing'! replaceNode: aNode withNode: anotherNode aNode == body ifTrue: [self body: anotherNode]. self arguments: (arguments collect: [:each | each == aNode ifTrue: [anotherNode] ifFalse: [each]])! ! !RBMethodNode methodsFor: 'testing'! defines: aName ^arguments anySatisfy: [:each | each name = aName]! ! !RBMethodNode methodsFor: 'testing' stamp: 'CamilloBruni 12/15/2011 16:32'! hasArgumentNamed: aString ^ self arguments anySatisfy: [ :argument| argument name = aString ]! ! !RBMethodNode methodsFor: 'testing' stamp: 'CamilloBruni 2/3/2012 15:47'! hasPragmaNamed: aSymbol ^ self pragmas anySatisfy: [ :pragma| pragma selector = aSymbol]! ! !RBMethodNode methodsFor: 'testing' stamp: 'CamilloBruni 12/15/2011 16:32'! hasTemporaryNamed: aString ^ self temporaries anySatisfy: [ :temp| temp name = aString ]! ! !RBMethodNode methodsFor: 'testing'! isLast: aNode ^body isLast: aNode! ! !RBMethodNode methodsFor: 'testing'! isMethod ^true! ! !RBMethodNode methodsFor: 'testing' stamp: 'lr 11/1/2009 19:37'! isPrimitive ^ self pragmas anySatisfy: [ :each | each isPrimitive ]! ! !RBMethodNode methodsFor: 'testing'! lastIsReturn ^body lastIsReturn! ! !RBMethodNode methodsFor: 'testing'! references: aVariableName ^body references: aVariableName! ! !RBMethodNode methodsFor: 'testing'! uses: aNode ^body == aNode and: [aNode lastIsReturn]! ! !RBMethodNode methodsFor: 'visitor' stamp: 'CamilloBruni 2/3/2012 15:53'! accept: aProgramNodeVisitor ^aProgramNodeVisitor visitMethodNode: self! ! !RBMethodNode methodsFor: 'visitor'! acceptVisitor: aProgramNodeVisitor ^aProgramNodeVisitor acceptMethodNode: self! ! !RBMethodNode methodsFor: 'private'! buildSelector | selectorStream | selectorStream := WriteStream on: (String new: 50). selectorParts do: [:each | selectorStream nextPutAll: each value]. ^selectorStream contents asSymbol! ! !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: 'private'! selectorParts ^selectorParts! ! !RBMethodNode methodsFor: 'private'! selectorParts: tokenCollection selectorParts := tokenCollection! ! !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 class instanceVariableNames: ''! !RBMethodNode class methodsFor: 'instance creation'! selector: aSymbol arguments: variableNodes body: aSequenceNode ^(self new) arguments: variableNodes; selector: aSymbol; body: aSequenceNode; yourself! ! !RBMethodNode class methodsFor: 'instance creation'! selector: aSymbol body: aSequenceNode ^self selector: aSymbol arguments: #() body: aSequenceNode! ! !RBMethodNode class methodsFor: 'instance creation'! selectorParts: tokenCollection arguments: variableNodes ^(self new) selectorParts: tokenCollection arguments: variableNodes; yourself! ! RBSpellingRule subclass: #RBMethodProtocolsSpellingRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Spelling'! !RBMethodProtocolsSpellingRule commentStamp: '' prior: 0! See #name for the area where I check spelling.! !RBMethodProtocolsSpellingRule methodsFor: 'accessing' stamp: 'lr 2/24/2009 07:57'! name ^ 'Method protocols'! ! !RBMethodProtocolsSpellingRule methodsFor: 'accessing' stamp: 'lr 9/8/2011 20:15'! resultClass ^ RBMultiEnvironment! ! !RBMethodProtocolsSpellingRule methodsFor: 'running' stamp: 'lr 1/21/2010 21:53'! checkClass: aContext | organizer | organizer := aContext selectedClass organization. organizer categories do: [ :protocol | (self checkSelector: protocol) do: [ :each | (organizer listAtCategoryNamed: protocol) do: [ :selector | result addSearchString: each; addClass: aContext selectedClass selector: selector into: protocol ] ] ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBMethodProtocolsSpellingRule class instanceVariableNames: ''! !RBMethodProtocolsSpellingRule 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" ^'MethodProtocolsSpellingRule'! ! RBRefactoring subclass: #RBMethodRefactoring instanceVariableNames: 'class' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBMethodRefactoring methodsFor: 'private'! buildSelectorString: aSelector aSelector numArgs = 0 ifTrue: [^aSelector]. ^self buildSelectorString: aSelector withPermuteMap: (1 to: aSelector numArgs)! ! !RBMethodRefactoring methodsFor: 'private'! 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! ! RBNodedScope subclass: #RBMethodScope instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AST-Semantic-Scope'! !RBMethodScope methodsFor: 'testing' stamp: 'lr 5/11/2010 19:12'! isMethodScope ^ true! ! RBSpellingRule subclass: #RBMethodSelectorsSpellingRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Spelling'! !RBMethodSelectorsSpellingRule commentStamp: '' prior: 0! See #name for the area where I check spelling.! !RBMethodSelectorsSpellingRule methodsFor: 'accessing' stamp: 'lr 2/24/2009 07:57'! name ^ 'Method selectors'! ! !RBMethodSelectorsSpellingRule methodsFor: 'running' stamp: 'lr 1/21/2010 21:32'! checkMethod: aContext (self checkSelector: aContext selector) do: [ :each | result addSearchString: each; addClass: aContext selectedClass selector: aContext selector ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBMethodSelectorsSpellingRule class instanceVariableNames: ''! !RBMethodSelectorsSpellingRule 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" ^'MethodSelectorsSpellingRule'! ! RBBlockLintRule subclass: #RBMethodSourceContainsLinefeedsRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBMethodSourceContainsLinefeedsRule commentStamp: '' prior: 0! See my #rationale.! !RBMethodSourceContainsLinefeedsRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 14:11'! category ^ 'Bugs'! ! !RBMethodSourceContainsLinefeedsRule methodsFor: 'accessing' stamp: 'lr 3/17/2010 17:54'! group ^ 'Pharo bugs'! ! !RBMethodSourceContainsLinefeedsRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Method source contains linefeeds'! ! !RBMethodSourceContainsLinefeedsRule methodsFor: 'accessing' stamp: 'SeanDeNigris 1/31/2013 09:21'! rationale ^ 'Pharo code should not contain linefeed characters.'! ! !RBMethodSourceContainsLinefeedsRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:11'! severity ^ #error! ! !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 class instanceVariableNames: ''! !RBMethodSourceContainsLinefeedsRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBTransformationRule subclass: #RBMinMaxRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-TransformationRules'! !RBMinMaxRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:51'! category ^ 'Coding Idiom Violation'! ! !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: '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: '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 class instanceVariableNames: ''! !RBMinMaxRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBBlockLintRule subclass: #RBMissingSubclassResponsibilityRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBMissingSubclassResponsibilityRule commentStamp: '' prior: 0! See my #rationale.! !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: '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: '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: 'lr 9/8/2011 20:15'! resultClass ^ RBMultiEnvironment! ! !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 instanceVariableNames: ''! !RBMissingSubclassResponsibilityRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBBlockLintRule subclass: #RBMissingSuperSendsRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBMissingSuperSendsRule commentStamp: '' prior: 0! See my #rationale.! !RBMissingSuperSendsRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 10:29'! category ^ 'Potential Bugs'! ! !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: '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: 'running' stamp: 'lr 2/23/2009 23:52'! checkMethod: aContext | definer superMethod | (aContext selectedClass isMeta not and: [ self superMessages includes: aContext selector ]) ifTrue: [ definer := aContext selectedClass superclass ifNotNilDo: [ :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 methodsFor: 'private' stamp: 'lr 2/24/2009 00:17'! superMessages ^#(#release #postCopy #postBuildWith: #preBuildWith: #postOpenWith: #noticeOfWindowClose: #initialize)! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBMissingSuperSendsRule class instanceVariableNames: ''! !RBMissingSuperSendsRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBParseTreeLintRule subclass: #RBMissingTranslationsInMenusRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !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 methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Literal strings shown to users in menus should be translated.'! ! !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 class instanceVariableNames: ''! !RBMissingTranslationsInMenusRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBParseTreeLintRule subclass: #RBMissingYourselfRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBMissingYourselfRule commentStamp: '' prior: 0! 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: '*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 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: '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: '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 class instanceVariableNames: ''! !RBMissingYourselfRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBParseTreeLintRule subclass: #RBModifiesCollectionRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBModifiesCollectionRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:25'! category ^ 'Potential Bugs'! ! !RBModifiesCollectionRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Possible bugs'! ! !RBModifiesCollectionRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Modifies collection while iterating over it'! ! !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: '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: '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 class instanceVariableNames: ''! !RBModifiesCollectionRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBMethodRefactoring subclass: #RBMoveMethodRefactoring instanceVariableNames: 'selector variable moveToClasses parseTree hasOnlySelfReturns selfVariableName' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBMoveMethodRefactoring methodsFor: 'initialize-release'! 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: 'preconditions'! checkForPrimitiveMethod parseTree isPrimitive ifTrue: [self refactoringError: 'Cannot move primitive methods']! ! !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: 'preconditions'! 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: '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: 'preconditions'! 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'! 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: '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'! isMovingToArgument ^(parseTree arguments collect: [:each | each name]) includes: variable! ! !RBMoveMethodRefactoring methodsFor: 'testing'! isMovingToInstVar ^self isMovingToArgument not and: [(class whoDefinesInstanceVariable: variable) notNil]! ! !RBMoveMethodRefactoring methodsFor: 'testing'! needsToReplaceSelfReferences ^self hasSelfReferences or: [self abstractVariablesRefactoring hasVariablesToAbstract]! ! !RBMoveMethodRefactoring methodsFor: 'transforming'! abstractVariables self performComponentRefactoring: self abstractVariablesRefactoring. parseTree := self abstractVariablesRefactoring parseTree! ! !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: 'transforming'! addSelfReturn self hasOnlySelfReturns ifTrue: [^self]. parseTree addSelfReturn! ! !RBMoveMethodRefactoring methodsFor: 'transforming'! compileDelagatorMethod | 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: 'lr 11/1/2009 23:05'! compileNewMethods moveToClasses do: [:each | each compile: parseTree newSource withAttributesFrom: (class methodFor: selector)]! ! !RBMoveMethodRefactoring methodsFor: 'transforming'! 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: '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: '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 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: '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: 'transforming'! transform self abstractVariables; addSelfReturn; replaceSelfReferences; replaceVariableReferences; compileNewMethods; compileDelagatorMethod! ! !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: '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: '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: '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: '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: '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 class instanceVariableNames: ''! !RBMoveMethodRefactoring class methodsFor: 'instance creation'! model: aRBSmalltalk selector: aSymbol class: aClass variable: aVariableName ^(self new) model: aRBSmalltalk; selector: aSymbol class: aClass variable: aVariableName; yourself! ! !RBMoveMethodRefactoring class methodsFor: 'instance creation'! selector: aSymbol class: aClass variable: aVariableName ^(self new) selector: aSymbol class: aClass variable: aVariableName; yourself! ! RBRefactoringTest subclass: #RBMoveMethodTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !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: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')! ! !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: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: '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)! ! RBMethodRefactoring subclass: #RBMoveVariableDefinitionRefactoring instanceVariableNames: 'selector interval name parseTree blockNodes definingNode' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBMoveVariableDefinitionRefactoring methodsFor: 'initialize-release'! class: aClass selector: aSelector interval: anInterval interval := anInterval. class := self classObjectFor: aClass. selector := aSelector! ! !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'! 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'! 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: '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: '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 methodsFor: 'transforming'! transform definingNode removeTemporaryNamed: name. blockNodes do: [:each | each body addTemporaryNamed: name]. class compileTree: parseTree! ! !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 class instanceVariableNames: ''! !RBMoveVariableDefinitionRefactoring class methodsFor: 'instance creation'! bindTight: anInterval in: aClass selector: aSelector ^self new class: aClass selector: aSelector interval: anInterval! ! !RBMoveVariableDefinitionRefactoring class methodsFor: 'instance creation'! model: aRBSmalltalk bindTight: anInterval in: aClass selector: aSelector ^(self new) model: aRBSmalltalk; class: aClass selector: aSelector interval: anInterval; yourself! ! RBRefactoringTest subclass: #RBMoveVariableDefinitionTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !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'! 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')! ! !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'! 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)! ! RBBrowserEnvironmentWrapper subclass: #RBMultiEnvironment instanceVariableNames: 'environmentDictionaries' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics'! !RBMultiEnvironment methodsFor: '*Manifest-CriticBrowser' stamp: 'SimonAllier 3/30/2012 11:43'! isMultiEnvironment ^ true! ! !RBMultiEnvironment methodsFor: '*Manifest-CriticBrowser' stamp: 'StephaneDucasse 11/21/2012 18:25'! removeClass: aClass environmentDictionaries keys do: [ :key | (environmentDictionaries at: key) removeClass: aClass ]! ! !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: 'accessing'! environments ^environmentDictionaries keys! ! !RBMultiEnvironment methodsFor: 'accessing'! problemCount ^environmentDictionaries size! ! !RBMultiEnvironment methodsFor: 'accessing' stamp: 'lr 9/8/2011 20:32'! selectEnvironment: aValue environment := environmentDictionaries at: aValue ifAbsent: [RBSelectorEnvironment new]! ! !RBMultiEnvironment methodsFor: 'adding' stamp: 'lr 9/8/2011 20:32'! addClass: aClass into: aValue (environmentDictionaries at: aValue ifAbsentPut: [RBSelectorEnvironment new]) addClass: 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: 'initialize-release' stamp: 'lr 9/8/2011 20:32'! initialize super initialize. environmentDictionaries := Dictionary new. environment := 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: '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:52'! includesClass: aClass ^ (super includesClass: aClass) and: [ environmentDictionaries anySatisfy: [ :env | env includesClass: aClass ] ]! ! !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: '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: 'testing'! isEmpty ^environmentDictionaries isEmpty! ! RBLiteralToken subclass: #RBMultiKeywordLiteralToken instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Tokens'! !RBMultiKeywordLiteralToken methodsFor: 'testing'! isMultiKeyword ^true! ! Object subclass: #RBNamespace instanceVariableNames: 'changes environment newClasses removedClasses changedClasses rootClasses implementorsCache sendersCache' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Model'! !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 13:40'! allImplementorsOf: aSelector ^ implementorsCache at: aSelector ifAbsentPut: [ self privateImplementorsOf: aSelector ]! ! !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: 'accessing' stamp: 'lr 4/7/2010 13:44'! allReferencesTo: aSymbol do: aBlock (self allReferencesTo: aSymbol) do: aBlock! ! !RBNamespace methodsFor: 'accessing'! allReferencesToClass: aRBClass do: aBlock self allClassesDo: [:each | (each whichSelectorsReferToClass: aRBClass) do: [:sel | aBlock value: (each methodFor: sel)]]! ! !RBNamespace methodsFor: 'accessing'! changes ^changes! ! !RBNamespace methodsFor: 'accessing' stamp: 'lr 1/20/2010 18:08'! description ^ self changes name! ! !RBNamespace methodsFor: 'accessing' stamp: 'lr 1/20/2010 18:08'! description: aString self changes name: aString! ! !RBNamespace methodsFor: 'accessing'! environment ^environment! ! !RBNamespace methodsFor: 'accessing'! environment: aBrowserEnvironment environment := aBrowserEnvironment! ! !RBNamespace methodsFor: 'accessing'! name ^changes name! ! !RBNamespace methodsFor: 'accessing'! name: aString ^changes name: aString! ! !RBNamespace methodsFor: 'accessing' stamp: 'lr 4/7/2010 13:38'! rootClasses ^ rootClasses ifNil: [ rootClasses := self privateRootClasses]! ! !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: '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-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-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: 'accessing-classes'! whichCategoryIncludes: aSymbol ^self environment whichCategoryIncludes: aSymbol! ! !RBNamespace methodsFor: 'changes' stamp: 'lr 7/1/2008 11:06'! comment: aString in: aClass ^ changes comment: aString in: aClass! ! !RBNamespace methodsFor: 'changes' stamp: 'lr 10/26/2009 22:09'! 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 poolDictionaryNames. newClass category: change category. ^ change! ! !RBNamespace methodsFor: 'changes'! removeClass: aRBClass self removeClassNamed: aRBClass name! ! !RBNamespace methodsFor: 'changes'! 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: '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'! reparentClasses: aRBClassCollection to: newClass aRBClassCollection do: [:aClass | self defineClass: (self replaceClassNameIn: aClass definitionString to: newClass name)]! ! !RBNamespace methodsFor: 'initialize-release' 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: 'testing'! hasRemoved: aSymbol ^removedClasses includes: aSymbol! ! !RBNamespace methodsFor: 'testing'! includesClassNamed: aSymbol ^(self classNamed: aSymbol) notNil! ! !RBNamespace methodsFor: 'testing'! includesGlobal: aSymbol (self hasRemoved: aSymbol) ifTrue: [^false]. (self includesClassNamed: aSymbol) ifTrue: [^true]. environment at: aSymbol ifAbsent: [^false]. ^true! ! !RBNamespace methodsFor: 'private' stamp: 'lr 10/31/2009 17:37'! classNameFor: aBehavior ^ aBehavior theNonMetaClass name! ! !RBNamespace methodsFor: 'private'! hasCreatedClassFor: aBehavior | className | className := self classNameFor: aBehavior. ^(newClasses includesKey: className) or: [changedClasses includesKey: className]! ! !RBNamespace methodsFor: 'private' stamp: 'lr 4/7/2010 13:45'! privateImplementorsOf: aSelector | classes | classes := Set new. self allClassesDo: [ :class | (class directlyDefinesMethod: aSelector) ifTrue: [ classes add: class ] ]. ^ classes! ! !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' 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: 'lr 10/26/2009 22:09'! addChangeToClass: aRBClass ^ changedClasses at: aRBClass name put: (Array with: aRBClass theNonMetaClass with: aRBClass theMetaClass)! ! !RBNamespace methodsFor: 'private-changes'! addClassVariable: aString to: aRBClass ^changes addClassVariable: aString to: aRBClass! ! !RBNamespace methodsFor: 'private-changes'! addInstanceVariable: aString to: aRBClass ^changes addInstanceVariable: aString to: aRBClass! ! !RBNamespace methodsFor: 'private-changes'! addPool: aString to: aRBClass ^changes addPool: aString to: aRBClass! ! !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'! compile: aString in: aRBClass classified: aSymbol | change | change := changes compile: aString in: aRBClass classified: aSymbol. self flushCaches. ^change! ! !RBNamespace methodsFor: 'private-changes'! flushCaches implementorsCache := IdentityDictionary new. sendersCache := IdentityDictionary new! ! !RBNamespace methodsFor: 'private-changes'! performChange: aCompositeRefactoryChange around: aBlock | oldChanges | changes addChange: aCompositeRefactoryChange. oldChanges := changes. changes := aCompositeRefactoryChange. aBlock ensure: [changes := oldChanges]. ^aCompositeRefactoryChange! ! !RBNamespace methodsFor: 'private-changes'! removeClassVariable: aString from: aRBClass ^changes removeClassVariable: aString from: aRBClass! ! !RBNamespace methodsFor: 'private-changes'! removeInstanceVariable: aString from: aRBClass ^changes removeInstanceVariable: aString from: aRBClass! ! !RBNamespace methodsFor: 'private-changes'! removeMethod: aSelector from: aRBClass self flushCaches. ^changes removeMethod: aSelector from: aRBClass! ! !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: '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'! replaceClassNameIn: definitionString to: aSymbol | parseTree | parseTree := RBParser parseExpression: definitionString. parseTree receiver: (RBVariableNode named: aSymbol). ^parseTree formattedCode! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBNamespace class instanceVariableNames: ''! !RBNamespace class methodsFor: 'instance creation'! onEnvironment: aBrowserEnvironment ^(self new) environment: aBrowserEnvironment; yourself! ! RBRefactoringBrowserTest subclass: #RBNamespaceTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !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 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'! 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: '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'! 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))! ! !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: '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'! 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: '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: '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 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'! 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'! 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: '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! ! RBAbstractCondition subclass: #RBNegationCondition instanceVariableNames: 'condition' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Conditions'! !RBNegationCondition methodsFor: 'checking'! check ^condition check not! ! !RBNegationCondition methodsFor: 'initialize-release'! condition: aCondition condition := aCondition. self errorMacro: condition errorMacro! ! !RBNegationCondition methodsFor: 'printing'! printOn: aStream aStream nextPutAll: 'NOT '; print: condition! ! !RBNegationCondition methodsFor: 'private'! errorBlockFor: aBoolean ^condition errorBlockFor: aBoolean not! ! !RBNegationCondition methodsFor: 'private'! errorStringFor: aBoolean ^condition errorStringFor: aBoolean not! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBNegationCondition class instanceVariableNames: ''! !RBNegationCondition class methodsFor: 'instance creation'! on: aCondition ^self new condition: aCondition! ! RBBlockLintRule subclass: #RBNoClassCommentRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBNoClassCommentRule commentStamp: '' prior: 0! See my #rationale.! !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: '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: '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: 'lr 9/8/2011 20:32'! resultClass ^ RBClassEnvironment! ! !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 instanceVariableNames: ''! !RBNoClassCommentRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBOwnedScope subclass: #RBNodedScope instanceVariableNames: 'node' classVariableNames: '' poolDictionaries: '' category: 'AST-Semantic-Scope'! !RBNodedScope methodsFor: 'accessing' stamp: 'lr 4/27/2010 13:29'! node "Answer the program node that defines this scope." ^ node! ! !RBNodedScope methodsFor: 'initialization' stamp: 'lr 4/27/2010 15:19'! setNode: aProgramNode node := aProgramNode. node propertyAt: #lexicalScope put: self! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBNodedScope class instanceVariableNames: ''! !RBNodedScope class methodsFor: 'instance creation' stamp: 'lr 6/7/2010 14:58'! owner: aLexicalScope node: aProgramNode ^ (self owner: aLexicalScope) setNode: aProgramNode! ! RBTransformationRule subclass: #RBNotEliminationRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-TransformationRules'! !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 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: '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 class instanceVariableNames: ''! !RBNotEliminationRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBBrowserEnvironmentWrapper subclass: #RBNotEnvironment instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Environment'! !RBNotEnvironment methodsFor: 'environments'! not ^environment! ! !RBNotEnvironment methodsFor: 'printing'! storeOn: aStream environment storeOn: aStream. aStream nextPutAll: ' not'! ! !RBNotEnvironment methodsFor: 'testing'! includesCategory: aCategory ^(self classNamesFor: aCategory) isEmpty not! ! !RBNotEnvironment methodsFor: 'testing'! includesClass: aClass (environment includesClass: aClass) ifFalse: [^true]. aClass selectorsAndMethodsDo: [:each :meth | (environment includesSelector: each in: aClass) ifFalse: [^true]]. ^false! ! !RBNotEnvironment methodsFor: 'testing'! includesProtocol: aProtocol in: aClass ^(self selectorsFor: aProtocol in: aClass) isEmpty not! ! !RBNotEnvironment methodsFor: 'testing'! includesSelector: aSelector in: aClass ^(environment includesSelector: aSelector in: aClass) not! ! RBLiteralToken subclass: #RBNumberLiteralToken instanceVariableNames: 'source' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Tokens'! !RBNumberLiteralToken methodsFor: 'accessing'! source ^source! ! !RBNumberLiteralToken methodsFor: 'initialize-release'! source: aString source := aString! ! !RBNumberLiteralToken methodsFor: 'printing'! storeOn: aStream aStream nextPutAll: source! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBNumberLiteralToken class instanceVariableNames: ''! !RBNumberLiteralToken class methodsFor: 'instance creation'! value: aNumber start: anInteger stop: stopInteger source: sourceString ^(self value: aNumber start: anInteger stop: stopInteger) source: sourceString; yourself! ! RBParseTreeLintRule subclass: #RBOnlyReadOrWrittenTemporaryRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBOnlyReadOrWrittenTemporaryRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:26'! category ^ 'Optimization'! ! !RBOnlyReadOrWrittenTemporaryRule methodsFor: 'accessing' stamp: 'lr 6/4/2010 12:10'! group ^ 'Unnecessary code'! ! !RBOnlyReadOrWrittenTemporaryRule methodsFor: 'accessing' stamp: 'lr 6/4/2010 12:10'! name ^ 'Temporary variables not read AND written'! ! !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'! severity ^ #information! ! !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 class instanceVariableNames: ''! !RBOnlyReadOrWrittenTemporaryRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBBlockLintRule subclass: #RBOnlyReadOrWrittenVariableRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBOnlyReadOrWrittenVariableRule commentStamp: '' prior: 0! See my #rationale.! !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: 'lr 2/23/2009 23:17'! group ^ 'Unnecessary code'! ! !RBOnlyReadOrWrittenVariableRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Instance variables not read AND written'! ! !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 9/8/2011 20:32'! resultClass ^ RBVariableEnvironment! ! !RBOnlyReadOrWrittenVariableRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:10'! severity ^ #information! ! !RBOnlyReadOrWrittenVariableRule methodsFor: 'running' stamp: 'lr 4/29/2010 19:35'! 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 whichSelectorsReallyRead: each) isEmpty not ]. isWritten ifFalse: [ isWritten := (class whichSelectorsAssign: each) isEmpty not ]. isRead and: [ isWritten ] ] ifNone: [ result addClass: aContext selectedClass instanceVariable: each ] ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBOnlyReadOrWrittenVariableRule class instanceVariableNames: ''! !RBOnlyReadOrWrittenVariableRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBBrowserEnvironmentWrapper subclass: #RBOrEnvironment instanceVariableNames: 'orEnvironment' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Environment'! !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: '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: '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: 'initialization' stamp: 'lr 11/25/2009 00:49'! orEnvironment: aBrowserEnvironment orEnvironment := aBrowserEnvironment! ! !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: 'testing' stamp: 'lr 11/25/2009 08:26'! includesCategory: aCategory ^ (environment includesCategory: aCategory) or: [ orEnvironment includesCategory: aCategory ]! ! !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: '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: '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 instanceVariableNames: ''! !RBOrEnvironment class methodsFor: 'as yet unclassified' stamp: 'lr 11/25/2009 00:51'! onEnvironment: anEnvironment or: anotherEnvironment ^ (self onEnvironment: anEnvironment) orEnvironment: anotherEnvironment; yourself! ! RBBlockLintRule subclass: #RBOverridesSpecialMessageRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBOverridesSpecialMessageRule commentStamp: '' prior: 0! See my #rationale.! !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: 'lr 2/23/2009 23:17'! group ^ 'Bugs'! ! !RBOverridesSpecialMessageRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Overrides a "special" message'! ! !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 5/15/2010 15:04'! severity ^ #error! ! !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 methodsFor: 'private' stamp: 'lr 2/24/2009 20:12'! classShouldNotOverride ^ #( #== #~~ #class #basicAt: #basicAt:put: #basicSize #identityHash )! ! !RBOverridesSpecialMessageRule methodsFor: 'private' stamp: 'lr 2/24/2009 20:13'! metaclassShouldNotOverride ^ #( #basicNew #basicNew #class #comment #name )! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBOverridesSpecialMessageRule class instanceVariableNames: ''! !RBOverridesSpecialMessageRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBLexicalScope subclass: #RBOwnedScope instanceVariableNames: 'owner' classVariableNames: '' poolDictionaries: '' category: 'AST-Semantic-Scope'! !RBOwnedScope methodsFor: 'accessing' stamp: 'lr 6/7/2010 14:57'! owner "Answer the owning scope." ^ owner! ! !RBOwnedScope methodsFor: 'initialization' stamp: 'lr 6/7/2010 14:57'! setOwner: aLexicalScope owner := aLexicalScope! ! !RBOwnedScope methodsFor: 'querying' stamp: 'lr 6/7/2010 14:57'! lookup: aString ifAbsent: aBlock ^ (self bindingOf: aString) ifNil: [ owner lookup: aString ifAbsent: aBlock ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBOwnedScope class instanceVariableNames: ''! !RBOwnedScope class methodsFor: 'instance creation' stamp: 'lr 6/7/2010 14:58'! owner: aLexicalScope ^ self new setOwner: aLexicalScope! ! RBBrowserEnvironmentWrapper subclass: #RBPackageEnvironment instanceVariableNames: 'packages' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Environment'! !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: 'accessing' stamp: 'lr 11/25/2009 08:48'! classesAndSelectorsDo: aBlock packages do: [ :package | package methods do: [ :method | (environment includesSelector: method methodSymbol in: method actualClass) ifTrue: [ aBlock value: method actualClass value: method methodSymbol ] ] ]! ! !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 12/3/2009 13:30'! numberSelectors ^ packages inject: 0 into: [ :result :package | result + package methods size ]! ! !RBPackageEnvironment methodsFor: 'accessing' stamp: 'lr 11/25/2009 08:49'! packageNames ^ packages collect: [ :each | each packageName ]! ! !RBPackageEnvironment methodsFor: 'accessing' stamp: 'lr 11/25/2009 08:46'! packages ^ packages! ! !RBPackageEnvironment methodsFor: 'copying' stamp: 'lr 4/12/2010 15:26'! postCopy super postCopy. packages := packages copy! ! !RBPackageEnvironment methodsFor: 'initialize-release' stamp: 'lr 4/12/2010 15:25'! initialize super initialize. packages := Set new! ! !RBPackageEnvironment methodsFor: 'initialize-release' stamp: 'lr 12/20/2009 09:29'! packages: aCollection packages addAll: aCollection! ! !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: 'lr 5/15/2010 09:39'! definesClass: aClass ^ (super definesClass: aClass) and: [ self packages anySatisfy: [ :package | package includesClass: aClass ] ]! ! !RBPackageEnvironment methodsFor: 'testing' stamp: 'lr 11/25/2009 08:51'! includesCategory: aCategory ^ (super includesCategory: aCategory) and: [ self packages anySatisfy: [ :package | package includesSystemCategory: aCategory ] ]! ! !RBPackageEnvironment methodsFor: 'testing' stamp: 'lr 11/25/2009 09:06'! includesClass: aClass ^ (super includesClass: aClass) and: [ self packages anySatisfy: [ :package | (package includesClass: aClass) or: [ (package extensionCategoriesForClass: aClass) notEmpty ] ] ]! ! !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: 'testing' stamp: 'lr 11/25/2009 10:33'! includesSelector: aSelector in: aClass ^ (environment includesSelector: aSelector in: aClass) and: [ self packages anySatisfy: [ :package | package includesMethod: aSelector ofClass: aClass ] ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBPackageEnvironment class instanceVariableNames: ''! !RBPackageEnvironment class methodsFor: 'instance creation' stamp: 'lr 11/25/2009 08:54'! onEnvironment: anEnvironment packageNames: aCollection ^ self onEnvironment: anEnvironment packages: (aCollection collect: [ :each | PackageInfo named: each ])! ! !RBPackageEnvironment class methodsFor: 'instance creation' stamp: 'lr 11/25/2009 08:54'! onEnvironment: anEnvironment packages: aCollection ^ (self onEnvironment: anEnvironment) packages: aCollection; yourself! ! RBProgramNode subclass: #RBParseErrorNode instanceVariableNames: 'token errorMessage' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Nodes'! !RBParseErrorNode commentStamp: '' prior: 0! 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'! errorMessage ^ errorMessage! ! !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: 'CamilloBruni 10/31/2012 18:52'! token: anObject token := anObject! ! !RBParseErrorNode methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 11/1/2012 13:51'! start ^ token start! ! !RBParseErrorNode methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 11/1/2012 13:51'! stop ^ token stop! ! !RBParseErrorNode methodsFor: 'visitor' stamp: 'CamilloBruni 10/31/2012 19:01'! acceptVisitor: aProgramNodeVisitor ^ aProgramNodeVisitor acceptParseErrorNode: self.! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBParseErrorNode class instanceVariableNames: ''! !RBParseErrorNode class methodsFor: 'instance creation' stamp: 'CamilloBruni 10/31/2012 18:59'! errorMessage: aString token: anRBToken ^ self new errorMessage: aString; token: anRBToken; yourself! ! RBSelectorEnvironment subclass: #RBParseTreeEnvironment instanceVariableNames: 'matcher' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics'! !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 ]! ! !RBParseTreeEnvironment methodsFor: 'initialize-release'! matcher: aParseTreeSearcher matcher := aParseTreeSearcher! ! RBBasicLintRule subclass: #RBParseTreeLintRule instanceVariableNames: 'matcher' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics'! !RBParseTreeLintRule commentStamp: '' prior: 0! A RBParseTreeLintRule is a rule that is expressed using a parse tree matcher on a method AST.! !RBParseTreeLintRule methodsFor: 'accessing' stamp: 'lr 2/24/2009 00:01'! matcher ^ matcher! ! !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: '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 methodsFor: 'running' stamp: 'lr 2/24/2009 08:21'! resetResult super resetResult. self result matcher: self matcher! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBParseTreeLintRule class instanceVariableNames: ''! !RBParseTreeLintRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! !RBParseTreeLintRule class methodsFor: 'testing' stamp: 'lr 2/24/2009 17:09'! isVisible ^ self name ~= #RBParseTreeLintRule! ! RBParseTreeSearcher subclass: #RBParseTreeRewriter instanceVariableNames: 'tree' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Matching'! !RBParseTreeRewriter commentStamp: '' prior: 0! 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: 'accessing'! executeTree: aParseTree | oldContext | oldContext := context. context := RBSmallDictionary new. answer := false. tree := self visitNode: aParseTree. context := oldContext. ^answer! ! !RBParseTreeRewriter methodsFor: 'accessing'! tree ^tree! ! !RBParseTreeRewriter methodsFor: 'replacing'! replace: searchString with: replaceString self addRule: (RBStringReplaceRule searchFor: searchString replaceWith: replaceString)! ! !RBParseTreeRewriter methodsFor: 'replacing'! replace: searchString with: replaceString when: aBlock self addRule: (RBStringReplaceRule searchFor: searchString replaceWith: replaceString when: aBlock)! ! !RBParseTreeRewriter methodsFor: 'replacing'! replace: searchString withValueFrom: replaceBlock self addRule: (RBBlockReplaceRule searchFor: searchString replaceWith: replaceBlock)! ! !RBParseTreeRewriter methodsFor: 'replacing'! replace: searchString withValueFrom: replaceBlock when: conditionBlock self addRule: (RBBlockReplaceRule searchFor: searchString replaceWith: replaceBlock when: conditionBlock)! ! !RBParseTreeRewriter methodsFor: 'replacing'! replaceArgument: searchString with: replaceString self addArgumentRule: (RBStringReplaceRule searchFor: searchString replaceWith: replaceString)! ! !RBParseTreeRewriter methodsFor: 'replacing'! replaceArgument: searchString with: replaceString when: aBlock self addArgumentRule: (RBStringReplaceRule searchFor: searchString replaceWith: replaceString when: aBlock)! ! !RBParseTreeRewriter methodsFor: 'replacing'! replaceArgument: searchString withValueFrom: replaceBlock self addArgumentRule: (RBBlockReplaceRule searchFor: searchString replaceWith: replaceBlock)! ! !RBParseTreeRewriter methodsFor: 'replacing'! replaceArgument: searchString withValueFrom: replaceBlock when: conditionBlock self addArgumentRule: (RBBlockReplaceRule searchFor: searchString replaceWith: replaceBlock when: conditionBlock)! ! !RBParseTreeRewriter methodsFor: 'replacing'! replaceMethod: searchString with: replaceString self addRule: (RBStringReplaceRule searchForMethod: searchString replaceWith: replaceString)! ! !RBParseTreeRewriter methodsFor: 'replacing'! replaceMethod: searchString with: replaceString when: aBlock self addRule: (RBStringReplaceRule searchForMethod: searchString replaceWith: replaceString when: aBlock)! ! !RBParseTreeRewriter methodsFor: 'replacing'! replaceMethod: searchString withValueFrom: replaceBlock self addRule: (RBBlockReplaceRule searchForMethod: searchString replaceWith: replaceBlock)! ! !RBParseTreeRewriter methodsFor: 'replacing'! replaceMethod: searchString withValueFrom: replaceBlock when: conditionBlock self addRule: (RBBlockReplaceRule searchForMethod: searchString replaceWith: replaceBlock when: conditionBlock)! ! !RBParseTreeRewriter methodsFor: 'replacing'! replaceTree: searchTree withTree: replaceTree self addRule: (RBStringReplaceRule searchForTree: searchTree replaceWith: replaceTree)! ! !RBParseTreeRewriter methodsFor: 'replacing'! replaceTree: searchTree withTree: replaceTree when: aBlock self addRule: (RBStringReplaceRule searchForTree: searchTree replaceWith: replaceTree when: aBlock)! ! !RBParseTreeRewriter methodsFor: 'visiting'! visitArguments: aNodeCollection ^aNodeCollection collect: [:each | self visitArgument: each]! ! !RBParseTreeRewriter methodsFor: 'visitor-double dispatching' stamp: 'lr 11/1/2009 20:07'! acceptArrayNode: anArrayNode anArrayNode statements: (anArrayNode statements collect: [:each | self visitNode: each])! ! !RBParseTreeRewriter methodsFor: 'visitor-double dispatching'! acceptAssignmentNode: anAssignmentNode anAssignmentNode variable: (self visitNode: anAssignmentNode variable). anAssignmentNode value: (self visitNode: anAssignmentNode value)! ! !RBParseTreeRewriter methodsFor: 'visitor-double dispatching'! acceptBlockNode: aBlockNode aBlockNode arguments: (self visitArguments: aBlockNode arguments). aBlockNode body: (self visitNode: aBlockNode body)! ! !RBParseTreeRewriter methodsFor: 'visitor-double dispatching' stamp: 'lr 5/30/2010 11:34'! acceptCascadeNode: 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'! acceptLiteralArrayNode: aRBArrayLiteralNode aRBArrayLiteralNode contents: (aRBArrayLiteralNode contents collect: [:each | self visitNode: each])! ! !RBParseTreeRewriter methodsFor: 'visitor-double dispatching'! acceptMessageNode: aMessageNode aMessageNode receiver: (self visitNode: aMessageNode receiver). aMessageNode arguments: (aMessageNode arguments collect: [:each | self visitNode: each])! ! !RBParseTreeRewriter methodsFor: 'visitor-double dispatching' stamp: 'lr 11/1/2009 20:06'! acceptMethodNode: aMethodNode aMethodNode arguments: (self visitArguments: aMethodNode arguments). aMethodNode pragmas: (aMethodNode pragmas collect: [:each | self visitNode: each]). aMethodNode body: (self visitNode: aMethodNode body)! ! !RBParseTreeRewriter methodsFor: 'visitor-double dispatching' stamp: 'lr 11/1/2009 20:07'! acceptPragmaNode: aPragmaNode aPragmaNode arguments: (aPragmaNode arguments collect: [:each | self visitNode: each])! ! !RBParseTreeRewriter methodsFor: 'visitor-double dispatching'! acceptReturnNode: aReturnNode aReturnNode value: (self visitNode: aReturnNode value)! ! !RBParseTreeRewriter methodsFor: 'visitor-double dispatching' stamp: 'CamilloBruni 8/20/2012 16:35'! acceptSequenceNode: aSequenceNode aSequenceNode temporaries: (self visitTemporaries: aSequenceNode temporaries). aSequenceNode statements: (aSequenceNode statements collect: [:each | self visitNode: each])! ! !RBParseTreeRewriter methodsFor: 'private'! foundMatch answer := true! ! !RBParseTreeRewriter methodsFor: 'private'! 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 instanceVariableNames: ''! !RBParseTreeRewriter class methodsFor: 'accessing'! replace: code with: newCode in: aParseTree ^(self replace: code with: newCode method: false) executeTree: aParseTree; tree! ! !RBParseTreeRewriter class methodsFor: 'accessing'! 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: 'accessing'! 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: 'instance creation'! removeTemporaryNamed: aName | rewriteRule | rewriteRule := self new. rewriteRule replace: '| `@temps1 ' , aName , ' `@temps2 | ``@.Statements' with: '| `@temps1 `@temps2 | ``@.Statements'. ^rewriteRule! ! !RBParseTreeRewriter class methodsFor: 'instance creation'! rename: varName to: newVarName | rewriteRule | rewriteRule := self new. rewriteRule replace: varName with: newVarName; replaceArgument: varName with: newVarName. ^rewriteRule! ! !RBParseTreeRewriter class methodsFor: 'instance creation'! 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: 'instance creation'! 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'! replaceLiteral: literal with: newLiteral | rewriteRule | rewriteRule := self new. rewriteRule replaceTree: (RBLiteralNode value: literal) withTree: (RBLiteralNode value: newLiteral). ^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! ! Object subclass: #RBParseTreeRule instanceVariableNames: 'searchTree owner' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Matching'! !RBParseTreeRule commentStamp: 'md 8/9/2005 14:55' prior: 0! 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'! sentMessages ^searchTree sentMessages! ! !RBParseTreeRule methodsFor: 'initialize-release'! methodSearchString: aString searchTree := RBParser parseRewriteMethod: aString! ! !RBParseTreeRule methodsFor: 'initialize-release'! owner: aParseTreeSearcher owner := aParseTreeSearcher! ! !RBParseTreeRule methodsFor: 'initialize-release'! searchString: aString searchTree := RBParser parseRewriteExpression: aString! ! !RBParseTreeRule methodsFor: 'matching'! canMatch: aProgramNode ^true! ! !RBParseTreeRule methodsFor: 'matching'! foundMatchFor: aProgramNode ^aProgramNode! ! !RBParseTreeRule methodsFor: 'matching'! 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: 'private'! context ^owner context! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBParseTreeRule class instanceVariableNames: ''! !RBParseTreeRule class methodsFor: 'instance creation'! methodSearch: aString ^(self new) methodSearchString: aString; yourself! ! !RBParseTreeRule class methodsFor: 'instance creation'! search: aString ^(self new) searchString: aString; yourself! ! RBProgramNodeVisitor subclass: #RBParseTreeSearcher instanceVariableNames: 'searches answer argumentSearches context messages' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Matching'! !RBParseTreeSearcher commentStamp: '' prior: 0! 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: 'accessing'! addArgumentRule: aParseTreeRule argumentSearches add: aParseTreeRule. aParseTreeRule owner: self! ! !RBParseTreeSearcher methodsFor: 'accessing'! addArgumentRules: ruleCollection ruleCollection do: [:each | self addArgumentRule: each]! ! !RBParseTreeSearcher methodsFor: 'accessing'! addRule: aParseTreeRule searches add: aParseTreeRule. aParseTreeRule owner: self! ! !RBParseTreeSearcher methodsFor: 'accessing'! addRules: ruleCollection ruleCollection do: [:each | self addRule: each]! ! !RBParseTreeSearcher methodsFor: 'accessing'! answer ^answer! ! !RBParseTreeSearcher methodsFor: 'accessing'! context ^context! ! !RBParseTreeSearcher methodsFor: 'accessing'! executeMethod: aParseTree initialAnswer: anObject answer := anObject. searches detect: [:each | (each performOn: aParseTree) notNil] ifNone: []. ^answer! ! !RBParseTreeSearcher methodsFor: 'accessing'! executeTree: aParseTree "Save our current context, in case someone is performing another search inside a match." | oldContext | oldContext := context. context := RBSmallDictionary new. self visitNode: aParseTree. context := oldContext. ^answer! ! !RBParseTreeSearcher methodsFor: 'accessing'! executeTree: aParseTree initialAnswer: aValue answer := aValue. ^self executeTree: aParseTree! ! !RBParseTreeSearcher methodsFor: 'accessing'! 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: 'initialize-release'! answer: anObject answer := anObject! ! !RBParseTreeSearcher methodsFor: 'initialize-release'! initialize super initialize. context := RBSmallDictionary new. searches := OrderedCollection new. argumentSearches := OrderedCollection new: 0. answer := nil! ! !RBParseTreeSearcher methodsFor: 'searching'! matches: aString do: aBlock self addRule: (RBSearchRule searchFor: aString thenDo: aBlock)! ! !RBParseTreeSearcher methodsFor: 'searching'! matchesAnyArgumentOf: stringCollection do: aBlock stringCollection do: [:each | self matchesArgument: each do: aBlock]! ! !RBParseTreeSearcher methodsFor: 'searching'! matchesAnyMethodOf: aStringCollection do: aBlock aStringCollection do: [:each | self matchesMethod: each do: aBlock]! ! !RBParseTreeSearcher methodsFor: 'searching'! matchesAnyOf: aStringCollection do: aBlock aStringCollection do: [:each | self matches: each do: aBlock]! ! !RBParseTreeSearcher methodsFor: 'searching'! matchesAnyTreeOf: treeCollection do: aBlock treeCollection do: [:each | self matchesTree: each do: aBlock]! ! !RBParseTreeSearcher methodsFor: 'searching'! matchesArgument: aString do: aBlock self addArgumentRule: (RBSearchRule searchFor: aString thenDo: aBlock)! ! !RBParseTreeSearcher methodsFor: 'searching'! matchesArgumentTree: aBRProgramNode do: aBlock self addArgumentRule: (RBSearchRule searchForTree: aBRProgramNode thenDo: aBlock)! ! !RBParseTreeSearcher methodsFor: 'searching'! matchesMethod: aString do: aBlock self addRule: (RBSearchRule searchForMethod: aString thenDo: aBlock)! ! !RBParseTreeSearcher methodsFor: 'searching'! matchesTree: aBRProgramNode do: aBlock self addRule: (RBSearchRule searchForTree: aBRProgramNode thenDo: aBlock)! ! !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: 'testing'! hasRules ^searches notEmpty! ! !RBParseTreeSearcher methodsFor: 'visiting'! visitArgument: aNode | value | value := self performSearches: argumentSearches on: aNode. ^value isNil ifTrue: [aNode acceptVisitor: self. aNode] ifFalse: [value]! ! !RBParseTreeSearcher methodsFor: 'visiting'! visitNode: aNode | value | value := self performSearches: searches on: aNode. ^value isNil ifTrue: [aNode acceptVisitor: self. aNode] ifFalse: [value]! ! !RBParseTreeSearcher methodsFor: 'private'! foundMatch! ! !RBParseTreeSearcher methodsFor: 'private'! lookForMoreMatchesInContext: oldContext oldContext keysAndValuesDo: [:key :value | (key isString not and: [key recurseInto]) ifTrue: [value do: [:each | self visitNode: each]]]! ! !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: 'private'! recusivelySearchInContext "We need to save the matched context since the other searches might overwrite it." | oldContext | oldContext := context. context := RBSmallDictionary new. self lookForMoreMatchesInContext: oldContext. context := oldContext! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBParseTreeSearcher class instanceVariableNames: ''! !RBParseTreeSearcher class methodsFor: 'accessing'! treeMatching: aString in: aParseTree (self new) matches: aString do: [:aNode :answer | ^aNode]; executeTree: aParseTree. ^nil! ! !RBParseTreeSearcher class methodsFor: 'accessing'! 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'! getterMethod: aVarName ^(self new) matchesMethod: '`method ^' , aVarName do: [:aNode :ans | aNode selector]; yourself! ! !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! ! !RBParseTreeSearcher class methodsFor: 'instance creation'! returnSetterMethod: aVarName ^(self new) matchesMethod: '`method: `Arg ^' , aVarName , ' := `Arg' do: [:aNode :ans | aNode selector]; yourself! ! !RBParseTreeSearcher class methodsFor: 'instance creation'! 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: 'private'! 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'! buildSelectorTree: aSelector aSelector isEmpty ifTrue: [^nil]. ^RBParser parseRewriteExpression: '``@receiver ' , (self buildSelectorString: aSelector) onError: [:err :pos | ^nil]! ! !RBParseTreeSearcher class methodsFor: 'private'! buildTree: aString method: aBoolean ^aBoolean ifTrue: [RBParser parseRewriteMethod: aString] ifFalse: [RBParser parseRewriteExpression: aString]! ! Object subclass: #RBParser instanceVariableNames: 'scanner currentToken nextToken errorBlock source comments pragmas' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Parser'! !RBParser commentStamp: '' prior: 0! 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: 'accessing'! errorBlock: aBlock errorBlock := aBlock. scanner notNil ifTrue: [scanner errorBlock: aBlock]! ! !RBParser methodsFor: 'accessing'! initializeParserWith: aString source := aString. self scanner: (self scannerClass on: (ReadStream on: aString) errorBlock: self errorBlock)! ! !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: 'accessing' stamp: 'CamilloBruni 10/31/2012 18:37'! parseMethod: aString | node | node := self parseMethod. self atEnd ifFalse: [ ^ self parserError: 'Unknown input at end']. node source: aString. ^node! ! !RBParser methodsFor: 'accessing'! scannerClass ^RBScanner! ! !RBParser methodsFor: 'error handling'! errorBlock ^errorBlock isNil ifTrue: [[:message :position | ]] ifFalse: [errorBlock]! ! !RBParser methodsFor: 'error handling'! errorPosition ^currentToken start! ! !RBParser methodsFor: 'error handling' stamp: 'CamilloBruni 10/31/2012 18:59'! parseErrorNode: aMessageString | token sourceString | sourceString := source copyFrom: self errorPosition to: source size. token := RBValueToken value: sourceString start: self errorPosition. ^ RBParseErrorNode errorMessage: aMessageString token: token! ! !RBParser methodsFor: 'error handling' stamp: 'MarcusDenker 1/25/2013 14:47'! parserError: aString "Let the errorBlock try to recover from the error." | errorNode | errorNode := self errorBlock cull: aString cull: self errorPosition cull: self. errorNode isNil ifFalse: [ ^ errorNode ]. SyntaxErrorNotification inClass: Object category: nil withCode: source doitFlag: false errorMessage: aString location: currentToken start! ! !RBParser methodsFor: 'initialize-release' stamp: 'lr 11/1/2009 19:17'! initialize comments := OrderedCollection new! ! !RBParser methodsFor: 'initialize-release' stamp: 'lr 11/1/2009 19:35'! scanner: aScanner scanner := aScanner. pragmas := nil. self initialize. self step! ! !RBParser methodsFor: 'testing'! atEnd ^currentToken class == RBToken! ! !RBParser methodsFor: 'private'! addCommentsTo: aNode aNode comments: aNode comments , comments. comments := OrderedCollection new! ! !RBParser methodsFor: 'private' stamp: 'CamilloBruni 11/13/2012 10:09'! addPragma: aPragma pragmas isNil ifTrue: [ pragmas := OrderedCollection new ]. pragmas addLast: aPragma! ! !RBParser methodsFor: 'private'! nextToken ^nextToken isNil ifTrue: [nextToken := scanner next] ifFalse: [nextToken]! ! !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'! 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: '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'! 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-classes' stamp: 'lr 11/1/2009 19:49'! arrayNodeClass ^ RBArrayNode! ! !RBParser methodsFor: 'private-classes' stamp: 'lr 11/1/2009 19:49'! assignmentNodeClass ^ RBAssignmentNode! ! !RBParser methodsFor: 'private-classes' stamp: 'lr 11/1/2009 19:49'! blockNodeClass ^ RBBlockNode! ! !RBParser methodsFor: 'private-classes' stamp: 'lr 11/1/2009 19:49'! cascadeNodeClass ^ RBCascadeNode! ! !RBParser methodsFor: 'private-classes' stamp: 'lr 11/1/2009 19:50'! literalArrayNodeClass ^ RBLiteralArrayNode! ! !RBParser methodsFor: 'private-classes' stamp: 'lr 11/1/2009 19:50'! literalNodeClass ^ RBLiteralNode! ! !RBParser methodsFor: 'private-classes' stamp: 'lr 11/1/2009 19:50'! messageNodeClass ^ RBMessageNode! ! !RBParser methodsFor: 'private-classes' stamp: 'lr 11/1/2009 19:50'! methodNodeClass ^ RBMethodNode! ! !RBParser methodsFor: 'private-classes' stamp: 'lr 11/9/2009 21:08'! pragmaNodeClass ^ RBPragmaNode! ! !RBParser methodsFor: 'private-classes' stamp: 'lr 11/1/2009 19:50'! returnNodeClass ^ RBReturnNode! ! !RBParser methodsFor: 'private-classes' stamp: 'CamilloBruni 8/23/2011 16:12'! selfNodeClass ^ RBSelfNode! ! !RBParser methodsFor: 'private-classes' stamp: 'lr 11/1/2009 19:50'! sequenceNodeClass ^ RBSequenceNode! ! !RBParser methodsFor: 'private-classes' stamp: 'CamilloBruni 8/23/2011 16:12'! superNodeClass ^ RBSuperNode! ! !RBParser methodsFor: 'private-classes' stamp: 'CamilloBruni 8/30/2011 17:03'! thisContextNodeClass ^ RBThisContextNode! ! !RBParser methodsFor: 'private-classes' stamp: 'CamilloBruni 12/15/2011 16:15'! variableNodeClass ^ RBVariableNode! ! !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-parsing'! parseArgs | args | args := OrderedCollection new. [currentToken isIdentifier] whileTrue: [args add: self parseVariableNode]. ^args! ! !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-parsing'! 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'! parseBinaryMessage | node | node := self parseUnaryMessage. [currentToken isLiteralToken ifTrue: [self patchNegativeLiteral]. currentToken isBinary] whileTrue: [node := self parseBinaryMessageWith: node]. ^node! ! !RBParser methodsFor: 'private-parsing'! parseBinaryMessageWith: aNode | binaryToken | binaryToken := currentToken. self step. ^self messageNodeClass receiver: aNode selectorParts: (Array with: binaryToken) arguments: (Array with: self parseUnaryMessage)! ! !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-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: 'CamilloBruni 11/8/2012 16:01'! 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']. node right: currentToken start. self step. ^node! ! !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: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-parsing'! parseKeywordMessage ^self parseKeywordMessageWith: self parseBinaryMessage! ! !RBParser methodsFor: 'private-parsing'! 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'! 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: '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-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: '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: '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-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'! 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: 'CamilloBruni 12/15/2011 16:40'! parseMethod | methodNode | methodNode := self parseMessagePattern. self parsePragmas. self addCommentsTo: methodNode. methodNode body: self sequenceNodeClass new. (self parseStatements: false into: methodNode body). pragmas isNil ifFalse: [ methodNode pragmas: pragmas ]. ^methodNode! ! !RBParser methodsFor: 'private-parsing' stamp: 'CamilloBruni 10/31/2012 18:37'! parseNegatedNumber | token | (self nextToken isLiteral 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: '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: '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: 'CamilloBruni 11/13/2012 10:22'! parsePragmas [ currentToken isBinary and: [ currentToken value = #< ] ] whileTrue: [ self parsePragma. self step ]! ! !RBParser methodsFor: 'private-parsing'! parsePrimitiveIdentifier | token node | token := currentToken. self step. node := self variableNodeClass identifierToken: token. self addCommentsTo: node. ^node! ! !RBParser methodsFor: 'private-parsing'! parsePrimitiveLiteral | token | token := currentToken. self step. ^self literalNodeClass literalToken: token! ! !RBParser methodsFor: 'private-parsing' stamp: 'CamilloBruni 10/31/2012 18:38'! 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 expected'! ! !RBParser methodsFor: 'private-parsing' stamp: 'ClementBEra 1/30/2013 15:22'! 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 encounted']. (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-parsing' stamp: 'CamilloBruni 12/15/2011 16:41'! parseStatements: pragmaBoolean ^ self parseStatements: pragmaBoolean into: self sequenceNodeClass new! ! !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: '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-parsing'! 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'! parseUnaryMessageWith: aNode | selector | selector := currentToken. self step. ^self messageNodeClass receiver: aNode selectorParts: (Array with: selector) arguments: #()! ! !RBParser methodsFor: 'private-parsing'! parseUnaryPattern | selector | selector := currentToken. self step. ^self methodNodeClass selectorParts: (Array with: selector) arguments: #()! ! !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-parsing' stamp: 'CamilloBruni 10/31/2012 18:38'! parseVariableNode currentToken isIdentifier ifFalse: [ ^ self parserError: 'Variable name expected']. ^self parsePrimitiveIdentifier! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBParser class instanceVariableNames: ''! !RBParser class methodsFor: 'accessing' stamp: 'CamilloBruni 10/31/2012 19:09'! errorNodeBlock ^ [ :aString :position :parser| parser parseErrorNode: aString ]! ! !RBParser class methodsFor: 'accessing' stamp: 'MarcusDenker 12/21/2012 12:13'! parseCompiledMethod: aCompiledMethod ^ self parseMethod: aCompiledMethod sourceCode! ! !RBParser class methodsFor: 'parsing'! parseExpression: aString ^self parseExpression: aString onError: nil! ! !RBParser class methodsFor: 'parsing'! 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: 'CamilloBruni 10/31/2012 19:08'! parseFaultyExpression: aString ^self parseExpression: aString onError: self errorNodeBlock! ! !RBParser class methodsFor: 'parsing' stamp: 'CamilloBruni 10/31/2012 19:08'! parseFaultyMethod: aString ^self parseMethod: aString onError: self errorNodeBlock! ! !RBParser class methodsFor: 'parsing'! parseMethod: aString ^self parseMethod: aString onError: nil! ! !RBParser class methodsFor: 'parsing'! parseMethod: aString onError: aBlock | parser | parser := self new. parser errorBlock: aBlock. parser initializeParserWith: aString. ^parser parseMethod: aString! ! !RBParser class methodsFor: 'parsing'! parseMethodPattern: aString | parser | parser := self new. parser errorBlock: [:error :position | ^nil]. parser initializeParserWith: aString. ^parser parseMessagePattern selector! ! !RBParser class methodsFor: 'parsing'! parseRewriteExpression: aString ^self parseRewriteExpression: aString onError: nil! ! !RBParser class methodsFor: 'parsing'! parseRewriteExpression: aString onError: aBlock ^RBPatternParser parseExpression: aString onError: aBlock! ! !RBParser class methodsFor: 'parsing'! parseRewriteMethod: aString ^self parseRewriteMethod: aString onError: nil! ! !RBParser class methodsFor: 'parsing'! parseRewriteMethod: aString onError: aBlock ^RBPatternParser parseMethod: aString onError: aBlock! ! TestCase subclass: #RBParserTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AST-Tests-Core'! !RBParserTest methodsFor: 'accessing'! compare: anObject to: anotherObject self assert: anObject hash = anotherObject hash. self assert: anObject = anotherObject! ! !RBParserTest methodsFor: 'accessing' stamp: 'lr 9/18/2011 15:58'! exampleClasses ^ Array with: RBParser with: RBScanner with: RBProgramNode with: RBConfigurableFormatter! ! !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: '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 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'! 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 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 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: '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: '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 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: '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: '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 21:59'! testIntervals | tree | tree := self treeWithReallyEverything. tree nodesDo: [:each | (each parent isNil or: [each parent isCascade not and: [ each parent isLiteral 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: 'TestRunner 11/2/2009 21:21'! testIsA | nodes types | nodes := Bag new. types := Set new. #(#(#isAssignment 1) #(#isBlock 1) #(#isCascade 1) #(#isLiteral 2) #(#isMessage 3) #(#isMethod 1) #(#isReturn 1) #(#isSequence 2) #(#isValue 15) #(#isVariable 7) #(#isUsed 10) #(#isDirectlyUsed 9) #(#hasParentheses 1) #(#isBinary 0) #(#isPrimitive 0) #(#isImmediate 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 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: '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: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'! 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: '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: '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:50'! testNodesDo | size | size := 0. self treeWithEverything nodesDo: [:e | size := size + 1]. self assert: size = 19! ! !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 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 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: '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 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! ! !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: '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: '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: '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'! 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: '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'! 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: '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: '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: '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: '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: '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: '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 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: '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: '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)) ])'! ! RBBlockNode subclass: #RBPatternBlockNode instanceVariableNames: 'valueBlock' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Pattern'! !RBPatternBlockNode commentStamp: 'md 8/9/2005 14:56' prior: 0! 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'! 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'! 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: 'lr 11/24/2009 23:30'! copyInContext: aDictionary ^ self replacingBlock value: aDictionary! ! !RBPatternBlockNode methodsFor: 'matching'! createBlockFor: aRBBlockNode | source | self replacePatternNodesIn: aRBBlockNode. source := aRBBlockNode formattedCode. ^Compiler evaluate: source for: self logged: false! ! !RBPatternBlockNode methodsFor: 'matching'! 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: 'matching'! 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'! lookupMatchFor: aString in: aDictionary ^aDictionary at: aString ifAbsent: [| variableNode | variableNode := RBPatternVariableNode named: aString. aDictionary at: variableNode ifAbsent: [nil]]! ! !RBPatternBlockNode methodsFor: 'matching'! match: aNode inContext: aDictionary ^self matchingBlock value: aNode value: aDictionary! ! !RBPatternBlockNode methodsFor: 'matching'! matchingBlock ^valueBlock isNil ifTrue: [valueBlock := self createMatchingBlock] ifFalse: [valueBlock]! ! !RBPatternBlockNode methodsFor: 'matching'! replacePatternNodesIn: aRBBlockNode aRBBlockNode body nodesDo: [:each | (each isVariable and: [each isPatternNode]) ifTrue: [each replaceWith: (self constructLookupNodeFor: each name in: aRBBlockNode)]]! ! !RBPatternBlockNode methodsFor: 'matching'! replacingBlock ^valueBlock isNil ifTrue: [valueBlock := self createReplacingBlock] ifFalse: [valueBlock]! ! !RBPatternBlockNode methodsFor: 'visitor'! acceptVisitor: aProgramNodeVisitor ^aProgramNodeVisitor acceptPatternBlockNode: self! ! RBValueToken subclass: #RBPatternBlockToken instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Tokens'! !RBPatternBlockToken commentStamp: 'md 8/9/2005 14:52' prior: 0! RBPatternBlockToken is the first-class representation of the pattern block token. ! !RBPatternBlockToken methodsFor: 'testing'! isPatternBlock ^true! ! RBMessageNode subclass: #RBPatternMessageNode instanceVariableNames: 'isList isCascadeList' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Pattern'! !RBPatternMessageNode commentStamp: 'md 8/9/2005 14:58' prior: 0! 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: 'accessing' stamp: 'lr 5/30/2010 14:22'! sentMessages ^ super sentMessages remove: self selector ifAbsent: [ ]; yourself! ! !RBPatternMessageNode methodsFor: 'initialize-release'! 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 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'! 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: '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 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'! isList ^isCascadeList and: [parent notNil and: [parent isCascade]]! ! !RBPatternMessageNode methodsFor: 'testing-matching'! isPatternNode ^true! ! !RBPatternMessageNode methodsFor: 'testing-matching'! isSelectorList ^isList! ! !RBPatternMessageNode methodsFor: 'private'! matchingClass ^RBMessageNode! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBPatternMessageNode class instanceVariableNames: ''! !RBPatternMessageNode class methodsFor: 'instance creation'! 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]! ! RBMethodNode subclass: #RBPatternMethodNode instanceVariableNames: 'isList' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Pattern'! !RBPatternMethodNode commentStamp: 'md 8/9/2005 14:59' prior: 0! 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: 'initialize-release'! selectorParts: tokenCollection arguments: variableNodes super selectorParts: tokenCollection arguments: variableNodes. isList := (tokenCollection first value at: 2) == self listCharacter! ! !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 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: '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 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'! isSelectorList ^isList! ! !RBPatternMethodNode methodsFor: 'testing-matching'! isPatternNode ^true! ! !RBPatternMethodNode methodsFor: 'private'! matchingClass ^RBMethodNode! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBPatternMethodNode class instanceVariableNames: ''! !RBPatternMethodNode class methodsFor: 'instance creation'! selectorParts: tokenCollection arguments: variableNodes ^(tokenCollection anySatisfy: [:each | each isPatternVariable]) ifTrue: [super selectorParts: tokenCollection arguments: variableNodes] ifFalse: [RBMethodNode selectorParts: tokenCollection arguments: variableNodes]! ! RBParser subclass: #RBPatternParser instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Parser'! !RBPatternParser commentStamp: '' prior: 0! 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: 'accessing'! scannerClass ^RBPatternScanner! ! !RBPatternParser methodsFor: 'private'! patchLiteralArrayToken (currentToken isIdentifier and: [currentToken isPatternVariable]) ifTrue: [^self]. super patchLiteralArrayToken! ! !RBPatternParser methodsFor: 'private-classes'! messageNodeClass ^RBPatternMessageNode! ! !RBPatternParser methodsFor: 'private-classes'! methodNodeClass ^RBPatternMethodNode! ! !RBPatternParser methodsFor: 'private-classes' stamp: 'lr 5/30/2010 09:44'! pragmaNodeClass ^RBPatternPragmaNode! ! !RBPatternParser methodsFor: 'private-classes'! variableNodeClass ^RBPatternVariableNode! ! !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: '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 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'! 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: 'private-parsing'! parsePrimitiveObject currentToken isPatternBlock ifTrue: [^self parsePatternBlock: RBPatternBlockNode]. ^super parsePrimitiveObject! ! !RBPatternParser methodsFor: 'private-parsing'! 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! ! RBPragmaNode subclass: #RBPatternPragmaNode instanceVariableNames: 'isList' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Pattern'! !RBPatternPragmaNode methodsFor: 'accessing' stamp: 'lr 5/30/2010 14:22'! sentMessages ^ super sentMessages remove: self selector ifAbsent: [ ]; yourself! ! !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: '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: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: '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: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: '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 instanceVariableNames: ''! !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 ]! ! RBScanner subclass: #RBPatternScanner instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Parser'! !RBPatternScanner commentStamp: '' prior: 0! 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! ! RBVariableNode subclass: #RBPatternVariableNode instanceVariableNames: 'recurseInto isList isLiteral isStatement isAnything' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Pattern'! !RBPatternVariableNode commentStamp: 'md 8/9/2005 14:59' prior: 0! 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: 'accessing'! 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: 'initialize-release'! identifierToken: anIdentifierToken super identifierToken: anIdentifierToken. self initializePatternVariables! ! !RBPatternVariableNode methodsFor: 'initialize-release'! 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: 'matching' stamp: 'lr 11/24/2009 23:37'! copyInContext: aDictionary ^ (aDictionary at: self) copy! ! !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: 'matching'! matchLiteral: aNode inContext: aDictionary ^aNode isLiteralNode and: [(aDictionary at: self ifAbsentPut: [aNode]) = aNode]! ! !RBPatternVariableNode methodsFor: 'matching'! matchStatement: aNode inContext: aDictionary (aNode parent notNil and: [aNode parent isSequence]) ifFalse: [^false]. ^(aDictionary at: self ifAbsentPut: [aNode]) = aNode! ! !RBPatternVariableNode methodsFor: 'testing-matching'! isAnything ^isAnything! ! !RBPatternVariableNode methodsFor: 'testing-matching'! isList ^isList! ! !RBPatternVariableNode methodsFor: 'testing-matching'! isLiteralNode ^isLiteral! ! !RBPatternVariableNode methodsFor: 'testing-matching'! isPatternNode ^true! ! !RBPatternVariableNode methodsFor: 'testing-matching'! isStatement ^isStatement! ! !RBPatternVariableNode methodsFor: 'testing-matching'! recurseInto ^recurseInto! ! !RBPatternVariableNode methodsFor: 'private'! matchingClass ^RBVariableNode! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBPatternVariableNode class instanceVariableNames: ''! !RBPatternVariableNode class methodsFor: 'instance creation'! identifierToken: anIdentifierToken ^anIdentifierToken isPatternVariable ifTrue: [super identifierToken: anIdentifierToken] ifFalse: [RBVariableNode identifierToken: anIdentifierToken]! ! RBPatternBlockNode subclass: #RBPatternWrapperBlockNode instanceVariableNames: 'wrappedNode' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Pattern'! !RBPatternWrapperBlockNode commentStamp: '' prior: 0! 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: 'accessing'! precedence ^1! ! !RBPatternWrapperBlockNode methodsFor: 'accessing'! wrappedNode ^wrappedNode! ! !RBPatternWrapperBlockNode methodsFor: 'accessing'! wrappedNode: aRBProgramNode wrappedNode := aRBProgramNode. aRBProgramNode parent: self! ! !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: 'matching'! match: aNode inContext: aDictionary (wrappedNode match: aNode inContext: aDictionary) ifFalse: [^false]. ^super match: aNode inContext: aDictionary! ! !RBPatternWrapperBlockNode methodsFor: 'visitor'! acceptVisitor: aProgramNodeVisitor ^aProgramNodeVisitor acceptPatternWrapperBlockNode: self! ! RBPlatform subclass: #RBPharoPlatform instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Pharo-Platform'! !RBPharoPlatform methodsFor: 'accessing' stamp: 'lr 12/29/2011 17:41'! changeStamp ^ Author changeStamp! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBPharoPlatform class instanceVariableNames: ''! !RBPharoPlatform class methodsFor: 'class initialization' stamp: 'lr 12/29/2011 17:40'! initialize Current := self new! ! Object subclass: #RBPlatform instanceVariableNames: '' classVariableNames: 'Current' poolDictionaries: '' category: 'Refactoring-Core-Model'! !RBPlatform methodsFor: 'accessing' stamp: 'lr 12/29/2011 17:41'! changeStamp self subclassResponsibility! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBPlatform class instanceVariableNames: ''! !RBPlatform class methodsFor: 'accessing' stamp: 'lr 12/29/2011 17:39'! current ^ Current! ! RBParseTreeLintRule subclass: #RBPlatformDependentUserInteractionRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBPlatformDependentUserInteractionRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:26'! category ^ 'Potential Bugs'! ! !RBPlatformDependentUserInteractionRule methodsFor: 'accessing' stamp: 'lr 3/17/2010 17:54'! group ^ 'Pharo bugs'! ! !RBPlatformDependentUserInteractionRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Platform dependent user interaction'! ! !RBPlatformDependentUserInteractionRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'The method uses platform dependent user interactions.'! ! !RBPlatformDependentUserInteractionRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:12'! severity ^ #error! ! !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 class instanceVariableNames: ''! !RBPlatformDependentUserInteractionRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBBrowserEnvironmentWrapper subclass: #RBPragmaEnvironment instanceVariableNames: 'keywords condition' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Environment'! !RBPragmaEnvironment methodsFor: 'adding' stamp: 'lr 7/21/2008 10:20'! addKeyword: aSymbol keywords add: aSymbol! ! !RBPragmaEnvironment methodsFor: 'copying' stamp: 'lr 7/21/2008 10:37'! postCopy super postCopy. keywords := keywords copy! ! !RBPragmaEnvironment methodsFor: 'initialize-release' stamp: 'lr 7/21/2008 10:34'! condition: aBlock condition := aBlock! ! !RBPragmaEnvironment methodsFor: 'initialize-release' stamp: 'lr 2/26/2009 13:35'! initialize super initialize. keywords := IdentitySet new. condition := [ :pragma | true ]! ! !RBPragmaEnvironment methodsFor: 'initialize-release' stamp: 'lr 2/24/2009 19:38'! keywords: aCollection keywords addAll: aCollection! ! !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: 'testing' stamp: 'lr 8/7/2009 12:42'! includesCategory: aCategory ^ (environment includesCategory: aCategory) and: [ (self classNamesFor: aCategory) notEmpty ]! ! !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: 'testing' stamp: 'lr 7/21/2008 10:34'! includesPragma: aPragma ^ (keywords includes: aPragma keyword) and: [ condition value: aPragma ]! ! !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: '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: '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 class instanceVariableNames: ''! !RBPragmaEnvironment class methodsFor: 'instance creation' stamp: 'lr 7/21/2008 10:38'! onEnvironment: anEnvironment keywords: aKeywordCollection ^ (self onEnvironment: anEnvironment) keywords: aKeywordCollection; yourself! ! RBProgramNode subclass: #RBPragmaNode instanceVariableNames: 'selector selectorParts arguments left right' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Nodes'! !RBPragmaNode commentStamp: '' prior: 0! 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: 'lr 10/18/2009 12:14'! arguments ^ arguments ifNil: [ #() ]! ! !RBPragmaNode methodsFor: 'accessing' stamp: 'lr 10/13/2009 14:01'! arguments: aLiteralCollection arguments := aLiteralCollection. arguments do: [ :each | each parent: self ]! ! !RBPragmaNode methodsFor: 'accessing' stamp: 'lr 10/27/2009 11:57'! children ^ self arguments! ! !RBPragmaNode methodsFor: 'accessing' stamp: 'lr 5/30/2010 09:30'! numArgs ^ self selector numArgs! ! !RBPragmaNode methodsFor: 'accessing' stamp: 'lr 10/13/2009 13:55'! selector ^ selector ifNil: [ selector := self buildSelector ]! ! !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: 'accessing' stamp: 'lr 5/30/2010 14:22'! sentMessages ^ super sentMessages add: self selector; yourself! ! !RBPragmaNode methodsFor: 'accessing' stamp: 'lr 11/5/2009 10:41'! start ^ left! ! !RBPragmaNode methodsFor: 'accessing' stamp: 'lr 11/5/2009 10:41'! stop ^ right! ! !RBPragmaNode methodsFor: 'accessing-token' stamp: 'lr 11/5/2009 10:40'! left ^ left! ! !RBPragmaNode methodsFor: 'accessing-token' stamp: 'lr 11/5/2009 10:40'! left: anInteger left := anInteger! ! !RBPragmaNode methodsFor: 'accessing-token' stamp: 'lr 11/5/2009 10:40'! right ^ right! ! !RBPragmaNode methodsFor: 'accessing-token' stamp: 'lr 11/5/2009 10:40'! right: anInteger right := anInteger! ! !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: '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: 'comparing' stamp: 'lr 3/7/2010 13:47'! hash ^ self selector hash bitXor: (self hashForCollection: self arguments)! ! !RBPragmaNode methodsFor: 'copying' stamp: 'lr 11/1/2009 22:37'! postCopy super postCopy. self arguments: (self arguments collect: [ :each | each copy ])! ! !RBPragmaNode methodsFor: 'initialization' stamp: 'lr 10/27/2009 11:58'! selectorParts: keywordTokens arguments: valueNodes self selectorParts: keywordTokens. self arguments: valueNodes! ! !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: '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: '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: 'testing' stamp: 'lr 10/13/2009 14:00'! isBinary ^ (self isUnary or: [self isKeyword]) not! ! !RBPragmaNode methodsFor: 'testing' stamp: 'lr 11/2/2009 23:37'! isKeyword ^ selectorParts first value last = $:! ! !RBPragmaNode methodsFor: 'testing' stamp: 'lr 10/13/2009 14:00'! isPragma ^ 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: 'testing' stamp: 'lr 10/13/2009 14:01'! isUnary ^ arguments isEmpty! ! !RBPragmaNode methodsFor: 'visitor' stamp: 'CamilloBruni 2/3/2012 15:53'! accept: aProgramNodeVisitor ^ aProgramNodeVisitor visitPragmaNode: self! ! !RBPragmaNode methodsFor: 'visitor' stamp: 'lr 10/13/2009 14:01'! acceptVisitor: aProgramNodeVisitor ^ aProgramNodeVisitor acceptPragmaNode: self! ! !RBPragmaNode methodsFor: 'private' stamp: 'lr 5/30/2010 09:36'! buildSelector | selectorStream | selectorStream := WriteStream on: (String new: 50). selectorParts do: [ :each | selectorStream nextPutAll: each value ]. ^ selectorStream contents asSymbol! ! !RBPragmaNode methodsFor: 'private' stamp: 'lr 5/30/2010 09:37'! selectorParts ^ selectorParts! ! !RBPragmaNode methodsFor: 'private' stamp: 'lr 10/13/2009 13:54'! selectorParts: tokenCollection selectorParts := tokenCollection! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBPragmaNode class instanceVariableNames: ''! !RBPragmaNode class methodsFor: 'instance creation' stamp: 'lr 10/13/2009 14:21'! selectorParts: keywordTokens arguments: valueNodes ^ self new selectorParts: keywordTokens arguments: valueNodes ! ! RBParseTreeLintRule subclass: #RBPrecedenceRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBPrecedenceRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:27'! category ^ 'Potential Bugs'! ! !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: '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: '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 class instanceVariableNames: ''! !RBPrecedenceRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBRefactoring subclass: #RBPrettyPrintCodeRefactoring instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NautilusRefactoring-Refactorings'! !RBPrettyPrintCodeRefactoring methodsFor: 'preconditions'! preconditions ^ RBCondition empty! ! !RBPrettyPrintCodeRefactoring methodsFor: 'transforming'! 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) ] ] ] ] ] ] ! ! Object subclass: #RBProgramNode instanceVariableNames: 'parent comments properties' classVariableNames: 'FormatterClass' poolDictionaries: '' category: 'AST-Core-Nodes'! !RBProgramNode commentStamp: '' prior: 0! 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: '*ast-semantic-accessing' stamp: 'lr 5/11/2010 22:23'! lexicalScope ^ self propertyAt: #lexicalScope ifAbsent: [ self parent isNil ifFalse: [ self parent lexicalScope ] ifTrue: [ self semanticAnnotationMissing ] ]! ! !RBProgramNode methodsFor: '*ast-semantic-actions' stamp: 'lr 6/7/2010 14:59'! annotateInClass: aBehavior self annotateInScope: (RBVariableScope owner: (RBLiteralScope owner: RBRootScope new class: aBehavior) class: aBehavior)! ! !RBProgramNode methodsFor: '*ast-semantic-actions' stamp: 'lr 5/29/2010 20:32'! annotateInScope: aScope self semanticAnnotatorClass new start: self scope: aScope! ! !RBProgramNode methodsFor: '*ast-semantic-private' stamp: 'lr 9/2/2010 13:52'! semanticAnnotationMissing RBSemanticAnnotationMissing signal: 'Semantic annotation missing, please use #annotateInClass: to annotate the AST'! ! !RBProgramNode methodsFor: '*ast-semantic-private' stamp: 'lr 5/29/2010 20:24'! semanticAnnotatorClass ^ RBSemanticAnnotator! ! !RBProgramNode methodsFor: 'accessing'! allArgumentVariables | children | children := self children. children isEmpty ifTrue: [^#()]. ^children inject: OrderedCollection new into: [:vars :each | vars addAll: each allArgumentVariables; yourself]! ! !RBProgramNode methodsFor: 'accessing'! allDefinedVariables | children | children := self children. children isEmpty ifTrue: [^#()]. ^children inject: OrderedCollection new into: [:vars :each | vars addAll: each allDefinedVariables; yourself]! ! !RBProgramNode methodsFor: 'accessing'! allTemporaryVariables | children | children := self children. children isEmpty ifTrue: [^#()]. ^children inject: OrderedCollection new into: [:vars :each | vars addAll: each allTemporaryVariables; yourself]! ! !RBProgramNode methodsFor: 'accessing'! asReturn "Change the current node to a return node." parent isNil ifTrue: [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'! blockVariables ^parent isNil ifTrue: [#()] ifFalse: [parent blockVariables]! ! !RBProgramNode methodsFor: 'accessing'! children ^#()! ! !RBProgramNode methodsFor: 'accessing' stamp: 'lr 10/1/2010 19:27'! comments "Answer the comments of the receiving parse tree node as intervals of starting and ending indices." ^ comments isNil ifTrue: [ #() ] ifFalse: [ comments ]! ! !RBProgramNode methodsFor: 'accessing'! comments: aCollection comments := aCollection! ! !RBProgramNode methodsFor: 'accessing' stamp: 'lr 3/26/2010 17:29'! formattedCode ^ self formatterClass new format: self! ! !RBProgramNode methodsFor: 'accessing' stamp: 'lr 3/26/2010 17:29'! formatterClass ^ self class formatterClass! ! !RBProgramNode methodsFor: 'accessing'! mappingFor: aNode | method | method := self methodNode. method isNil ifTrue: [^aNode]. ^method mappingFor: aNode! ! !RBProgramNode methodsFor: 'accessing'! methodComments ^self comments! ! !RBProgramNode methodsFor: 'accessing'! methodNode ^parent isNil ifTrue: [nil] ifFalse: [parent methodNode]! ! !RBProgramNode methodsFor: 'accessing'! newSource ^self formattedCode! ! !RBProgramNode methodsFor: 'accessing'! parent ^parent! ! !RBProgramNode methodsFor: 'accessing'! parent: aRBProgramNode parent := aRBProgramNode! ! !RBProgramNode methodsFor: 'accessing' stamp: 'lr 11/13/2009 09:02'! parents ^ parent isNil ifTrue: [ OrderedCollection with: self ] ifFalse: [ parent parents addLast: self; yourself ]! ! !RBProgramNode methodsFor: 'accessing'! precedence ^6! ! !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: 'accessing'! source ^parent notNil ifTrue: [parent source] ifFalse: [nil]! ! !RBProgramNode methodsFor: 'accessing'! sourceInterval ^self start to: self stop! ! !RBProgramNode methodsFor: 'accessing'! start self subclassResponsibility! ! !RBProgramNode methodsFor: 'accessing'! 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: 'accessing'! stop self subclassResponsibility! ! !RBProgramNode methodsFor: 'accessing'! temporaryVariables ^parent isNil ifTrue: [#()] ifFalse: [parent temporaryVariables]! ! !RBProgramNode methodsFor: 'comparing'! 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: 'comparing'! equalTo: aNode withMapping: aDictionary ^self = aNode! ! !RBProgramNode methodsFor: 'comparing' stamp: 'lr 3/7/2010 13:47'! hashForCollection: aCollection ^ aCollection isEmpty ifTrue: [ 0 ] ifFalse: [ aCollection first hash ]! ! !RBProgramNode methodsFor: 'copying'! 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: 'copying' stamp: 'lr 12/29/2009 12:44'! postCopy super postCopy. properties := properties copy! ! !RBProgramNode methodsFor: 'deprecated'! isImmediate ^self isImmediateNode! ! !RBProgramNode methodsFor: 'deprecated'! isLiteral ^self isLiteralNode! ! !RBProgramNode methodsFor: 'enumeration'! collect: aBlock "Hacked to fit collection protocols" ^aBlock value: self! ! !RBProgramNode methodsFor: 'enumeration'! do: aBlock "Hacked to fit collection protocols" aBlock value: self! ! !RBProgramNode methodsFor: 'enumeration'! size "Hacked to fit collection protocols" ^1! ! !RBProgramNode methodsFor: 'iterating' stamp: 'lr 11/1/2009 20:49'! allChildren | children | children := OrderedCollection new. self nodesDo: [ :each | children addLast: each ]. ^ children! ! !RBProgramNode methodsFor: 'iterating' stamp: 'lr 11/1/2009 20:49'! nodesDo: aBlock aBlock value: self. self children do: [ :each | each nodesDo: aBlock ]! ! !RBProgramNode methodsFor: 'matching' stamp: 'lr 11/24/2009 23:30'! copyInContext: aDictionary ^ self copy! ! !RBProgramNode methodsFor: 'matching'! copyList: matchNodes inContext: aDictionary | newNodes | newNodes := OrderedCollection new. matchNodes do: [:each | | object | object := each copyInContext: aDictionary. newNodes addAll: object]. ^newNodes! ! !RBProgramNode methodsFor: 'matching' stamp: 'lr 11/24/2009 23:40'! match: aNode inContext: aDictionary ^ self = aNode! ! !RBProgramNode methodsFor: 'matching'! matchList: matchNodes against: programNodes inContext: aDictionary ^self matchList: matchNodes index: 1 against: programNodes index: 1 inContext: aDictionary! ! !RBProgramNode methodsFor: 'matching'! 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: 'meta variable-accessing'! cascadeListCharacter ^$;! ! !RBProgramNode methodsFor: 'meta variable-accessing'! listCharacter ^$@! ! !RBProgramNode methodsFor: 'meta variable-accessing'! literalCharacter ^$#! ! !RBProgramNode methodsFor: 'meta variable-accessing'! recurseIntoCharacter ^$`! ! !RBProgramNode methodsFor: 'meta variable-accessing'! statementCharacter ^$.! ! !RBProgramNode methodsFor: 'printing' stamp: 'lr 11/1/2009 19:28'! printOn: aStream aStream nextPutAll: self class name; nextPut: $(; nextPutAll: self formattedCode; nextPut: $)! ! !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: '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: 'properties' stamp: 'lr 12/29/2009 12:22'! propertyAt: aKey ifAbsent: aBlock "Answer the property value associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock." ^ properties isNil ifTrue: [ aBlock value ] ifFalse: [ properties at: aKey ifAbsent: aBlock ]! ! !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: 'properties' stamp: 'lr 12/29/2009 12:22'! 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 := RBSmallDictionary new: 1 ]) at: aKey put: anObject! ! !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: 'properties' stamp: 'lr 10/18/2009 17:19'! 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 isNil ifTrue: [ ^ aBlock value ]. answer := properties removeKey: aKey ifAbsent: aBlock. properties isEmpty ifTrue: [ properties := nil ]. ^ answer! ! !RBProgramNode methodsFor: 'querying'! 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: '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: 'querying'! statementNode "Return your topmost node that is contained by a sequence node." (parent isNil or: [parent isSequence]) ifTrue: [^self]. ^parent statementNode! ! !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: 'querying'! 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: 'querying'! whoDefines: aName ^(self defines: aName) ifTrue: [self] ifFalse: [parent notNil ifTrue: [parent whoDefines: aName] ifFalse: [nil]]! ! !RBProgramNode methodsFor: 'replacing'! addReplacement: aStringReplacement parent isNil ifTrue: [^self]. parent addReplacement: aStringReplacement! ! !RBProgramNode methodsFor: 'replacing'! clearReplacements parent isNil ifTrue: [^self]. parent clearReplacements! ! !RBProgramNode methodsFor: 'replacing'! removeDeadCode self children do: [:each | each removeDeadCode]! ! !RBProgramNode methodsFor: 'replacing'! 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: 'replacing'! replaceNode: aNode withNode: anotherNode self error: 'I don''t store other nodes'! ! !RBProgramNode methodsFor: 'replacing'! replaceWith: aNode parent isNil ifTrue: [self error: 'This node doesn''t have a parent']. self replaceMethodSource: aNode. parent replaceNode: self withNode: aNode! ! !RBProgramNode methodsFor: 'testing'! assigns: aVariableName ^self children anySatisfy: [:each | each assigns: aVariableName]! ! !RBProgramNode methodsFor: 'testing'! containedBy: anInterval ^anInterval first <= self start and: [anInterval last >= self stop]! ! !RBProgramNode methodsFor: 'testing'! containsReturn ^self children anySatisfy: [:each | each containsReturn]! ! !RBProgramNode methodsFor: 'testing'! defines: aName ^false! ! !RBProgramNode methodsFor: 'testing'! directlyUses: aNode ^true! ! !RBProgramNode methodsFor: 'testing'! evaluatedFirst: aNode self children do: [:each | each == aNode ifTrue: [^true]. each isImmediateNode ifFalse: [^false]]. ^false! ! !RBProgramNode methodsFor: 'testing'! hasMultipleReturns | count | count := 0. self nodesDo: [:each | each isReturn ifTrue: [count := count + 1]]. ^count > 1! ! !RBProgramNode methodsFor: 'testing'! intersectsInterval: anInterval ^(anInterval first between: self start and: self stop) or: [self start between: anInterval first and: anInterval last]! ! !RBProgramNode methodsFor: 'testing' stamp: 'CamilloBruni 12/15/2011 14:31'! isArgument ^false! ! !RBProgramNode methodsFor: 'testing' stamp: 'lr 11/1/2009 18:39'! isArray ^ false! ! !RBProgramNode methodsFor: 'testing'! isAssignment ^false! ! !RBProgramNode methodsFor: 'testing'! isBlock ^false! ! !RBProgramNode methodsFor: 'testing'! isCascade ^false! ! !RBProgramNode methodsFor: 'testing'! isDirectlyUsed "This node is directly used as an argument, receiver, or part of an assignment." ^parent isNil ifTrue: [false] ifFalse: [parent directlyUses: self]! ! !RBProgramNode methodsFor: 'testing'! isEvaluatedFirst "Return true if we are the first thing evaluated in this statement." ^parent isNil or: [parent isSequence or: [parent evaluatedFirst: self]]! ! !RBProgramNode methodsFor: 'testing'! isImmediateNode ^false! ! !RBProgramNode methodsFor: 'testing'! isLast: aNode | children | children := self children. ^children notEmpty and: [children last == aNode]! ! !RBProgramNode methodsFor: 'testing'! isLiteralArray ^false! ! !RBProgramNode methodsFor: 'testing'! isLiteralNode ^false! ! !RBProgramNode methodsFor: 'testing'! isMessage ^false! ! !RBProgramNode methodsFor: 'testing'! isMethod ^false! ! !RBProgramNode methodsFor: 'testing' stamp: 'lr 10/27/2009 14:33'! isPragma ^false! ! !RBProgramNode methodsFor: 'testing'! isReturn ^false! ! !RBProgramNode methodsFor: 'testing' stamp: 'CamilloBruni 12/15/2011 14:32'! isSelf ^ false! ! !RBProgramNode methodsFor: 'testing'! isSequence ^false! ! !RBProgramNode methodsFor: 'testing' stamp: 'CamilloBruni 12/15/2011 14:32'! isTemp ^ false! ! !RBProgramNode methodsFor: 'testing'! 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 isNil ifTrue: [false] ifFalse: [parent uses: self]! ! !RBProgramNode methodsFor: 'testing'! isValue ^false! ! !RBProgramNode methodsFor: 'testing'! isVariable ^false! ! !RBProgramNode methodsFor: 'testing'! lastIsReturn ^self isReturn! ! !RBProgramNode methodsFor: 'testing'! references: aVariableName ^self children anySatisfy: [:each | each references: aVariableName]! ! !RBProgramNode methodsFor: 'testing'! uses: aNode ^true! ! !RBProgramNode methodsFor: 'testing-matching'! canMatchMethod: aCompiledMethod ^self sentMessages allSatisfy: [:each | (self class optimizedSelectors includes: each) or: [aCompiledMethod refersToLiteral: each]]! ! !RBProgramNode methodsFor: 'testing-matching'! isList ^false! ! !RBProgramNode methodsFor: 'testing-matching'! isPatternNode ^false! ! !RBProgramNode methodsFor: 'testing-matching'! recurseInto ^false! ! !RBProgramNode methodsFor: 'visitor' stamp: 'CamilloBruni 2/3/2012 15:52'! accept: aProgramNodeVisitor self subclassResponsibility! ! !RBProgramNode methodsFor: 'visitor' stamp: 'CamilloBruni 12/14/2011 16:11'! acceptIgnoreResult: aProgramVisitor ^ self accept: aProgramVisitor! ! !RBProgramNode methodsFor: 'visitor'! acceptVisitor: aProgramNodeVisitor self subclassResponsibility! ! !RBProgramNode methodsFor: 'private-replacing' stamp: 'lr 10/29/2010 11:37'! replaceSourceFrom: aNode self == aNode ifFalse: [ self clearReplacements ]! ! !RBProgramNode methodsFor: 'private-replacing'! replaceSourceWith: aNode aNode replaceSourceFrom: self! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBProgramNode class instanceVariableNames: ''! !RBProgramNode class methodsFor: 'accessing' stamp: 'lr 11/7/2009 15:35'! formatterClass ^ FormatterClass isNil ifTrue: [ RBConfigurableFormatter ] ifFalse: [ FormatterClass ]! ! !RBProgramNode class methodsFor: 'accessing'! 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: '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: ]) ]! ! TestCase subclass: #RBProgramNodeTest instanceVariableNames: 'node previous' classVariableNames: '' poolDictionaries: '' category: 'AST-Tests-Core'! !RBProgramNodeTest methodsFor: 'accessing' stamp: 'lr 12/29/2009 12:48'! node ^ node ifNil: [ node := RBProgramNode new ]! ! !RBProgramNodeTest methodsFor: 'accessing' stamp: 'lr 2/21/2010 12:17'! parseExpression: aString ^ RBParser parseExpression: aString! ! !RBProgramNodeTest methodsFor: 'accessing' stamp: 'lr 2/21/2010 12:17'! parseMethod: aString ^ RBParser parseMethod: aString! ! !RBProgramNodeTest methodsFor: 'running' stamp: 'lr 3/26/2010 17:35'! setUp super setUp. previous := RBProgramNode formatterClass. RBProgramNode formatterClass: RBFormatter! ! !RBProgramNodeTest methodsFor: 'running' stamp: 'lr 3/26/2010 17:35'! tearDown super tearDown. RBProgramNode formatterClass: previous! ! !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-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-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-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: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-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 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: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-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-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-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-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 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-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: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: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-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 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-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: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: '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: '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-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-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: '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 class instanceVariableNames: ''! !RBProgramNodeTest class methodsFor: 'accessing' stamp: 'lr 9/18/2011 15:06'! packageNamesUnderTest ^ #('AST-Core')! ! Object subclass: #RBProgramNodeVisitor uses: TRBProgramNodeVisitor instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Visitors'! !RBProgramNodeVisitor commentStamp: '' prior: 0! RBProgramNodeVisitor is an abstract visitor for the RBProgramNodes. ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified'! acceptArgumentNode: anArgumentNode ^ self acceptVariableNode: anArgumentNode! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified'! acceptArrayNode: anArrayNode anArrayNode children do: [:each | self visitNode: each]! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified'! acceptAssignmentNode: anAssignmentNode self visitNode: anAssignmentNode variable. self visitNode: anAssignmentNode value! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified'! acceptBlockNode: aBlockNode self visitArguments: aBlockNode arguments. self visitNode: aBlockNode body! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified'! acceptCascadeNode: aCascadeNode aCascadeNode messages do: [:each | self visitNode: each]! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified'! acceptLiteralArrayNode: aRBLiteralArrayNode aRBLiteralArrayNode contents do: [:each | self visitNode: each]! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified'! acceptLiteralNode: aLiteralNode! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified'! acceptMessageNode: aMessageNode (aMessageNode isCascaded not or: [aMessageNode isFirstCascaded]) ifTrue: [self visitNode: aMessageNode receiver]. aMessageNode arguments do: [:each | self visitNode: each]! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified'! acceptMethodNode: aMethodNode self visitArguments: aMethodNode arguments. aMethodNode pragmas do: [ :each | self visitNode: each ]. self visitNode: aMethodNode body! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified'! acceptParseErrorNode: anErrorNode! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified'! acceptPatternBlockNode: aRBPatternBlockNode self visitArguments: aRBPatternBlockNode arguments. self visitNode: aRBPatternBlockNode body! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified'! acceptPatternWrapperBlockNode: aRBPatternWrapperBlockNode self visitNode: aRBPatternWrapperBlockNode wrappedNode. self visitArguments: aRBPatternWrapperBlockNode arguments. self visitNode: aRBPatternWrapperBlockNode body! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified'! acceptPragmaNode: aPragmaNode aPragmaNode arguments do: [ :each | self visitNode: each ]! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified'! acceptReturnNode: aReturnNode ^ self visitNode: aReturnNode value! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified'! acceptSelfNode: aSelfNode ^ self acceptVariableNode: aSelfNode! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified'! acceptSequenceNode: aSequenceNode self visitTemporaries: aSequenceNode temporaries. aSequenceNode statements do: [:each | self visitNode: each]! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified'! acceptSuperNode: aSuperNode ^ self acceptVariableNode: aSuperNode! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified'! acceptTemporaryNode: anTemporaryNode ^ self acceptVariableNode: anTemporaryNode! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified'! acceptThisContextNode: aThisContextNode ^ self acceptVariableNode: aThisContextNode! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified'! acceptVariableNode: aVariableNode! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified'! visitArgument: each "Here to allow subclasses to detect arguments or temporaries." ^self visitNode: each! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified'! visitArguments: aNodeCollection ^aNodeCollection do: [:each | self visitArgument: each]! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified'! visitNode: aNode ^aNode acceptVisitor: self! ! !RBProgramNodeVisitor methodsFor: 'as yet unclassified'! visitTemporaries: aNodeCollection ^ self visitArguments: aNodeCollection! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBProgramNodeVisitor class uses: TRBProgramNodeVisitor classTrait instanceVariableNames: ''! RBVariableRefactoring subclass: #RBProtectInstanceVariableRefactoring instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBProtectInstanceVariableRefactoring methodsFor: 'preconditions'! preconditions ^RBCondition definesInstanceVariable: variableName in: class! ! !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'! transform self setOption: #inlineExpression toUse: [:ref :string | true]. self getterSetterMethods do: [:each | self inline: each]! ! !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! ! RBRefactoringTest subclass: #RBProtectInstanceVariableTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !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)! ! RBBrowserEnvironmentWrapper subclass: #RBProtocolEnvironment instanceVariableNames: 'class protocols' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Environment'! !RBProtocolEnvironment methodsFor: 'copying' stamp: 'lr 2/26/2009 14:29'! postCopy super postCopy. protocols := protocols copy! ! !RBProtocolEnvironment methodsFor: 'initialize-release'! class: aClass protocols: aCollection class := aClass. protocols := aCollection! ! !RBProtocolEnvironment methodsFor: 'printing'! 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: 'testing'! includesClass: aClass ^aClass == class and: [super includesClass: aClass]! ! !RBProtocolEnvironment methodsFor: 'testing'! includesProtocol: aProtocol in: aClass ^aClass == class and: [(super includesProtocol: aProtocol in: aClass) and: [protocols includes: aProtocol]]! ! !RBProtocolEnvironment methodsFor: 'testing'! includesSelector: aSelector in: aClass ^(super includesSelector: aSelector in: aClass) and: [protocols includes: (environment whichProtocolIncludes: aSelector in: aClass)]! ! !RBProtocolEnvironment methodsFor: 'testing'! isEmpty ^protocols isEmpty! ! !RBProtocolEnvironment methodsFor: 'private'! defaultLabel | stream | stream := String new writeStream. stream nextPutAll: class name; nextPut: $>. protocols do: [:each | stream nextPutAll: each; nextPut: $ ]. ^stream contents! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBProtocolEnvironment class instanceVariableNames: ''! !RBProtocolEnvironment class methodsFor: 'instance creation'! onEnvironment: anEnvironment class: aClass protocols: aCollection ^(self onEnvironment: anEnvironment) class: aClass protocols: aCollection; yourself! ! RBRegexRefactoring subclass: #RBProtocolRegexRefactoring instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NautilusRefactoring-Refactorings'! !RBProtocolRegexRefactoring methodsFor: 'transforming'! 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 ] ] ] ]! ! RBVariableRefactoring subclass: #RBPullUpClassVariableRefactoring instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBPullUpClassVariableRefactoring methodsFor: 'preconditions'! preconditions ^(RBCondition isMetaclass: class) not! ! !RBPullUpClassVariableRefactoring methodsFor: 'transforming'! transform | subclass | subclass := self subclassDefiningVariable. subclass removeClassVariable: variableName. class addClassVariable: variableName! ! !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! ! RBRefactoringTest subclass: #RBPullUpClassVariableTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !RBPullUpClassVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testMetaClassFailure self shouldFail: (RBPullUpClassVariableRefactoring variable: #RecursiveSelfRule class: RBLintRuleTest class)! ! !RBPullUpClassVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testNonExistantName self shouldFail: (RBPullUpClassVariableRefactoring variable: #Foo class: RBLintRuleTest)! ! !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)! ! RBVariableRefactoring subclass: #RBPullUpInstanceVariableRefactoring instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !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'! transform class allSubclasses do: [:each | (each directlyDefinesInstanceVariable: variableName) ifTrue: [each removeInstanceVariable: variableName]]. class addInstanceVariable: variableName! ! RBRefactoringTest subclass: #RBPullUpInstanceVariableTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !RBPullUpInstanceVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testPullUpVariableNotDefined self shouldFail: (RBPullUpInstanceVariableRefactoring variable: 'notDefinedVariable' class: RBLintRuleTest)! ! !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')! ! RBMethodRefactoring subclass: #RBPullUpMethodRefactoring instanceVariableNames: 'removeDuplicates selectors' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !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: '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'! checkClassVars selectors do: [:each | self checkClassVarsFor: each]! ! !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'! checkInstVars selectors do: [:each | self checkInstVarsFor: each]! ! !RBPullUpMethodRefactoring methodsFor: 'preconditions'! 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: '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: 'preconditions'! checkSuperMessages self checkSuperSendsFromPushedUpMethods. self checkSuperSendsFromSiblings! ! !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: 'preconditions'! checkSuperSendsFromSiblings | siblings | siblings := class superclass subclasses reject: [:each | each = class]. siblings do: [:aRBClass | self checkSiblingSuperSendsFrom: aRBClass]! ! !RBPullUpMethodRefactoring methodsFor: 'preconditions'! 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'! 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'! copyDownMethods selectors do: [:each | self copyDownMethod: 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'! pullUpMethods selectors do: [:each | self pullUp: each]! ! !RBPullUpMethodRefactoring methodsFor: 'transforming'! removeDuplicateMethods selectors do: [:each | self removeDuplicatesOf: each]! ! !RBPullUpMethodRefactoring methodsFor: 'transforming'! 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: 'transforming' stamp: 'lr 7/17/2010 23:24'! removePulledUpMethods selectors do: [:each | class removeMethod: each]! ! !RBPullUpMethodRefactoring methodsFor: 'transforming' stamp: 'lr 7/17/2010 23:24'! transform self copyDownMethods; pullUpMethods; removePulledUpMethods; removeDuplicateMethods! ! !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 class instanceVariableNames: ''! !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! ! RBRefactoringTest subclass: #RBPullUpMethodTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !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'! testPullUpReferencesInstVar self shouldFail: (RBPullUpMethodRefactoring pullUp: #(#checkClass: ) from: RBBasicLintRuleTest)! ! !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: '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'! 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: '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: '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)! ! RBVariableRefactoring subclass: #RBPushDownClassVariableRefactoring instanceVariableNames: 'destinationClass' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !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'! preconditions "Preconditions are that only one subclass refers to the class variable." ^(RBCondition definesClassVariable: variableName in: class) & (RBCondition withBlock: [self findDestinationClass. true])! ! !RBPushDownClassVariableRefactoring methodsFor: 'preconditions'! signalMultipleReferenceError self signalReferenceError: ('Multiple subclasses reference <1s>' expandMacrosWith: 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'! signalStillReferencedError self signalReferenceError: ('<1p> has references to <2s>' expandMacrosWith: class with: variableName)! ! !RBPushDownClassVariableRefactoring methodsFor: 'transforming'! transform class removeClassVariable: variableName. destinationClass isNil ifTrue: [^self]. destinationClass addClassVariable: variableName! ! RBRefactoringTest subclass: #RBPushDownClassVariableTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !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: '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: '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'! 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: '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)! ! !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: '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) ]! ! RBVariableRefactoring subclass: #RBPushDownInstanceVariableRefactoring instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !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'! transform class removeInstanceVariable: variableName. class subclasses do: [:each | (each withAllSubclasses detect: [:aClass | (aClass whichSelectorsReferToInstanceVariable: variableName) isEmpty not] ifNone: [nil]) notNil ifTrue: [each addInstanceVariable: variableName]]! ! RBRefactoringTest subclass: #RBPushDownInstanceVariableTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !RBPushDownInstanceVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testNonExistantName self shouldFail: (RBPushDownInstanceVariableRefactoring variable: 'foo' class: RBBasicLintRuleTest)! ! !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: '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: 'tests' stamp: 'lr 9/8/2011 20:11'! 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 deny: ((model classNamed: #Subclass) directlyDefinesVariable: 'foo')! ! !RBPushDownInstanceVariableTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:11'! testPushDownInstanceVariable | refactoring | refactoring := RBPushDownInstanceVariableRefactoring variable: 'foo1' class: RBLintRuleTest. self executeRefactoring: refactoring. (refactoring model classNamed: #RBLintRuleTest) withAllSubclasses do: [ :each | self deny: (each directlyDefinesInstanceVariable: 'foo1') ]! ! RBMethodRefactoring subclass: #RBPushDownMethodRefactoring instanceVariableNames: 'selectors' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBPushDownMethodRefactoring methodsFor: 'initialize-release'! pushDown: selectorCollection from: aClass class := self classObjectFor: aClass. selectors := selectorCollection! ! !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'! 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: '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: 'transforming'! transform selectors do: [:each | self pushDown: each]. selectors do: [:each | class removeMethod: each]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBPushDownMethodRefactoring class instanceVariableNames: ''! !RBPushDownMethodRefactoring class methodsFor: 'instance creation'! model: aRBSmalltalk pushDown: selectorCollection from: aClass ^(self new) model: aRBSmalltalk; pushDown: selectorCollection from: aClass; yourself! ! !RBPushDownMethodRefactoring class methodsFor: 'instance creation'! pushDown: selectorCollection from: aClass ^self new pushDown: selectorCollection from: aClass! ! RBRefactoringTest subclass: #RBPushDownMethodTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !RBPushDownMethodTest methodsFor: 'failure tests' stamp: 'lr 12/29/2011 17:30'! testPushDownMethodOnNonAbstractClass | refactoring | refactoring := RBPushDownMethodRefactoring pushDown: #(#yourself) from: Object. self shouldFail: refactoring! ! !RBPushDownMethodTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testPushDownNonExistantMenu | refactoring | refactoring := RBPushDownMethodRefactoring pushDown: #(#someMethodThatDoesNotExist ) from: RBLintRuleTest. self shouldFail: refactoring! ! !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: '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) ]! ! RBProgramNodeVisitor subclass: #RBReadBeforeWrittenTester instanceVariableNames: 'read checkNewTemps scopeStack' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Visitors'! !RBReadBeforeWrittenTester commentStamp: '' prior: 0! 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: 'accessing'! executeTree: aParseTree ^self visitNode: aParseTree! ! !RBReadBeforeWrittenTester methodsFor: 'accessing'! read self currentScope keysAndValuesDo: [:key :value | value == true ifTrue: [read add: key]]. ^read! ! !RBReadBeforeWrittenTester methodsFor: 'initialize-release'! checkNewTemps: aBoolean checkNewTemps := aBoolean! ! !RBReadBeforeWrittenTester methodsFor: 'initialize-release'! initialize super initialize. scopeStack := OrderedCollection with: Dictionary new. read := Set new. checkNewTemps := true! ! !RBReadBeforeWrittenTester methodsFor: 'initialize-release'! initializeVars: varNames varNames do: [:each | self currentScope at: each put: nil]! ! !RBReadBeforeWrittenTester methodsFor: 'visitor-double dispatching'! acceptAssignmentNode: anAssignmentNode self visitNode: anAssignmentNode value. self variableWritten: anAssignmentNode! ! !RBReadBeforeWrittenTester methodsFor: 'visitor-double dispatching'! acceptBlockNode: aBlockNode self processBlock: aBlockNode! ! !RBReadBeforeWrittenTester methodsFor: 'visitor-double dispatching'! acceptMessageNode: 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: 'visitor-double dispatching'! acceptSequenceNode: aSequenceNode self processStatementNode: aSequenceNode! ! !RBReadBeforeWrittenTester methodsFor: 'visitor-double dispatching'! acceptVariableNode: aVariableNode self variableRead: aVariableNode! ! !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'! createScope scopeStack add: (self copyDictionary: scopeStack last)! ! !RBReadBeforeWrittenTester methodsFor: 'private'! currentScope ^scopeStack last! ! !RBReadBeforeWrittenTester methodsFor: 'private'! 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: 'private'! 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 methodsFor: 'private'! 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'! removeScope ^scopeStack removeLast! ! !RBReadBeforeWrittenTester methodsFor: 'private'! variableRead: aNode (self currentScope includesKey: aNode name) ifTrue: [(self currentScope at: aNode name) isNil ifTrue: [self currentScope at: aNode name put: true]]! ! !RBReadBeforeWrittenTester methodsFor: 'private'! 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 class instanceVariableNames: ''! !RBReadBeforeWrittenTester class methodsFor: 'accessing'! isVariable: aString readBeforeWrittenIn: aBRProgramNode ^(self isVariable: aString writtenBeforeReadIn: aBRProgramNode) not! ! !RBReadBeforeWrittenTester class methodsFor: 'accessing'! isVariable: aString writtenBeforeReadIn: aBRProgramNode ^(self readBeforeWritten: (Array with: aString) in: aBRProgramNode) isEmpty! ! !RBReadBeforeWrittenTester class methodsFor: 'accessing'! readBeforeWritten: varNames in: aParseTree ^(self new) checkNewTemps: false; initializeVars: varNames; executeTree: aParseTree; read! ! !RBReadBeforeWrittenTester class methodsFor: 'accessing'! variablesReadBeforeWrittenIn: aParseTree ^(self new) executeTree: aParseTree; read! ! RBClassRefactoring subclass: #RBRealizeClassRefactoring instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NautilusRefactoring-Refactorings'! !RBRealizeClassRefactoring commentStamp: 'lr 10/19/2007 09:16' prior: 0! Make a given class concrete, by providing empty templates for all the abstract methods.! !RBRealizeClassRefactoring methodsFor: 'accessing'! theClass ^ (self classObjectFor: className) theNonMetaClass! ! !RBRealizeClassRefactoring methodsFor: 'preconditions'! 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: 'transforming'! transform self transform: self theClass. self transform: self theClass theMetaClass! ! !RBRealizeClassRefactoring methodsFor: 'transforming'! 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 ] ] ]! ! Object subclass: #RBRefactoring instanceVariableNames: 'model options' classVariableNames: 'RefactoringOptions' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBRefactoring methodsFor: '*NautilusRefactoring'! whatToDisplayIn: aBrowser ^ self changes changes gather: [:e | e whatToDisplayIn: aBrowser ]! ! !RBRefactoring methodsFor: 'accessing'! changes ^self model changes! ! !RBRefactoring methodsFor: 'accessing'! 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: 'accessing'! options ^options isNil ifTrue: [self class refactoringOptions] ifFalse: [options]! ! !RBRefactoring methodsFor: 'accessing'! options: aDictionary options := aDictionary! ! !RBRefactoring methodsFor: 'accessing'! 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: 'initialize-release'! model: aRBNamespace model := aRBNamespace! ! !RBRefactoring methodsFor: 'preconditions'! 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: 'preconditions'! preconditions self subclassResponsibility! ! !RBRefactoring methodsFor: 'requests'! openBrowserOn: anEnvironment ^(self options at: #openBrowser) value: self value: anEnvironment! ! !RBRefactoring methodsFor: 'requests'! requestImplementorToInline: implementorsCollection ^(self options at: #implementorToInline) value: self value: implementorsCollection! ! !RBRefactoring methodsFor: 'requests' stamp: 'dvf 9/8/2001 19:32'! requestMethodNameFor: aMethodName ^(self options at: #methodName) value: self value: aMethodName! ! !RBRefactoring methodsFor: 'requests'! requestSelfArgumentName ^(self options at: #selfArgumentName) value: self! ! !RBRefactoring methodsFor: 'requests'! selectVariableToMoveMethodTo: aSelector class: aClass ^(self options at: #selectVariableToMoveTo) value: self value: aClass value: aSelector! ! !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: 'requests'! shouldExtractAssignmentTo: aString ^(self options at: #extractAssignment) value: self value: aString! ! !RBRefactoring methodsFor: 'requests'! shouldInlineExpression: aString ^(self options at: #inlineExpression) value: self value: aString! ! !RBRefactoring methodsFor: 'requests'! shouldOverride: aSelector in: aClass ^(self options at: #alreadyDefined) value: self value: aClass value: aSelector! ! !RBRefactoring methodsFor: 'requests'! shouldUseExistingMethod: aSelector ^(self options at: #useExistingMethod) value: self value: aSelector! ! !RBRefactoring methodsFor: 'support'! checkClass: aRBClass selector: aSelector using: aMatcher | parseTree | parseTree := aRBClass parseTreeFor: aSelector. parseTree notNil ifTrue: [aMatcher executeTree: parseTree]. ^aMatcher answer! ! !RBRefactoring methodsFor: 'support'! convertAllReferencesTo: aSymbol using: searchReplacer self model allReferencesTo: aSymbol do: [:method | self convertMethod: method selector for: method modelClass using: searchReplacer]! ! !RBRefactoring methodsFor: 'support'! convertAllReferencesToClass: aRBClass using: searchReplacer self model allReferencesToClass: aRBClass do: [:method | self convertMethod: method selector for: method modelClass using: searchReplacer]! ! !RBRefactoring methodsFor: 'support'! convertClasses: classSet select: aBlock using: searchReplacer classSet do: [:aClass | (aBlock value: aClass) do: [:selector | self convertMethod: selector for: aClass using: searchReplacer]]! ! !RBRefactoring methodsFor: 'support'! 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: 'testing'! canReferenceVariable: aString in: aClass (aClass definesVariable: aString) ifTrue: [^true]. (self model includesGlobal: aString asSymbol) ifTrue: [^true]. ^(self poolVariableNamesFor: aClass) includes: aString! ! !RBRefactoring methodsFor: 'transforming' stamp: 'lr 9/8/2011 20:25'! defaultEnvironment ^RBBrowserEnvironment new! ! !RBRefactoring methodsFor: 'transforming' stamp: 'lr 9/8/2011 20:14'! execute self primitiveExecute. RBRefactoringManager instance addRefactoring: self! ! !RBRefactoring methodsFor: 'transforming'! model ^model isNil ifTrue: [model := (RBNamespace onEnvironment: self defaultEnvironment) name: self printString; yourself] ifFalse: [model]! ! !RBRefactoring methodsFor: 'transforming'! performComponentRefactoring: aRefactoring aRefactoring copyOptionsFrom: self options. aRefactoring primitiveExecute! ! !RBRefactoring methodsFor: 'transforming'! transform self subclassResponsibility! ! !RBRefactoring methodsFor: 'utilities'! associationForClassVariable: aName in: aClass ifAbsent: aBlock ^aClass realClass classPool associationAt: aName asSymbol ifAbsent: [aClass realClass classPool associationAt: aName asString ifAbsent: aBlock]! ! !RBRefactoring methodsFor: 'utilities'! checkInstanceVariableName: aName in: aClass ^RBCondition checkInstanceVariableName: aName in: aClass! ! !RBRefactoring methodsFor: 'utilities'! checkMethodName: aName in: aClass ^RBCondition checkMethodName: aName in: aClass! ! !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: 'utilities'! 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: '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: '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: 'private'! onError: aBlock do: errorBlock ^aBlock on: self class preconditionSignal do: [:ex | errorBlock value. ex return: nil]! ! !RBRefactoring methodsFor: 'private'! primitiveExecute self checkPreconditions. self transform! ! !RBRefactoring methodsFor: 'private' stamp: 'lr 10/5/2010 16:13'! refactoringError: aString ^ RBRefactoringError signal: aString! ! !RBRefactoring methodsFor: 'private' stamp: 'lr 10/5/2010 16:13'! refactoringError: aString with: aBlock ^ RBRefactoringError signal: aString with: aBlock! ! !RBRefactoring methodsFor: 'private' stamp: 'CamilloBruni 10/7/2012 23:54'! refactoringFailure: aString ^ RBRefactoringFailure signal: aString! ! !RBRefactoring methodsFor: 'private' stamp: 'CamilloBruni 10/7/2012 23:55'! refactoringFailure: aString with: aBlock ^ RBRefactoringFailure signal: aString with: aBlock! ! !RBRefactoring methodsFor: 'private' stamp: 'lr 10/5/2010 16:13'! refactoringWarning: aString ^ RBRefactoringWarning signal: aString! ! !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: 'private'! 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 class instanceVariableNames: ''! !RBRefactoring class methodsFor: 'accessing' stamp: 'lr 1/18/2010 21:03'! refactoringOptions ^ RefactoringOptions! ! !RBRefactoring class methodsFor: 'accessing'! setDefaultOption: aSymbol to: aBlock self refactoringOptions at: aSymbol put: aBlock! ! !RBRefactoring class methodsFor: 'accessing signal' stamp: 'lr 10/5/2010 16:13'! preconditionSignal ^ RBRefactoringError , RBRefactoringWarning! ! !RBRefactoring class methodsFor: 'initialization' stamp: 'lr 1/18/2010 21:02'! initialize self initializeRefactoringOptions! ! !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 ]! ! TestCase subclass: #RBRefactoringBrowserTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !RBRefactoringBrowserTest methodsFor: 'private'! convertInterval: anInterval for: aString "Convert the interval to ignore differences in end of line conventions." ^anInterval! ! !RBRefactoringBrowserTest methodsFor: 'private'! executeRefactoring: aRefactoring aRefactoring primitiveExecute. RBParser parseExpression: aRefactoring storeString! ! !RBRefactoringBrowserTest methodsFor: 'private'! objectClassVariable ^Object classPool keys detect: [:each | true]! ! !RBRefactoringBrowserTest methodsFor: 'private' stamp: 'CamilloBruni 1/12/2013 12:49'! proceedThroughWarning: aBlock aBlock on: RBRefactoringWarning do: [ :ex | ex resume ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBRefactoringBrowserTest class instanceVariableNames: ''! !RBRefactoringBrowserTest class methodsFor: 'testing' stamp: 'lr 10/27/2009 14:01'! isAbstract ^ self name = #RBRefactoringBrowserTest! ! Object subclass: #RBRefactoringChangeMock instanceVariableNames: 'instVar' classVariableNames: 'ClassVar' poolDictionaries: '' category: 'Refactoring-Tests-Changes'! !RBRefactoringChangeMock methodsFor: 'accessing' stamp: 'CamilloBruni 9/11/2012 16:42'! one ^ 1! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBRefactoringChangeMock class instanceVariableNames: 'classInstVar'! TestCase subclass: #RBRefactoringChangeTests instanceVariableNames: 'changes' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Changes'! !RBRefactoringChangeTests methodsFor: 'mocking' stamp: 'lr 10/15/2010 09:17'! changeMock ^ RBRefactoringChangeMock! ! !RBRefactoringChangeTests methodsFor: 'mocking' stamp: 'lr 9/6/2010 13:38'! selectionInterval ^ 1 to: 0! ! !RBRefactoringChangeTests methodsFor: 'mocking' stamp: 'lr 11/6/2011 08:54'! text ^ String new! ! !RBRefactoringChangeTests methodsFor: 'running' stamp: 'lr 9/8/2011 20:10'! setUp super setUp. changes := RBCompositeRefactoryChange named: 'testing'! ! !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 9/8/2011 20:10'! 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 poolDictionaryNames size = 1. self assert: change poolDictionaryNames first = 'PoolDict'. self assert: change category = self class category. self universalTestFor: change! ! !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' 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: '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' 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 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 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 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: '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 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: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: '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 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: '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' 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: '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 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' 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: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' 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: '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-pattern' stamp: 'lr 9/8/2011 20:10'! testAddClassPattern "Make sure that all class definitions can be parsed." self class environment allClassesDo: [ :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 poolDictionaryNames = class poolDictionaryNames asArray). self assert: (change category = class category). self universalTestFor: change ] ]! ! !RBRefactoringChangeTests methodsFor: 'tests-pattern' stamp: 'lr 9/8/2011 20:10'! testAddClassTraitPattern "Make sure that all class trait definitions can be parsed." self class environment allTraitsDo: [ :trait | | change | change := changes defineClass: trait classTrait definition. self assert: (change isKindOf: RBAddClassTraitChange). self assert: (change changeClassName = trait name). self universalTestFor: change ]! ! !RBRefactoringChangeTests methodsFor: 'tests-pattern' stamp: 'lr 9/8/2011 20:10'! testAddMetaclassPattern "Make sure that all metaclass definitions can be parsed." self class environment allClassesDo: [ :class | | change | change := changes defineClass: class class definition. self assert: (change isKindOf: RBAddMetaclassChange). self assert: (change changeClassName = class name). self assert: (change classInstanceVariableNames = class class instVarNames). self universalTestFor: change ]! ! !RBRefactoringChangeTests methodsFor: 'tests-pattern' stamp: 'lr 9/8/2011 20:10'! testAddTraitPattern "Make sure that all trait definitions can be parsed." self class environment allTraitsDo: [ :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 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: '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: '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: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-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: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-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-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-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-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: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-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: '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-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-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-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 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: '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: '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: '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: 'utilities' stamp: 'lr 9/8/2011 20:10'! undoTestFor: aChange | undo | undo := aChange asUndoOperation. self assert: (undo isKindOf: RBRefactoryChange)! ! !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 class instanceVariableNames: ''! !RBRefactoringChangeTests class methodsFor: 'accessing' stamp: 'lr 9/5/2010 19:39'! packageNamesUnderTest ^ #('Refactoring-Changes')! ! Error subclass: #RBRefactoringError instanceVariableNames: 'actionBlock' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Support'! !RBRefactoringError commentStamp: 'lr 10/5/2010 16:17' prior: 0! 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 instanceVariableNames: ''! !RBRefactoringError class methodsFor: 'signalling' stamp: 'lr 10/5/2010 16:07'! signal: aString with: aBlock ^ self new actionBlock: aBlock; signal: aString! ! RBRefactoringError subclass: #RBRefactoringFailure instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Support'! !RBRefactoringFailure commentStamp: '' prior: 0! 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! ! Object subclass: #RBRefactoringManager instanceVariableNames: 'refactorings' classVariableNames: 'Instance' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBRefactoringManager methodsFor: 'initialize-release'! initialize refactorings := Bag new! ! !RBRefactoringManager methodsFor: 'printing'! printOn: aStream aStream nextPutAll: '# Refactoring'; cr; nextPutAll: '--- -----------------------------------------------'; cr. refactorings asSet asSortedCollection do: [:name | aStream nextPutAll: (refactorings occurrencesOf: name) printString; nextPutAll: ' '; nextPutAll: name; cr]! ! !RBRefactoringManager methodsFor: 'public access' stamp: 'lr 9/8/2011 20:10'! addRefactoring: aRefactoring RBRefactoryChangeManager instance performChange: aRefactoring changes. refactorings add: aRefactoring class name! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBRefactoringManager class instanceVariableNames: ''! !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! ! !RBRefactoringManager class methodsFor: 'public' stamp: 'lr 4/4/2010 08:32'! unload self nuke! ! RBRefactoringBrowserTest subclass: #RBRefactoringTest instanceVariableNames: 'manager changeSet model' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !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: 'set up'! setupImplementorToInlineFor: aRefactoring toReturn: anObject | options | options := aRefactoring options copy. options at: #implementorToInline put: [:ref :imps | anObject]. aRefactoring options: options! ! !RBRefactoringTest methodsFor: 'set up'! setupInlineExpressionFor: aRefactoring toReturn: aBoolean | options | options := aRefactoring options copy. options at: #inlineExpression put: [:ref :string | aBoolean]. aRefactoring options: options! ! !RBRefactoringTest methodsFor: 'set up'! setupMethodNameFor: aRefactoring toReturn: aSelector | options | options := aRefactoring options copy. options at: #methodName put: [:ref :aMethodName | aMethodName selector: aSelector; yourself]. aRefactoring options: options! ! !RBRefactoringTest methodsFor: 'set up'! 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'! setupSelfArgumentNameFor: aRefactoring toReturn: aString | options | options := aRefactoring options copy. options at: #selfArgumentName put: [:ref | aString]. aRefactoring options: options! ! !RBRefactoringTest methodsFor: 'set up'! setupVariableToMoveToFor: aRefactoring toReturn: aString | options | options := aRefactoring options copy. options at: #selectVariableToMoveTo put: [:ref :class :selector | aString]. aRefactoring options: options! ! !RBRefactoringTest methodsFor: 'set up'! setupVariableTypesFor: aRefactoring toReturn: anObject | options | options := aRefactoring options copy. options at: #variableTypes put: [:ref :ignore1 :ignore2 | anObject]. 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: '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: 'tests' stamp: 'lr 9/8/2011 20:14'! testPrintRefactoringManager self assert: RBRefactoringManager instance printString isString! ! !RBRefactoringTest methodsFor: 'private' stamp: 'lr 9/8/2011 20:57'! abstractVariableTestData ^' | model | (model := RBNamespace onEnvironment: ((RBClassEnvironment onEnvironment: RBBrowserEnvironment new) classes: (#(#Bar #Foo) inject: OrderedCollection new into: [:sum :each | | class | class := Smalltalk at: each ifAbsent: [nil]. class notNil ifTrue: [sum add: class]. sum]) , (#(#Bar #Foo) 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: #Foo instanceVariableNames: ''''instVarName1 instVarName2 '''' classVariableNames: ''''ClassVarName1 ClassVarName2 '''' poolDictionaries: '''''''' category: ''''Testing'''''' ''Foo subclass: #Bar instanceVariableNames: '''''''' classVariableNames: '''''''' poolDictionaries: '''''''' category: ''''Testing'''''') do: [:each | model 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 := model classNamed: each first. each last do: [:meth | class compile: meth first classified: meth last]]. model '! ! !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: 'private' stamp: 'lr 10/5/2010 16:13'! shouldFail: aRefactoring self proceedThroughWarning: [ self should: [ self executeRefactoring: aRefactoring ] raise: RBRefactoringError ]! ! !RBRefactoringTest methodsFor: 'private' stamp: 'lr 10/5/2010 16:13'! shouldWarn: aRefactoring self should: [ self executeRefactoring: aRefactoring ] raise: RBRefactoringWarning! ! Notification subclass: #RBRefactoringWarning instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Support'! !RBRefactoringWarning commentStamp: 'lr 10/5/2010 16:17' prior: 0! 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. ! Object subclass: #RBRefactoryChange instanceVariableNames: 'name' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Changes'! !RBRefactoryChange commentStamp: '' prior: 0! 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: '*NautilusRefactoring'! accept: aText notifying: aController ^ false! ! !RBRefactoryChange methodsFor: '*NautilusRefactoring'! nameToDisplay ^ self name! ! !RBRefactoryChange methodsFor: '*NautilusRefactoring'! oldVersionTextToDisplay ^ ''! ! !RBRefactoryChange methodsFor: '*NautilusRefactoring'! textToDisplay ^ self name! ! !RBRefactoryChange methodsFor: '*NautilusRefactoring'! whatToDisplayIn: aChangeBrowser ^ { self }! ! !RBRefactoryChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 11:29'! changeForClass: aClassName selector: aSelector ^ nil! ! !RBRefactoryChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 11:29'! changeForMetaclass: aClassName selector: aSelector ^ nil! ! !RBRefactoryChange methodsFor: 'accessing'! changes ^Array with: self! ! !RBRefactoryChange methodsFor: 'accessing'! changesSize ^1! ! !RBRefactoryChange methodsFor: 'accessing'! name ^name isNil ifTrue: [self changeString] ifFalse: [name]! ! !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: 'initialize-release'! name: aString name := aString! ! !RBRefactoryChange methodsFor: 'performing-changes'! execute ^self executeNotifying: []! ! !RBRefactoryChange methodsFor: 'printing'! changeString ^self class name! ! !RBRefactoryChange methodsFor: 'printing'! displayString ^name isNil ifTrue: [self changeString] ifFalse: [name]! ! !RBRefactoryChange methodsFor: 'private'! executeNotifying: aBlock self subclassResponsibility! ! Object subclass: #RBRefactoryChangeManager instanceVariableNames: 'undo redo isPerformingRefactoring' classVariableNames: 'Instance UndoSize' poolDictionaries: '' category: 'Refactoring-Changes'! !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: 'CamilleTeruel 7/29/2012 18:46'! disconnectFromChanges SystemAnnouncer uniqueInstance unsubscribe: self! ! !RBRefactoryChangeManager methodsFor: 'initialize-release'! initialize undo := OrderedCollection new. redo := OrderedCollection new. isPerformingRefactoring := false. self connectToChanges! ! !RBRefactoryChangeManager methodsFor: 'initialize-release'! release super release. self disconnectFromChanges! ! !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: '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'! performChange: aRefactoringChange self ignoreChangesWhile: [ self addUndo: aRefactoringChange 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: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'! undoChange ^ undo last! ! !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: 'testing' stamp: 'lr 9/7/2010 19:11'! hasRedoableOperations ^ redo isEmpty not! ! !RBRefactoryChangeManager methodsFor: 'testing' stamp: 'lr 9/7/2010 19:11'! hasUndoableOperations ^ undo isEmpty not! ! !RBRefactoryChangeManager methodsFor: 'updating' stamp: 'GuillermoPolito 7/2/2012 11:54'! update: anEvent isPerformingRefactoring ifFalse: [ self clearUndoRedoList ]! ! !RBRefactoryChangeManager methodsFor: 'private'! clearUndoRedoList undo := OrderedCollection new. redo := OrderedCollection new! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBRefactoryChangeManager class instanceVariableNames: ''! !RBRefactoryChangeManager class methodsFor: 'class initialization' stamp: 'lr 4/4/2010 08:32'! initialize self nuke. UndoSize := 20! ! !RBRefactoryChangeManager class methodsFor: 'class initialization' stamp: 'lr 4/4/2010 08:33'! undoSize ^ UndoSize! ! !RBRefactoryChangeManager class methodsFor: 'class initialization'! undoSize: anInteger UndoSize := anInteger max: 0! ! !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: 'public' stamp: 'lr 4/4/2010 08:34'! nuke Instance notNil ifTrue: [ Instance release ]. Instance := nil! ! !RBRefactoryChangeManager class methodsFor: 'public' stamp: 'lr 4/4/2010 08:34'! unload self nuke! ! !RBRefactoryChangeManager class methodsFor: 'settings' stamp: 'LukasRenggli 12/18/2009 10:42'! settingsOn: aBuilder (aBuilder setting: #undoSize) target: self; label: 'Undo size'; parentName: #refactoring! ! RBRefactoryChange subclass: #RBRefactoryClassChange instanceVariableNames: 'className isMeta' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Changes'! !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 10/31/2009 17:37'! changeClass: aBehavior isMeta := aBehavior isMeta. className := aBehavior theNonMetaClass name! ! !RBRefactoryClassChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 21:19'! changeClassName ^ className! ! !RBRefactoryClassChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 21:19'! changeClassName: aSymbol className := aSymbol. isMeta isNil ifTrue: [ isMeta := false ]! ! !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 9/6/2010 13:57'! renameChangesForClass: oldClassName to: newClassName ^ self changeClassName = oldClassName ifFalse: [ self ] ifTrue: [ self copy changeClassName: newClassName; yourself ]! ! !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: 'comparing' stamp: 'lr 9/6/2010 21:19'! hash ^ self changeClassName hash! ! !RBRefactoryClassChange methodsFor: 'converting'! asUndoOperation ^self subclassResponsibility! ! !RBRefactoryClassChange methodsFor: 'printing' stamp: 'lr 9/6/2010 21:19'! changeString ^ self displayClassName! ! !RBRefactoryClassChange methodsFor: 'printing' stamp: 'lr 9/6/2010 21:19'! displayClassName ^ isMeta ifTrue: [ self changeClassName , ' class' ] ifFalse: [ self changeClassName asString ]! ! !RBRefactoryClassChange methodsFor: 'printing'! printOn: aStream aStream nextPutAll: self displayString! ! !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: 'private' stamp: 'lr 9/6/2010 21:19'! isMeta ^ isMeta! ! !RBRefactoryClassChange methodsFor: 'private' stamp: 'lr 9/6/2010 13:29'! primitiveExecute ^ self subclassResponsibility! ! RBRefactoryClassChange subclass: #RBRefactoryDefinitionChange instanceVariableNames: 'controller definition definedClass' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Changes'! !RBRefactoryDefinitionChange methodsFor: 'accessing' stamp: 'lr 9/30/2010 14:13'! controller ^ controller! ! !RBRefactoryDefinitionChange methodsFor: 'accessing' stamp: 'lr 9/30/2010 14:09'! definedClass ^ definedClass! ! !RBRefactoryDefinitionChange methodsFor: 'accessing' stamp: 'lr 9/30/2010 14:08'! definition ^ definition! ! !RBRefactoryDefinitionChange methodsFor: 'comparing' stamp: 'lr 9/30/2010 14:07'! = aDefinitionChange ^ self class = aDefinitionChange class and: [ self definition = aDefinitionChange definition ]! ! !RBRefactoryDefinitionChange methodsFor: 'comparing' stamp: 'lr 9/30/2010 14:07'! hash ^ definition hash! ! !RBRefactoryDefinitionChange methodsFor: 'initialization' stamp: 'lr 10/1/2010 14:37'! definition: aString controller: aController isMeta := false. definition := aString. controller := aController! ! !RBRefactoryDefinitionChange methodsFor: 'initialization' stamp: 'lr 10/1/2010 14:32'! fillOutDefinition: aDictionary self subclassResponsibility! ! !RBRefactoryDefinitionChange methodsFor: 'printing' stamp: 'lr 9/30/2010 14:12'! changeString ^ 'Define ' , self displayClassName! ! !RBRefactoryDefinitionChange methodsFor: 'printing' stamp: 'lr 9/30/2010 14:12'! printOn: aStream aStream nextPutAll: definition; nextPut: $!!! ! !RBRefactoryDefinitionChange methodsFor: 'private' stamp: 'lr 9/30/2010 14:20'! definitionClass self subclassResponsibility! ! !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 methodsFor: 'private' stamp: 'lr 10/14/2010 20:50'! primitiveExecute definedClass := self definitionClass compilerClass evaluate: self definition notifying: self controller logged: true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBRefactoryDefinitionChange class instanceVariableNames: ''! !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: 'lr 9/8/2011 20:10'! definition: aString for: aController | parseTree context | parseTree := RBParser parseExpression: aString onError: [ :err :pos | ^ self error: 'Invalid definition string' ]. context := RBSmallDictionary 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: 'lr 9/30/2010 18:54'! definition: aString for: aController context: aDictionary | dictionary | dictionary := RBSmallDictionary new. aDictionary keysAndValuesDo: [ :key :node | dictionary at: key formattedCode put: (node isVariable ifTrue: [ node name ] ifFalse: [ node isLiteral ifTrue: [ node value ] ifFalse: [ node ] ]) ]. ^ self new definition: aString controller: aController; fillOutDefinition: dictionary; yourself! ! !RBRefactoryDefinitionChange class methodsFor: 'private' stamp: 'lr 10/1/2010 14:32'! definitionPatterns self subclassResponsibility! ! Object subclass: #RBRefactoryTestDataApp instanceVariableNames: 'temporaryVariable' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core-Data'! !RBRefactoryTestDataApp methodsFor: 'accessing'! 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: 'inline'! called: anObject on1: aBlock | each | each := anObject printString. Transcript show: each; cr. aBlock value: each! ! !RBRefactoryTestDataApp methodsFor: 'inline'! called: anObject on: aBlock Transcript show: anObject printString; cr. aBlock value! ! !RBRefactoryTestDataApp methodsFor: 'inline'! caller | anObject | anObject := 5. self called: anObject + 1 on: [^anObject]! ! !RBRefactoryTestDataApp methodsFor: 'inline'! caller1 | anObject | anObject := 5. self called: anObject + 1 on1: [:each | each printString. ^anObject]! ! !RBRefactoryTestDataApp methodsFor: 'inline'! caller2 ^(1 to: 10) inject: 1 into: [:sum :each | sum * (self foo: each)]! ! !RBRefactoryTestDataApp methodsFor: 'inline'! foo: aValue ^(1 to: 10) inject: aValue into: [:sum :each | sum + each]! ! !RBRefactoryTestDataApp methodsFor: 'inline'! inlineComponent | a | a := 5. ^a class superclass; hasImmediateInstances; yourself! ! !RBRefactoryTestDataApp methodsFor: 'inline'! inlineFailed | x y q | x := 5. y := 10. q := x + 1 fooMax: y. ^q! ! !RBRefactoryTestDataApp methodsFor: 'inline'! inlineLast 5 = 3 ifTrue: [^self caller] ifFalse: [^self caller2]! ! !RBRefactoryTestDataApp methodsFor: 'inline'! inlineMax | x y q | x := 5. y := 10. q := x + 1 max: y. ^q! ! !RBRefactoryTestDataApp methodsFor: 'inline'! inlineTemporary | temp | self isNil ifTrue: [temp := 4]. ^temp! ! !RBRefactoryTestDataApp methodsFor: 'inline'! multipleCalls self caller2. self caller2! ! !RBRefactoryTestDataApp methodsFor: 'lint'! asOrderedCollectionNotNeeded self foo addAll: (1 to: 10) asOrderedCollection! ! !RBRefactoryTestDataApp methodsFor: 'lint'! assignmentInBlock [^self printString] ensure: [self close]! ! !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: 'md 3/14/2006 16:47'! atIfAbsent ^ Smalltalk at: #MyTest ifAbsent: [| collection | collection := #(). Smalltalk at: #MyTest put: collection]! ! !RBRefactoryTestDataApp methodsFor: 'lint'! badMessage self become: String new! ! !RBRefactoryTestDataApp methodsFor: 'lint'! booleanPrecedence ^true & 4 = 45! ! !RBRefactoryTestDataApp methodsFor: 'lint'! collectSelectNotUsed (1 to: 10) select: [:each | each = 4]! ! !RBRefactoryTestDataApp methodsFor: 'lint'! collectionMessagesToExternalObject self someObject collection remove: 10! ! !RBRefactoryTestDataApp methodsFor: 'lint'! collectionProtocol | newCollection | newCollection := OrderedCollection new. (1 to: 10) asOrderedCollection do: [:each | | new | new := each * 2. newCollection add: new]. ^newCollection! ! !RBRefactoryTestDataApp methodsFor: 'lint'! consistencyCheck ^(1 to: 10) at: 1! ! !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: 'lr 7/1/2008 10:14'! cruft self halt! ! !RBRefactoryTestDataApp methodsFor: 'lint'! detectContains ^(1 to: 10) do: [:each | each > 2 ifTrue: [^each]]! ! !RBRefactoryTestDataApp methodsFor: 'lint'! endTrueFalse self isVariable ifTrue: [self printString. self isVariable printString] ifFalse: [self printString. ^4]! ! !RBRefactoryTestDataApp methodsFor: 'lint'! equalNotUsed | string | string = '' yourself. (1 to: 10) do: [:i | string := i printString]. ^string! ! !RBRefactoryTestDataApp methodsFor: 'lint'! equalsTrue ^true == self! ! !RBRefactoryTestDataApp methodsFor: 'lint'! extraBlock ^[:arg | arg + 43] value: 45! ! !RBRefactoryTestDataApp methodsFor: 'lint'! fileBlocks | file | ^ [file := 'asdf' asFilename readStream. file contents] ensure: [file close]! ! !RBRefactoryTestDataApp methodsFor: 'lint'! fullBlocks ^[thisContext]! ! !RBRefactoryTestDataApp methodsFor: 'lint'! guardingClause self isSymbol ifFalse: [self printString. self isSymbol printString]! ! !RBRefactoryTestDataApp methodsFor: 'lint'! ifTrueReturns self isSymbol ifFalse: [^true]. ^false! ! !RBRefactoryTestDataApp methodsFor: 'lint'! isLiteral ^false! ! !RBRefactoryTestDataApp methodsFor: 'lint'! justSendsSuper super justSendsSuper! ! !RBRefactoryTestDataApp methodsFor: 'lint'! literalArrayCharacters ^#($a $b $c) includes: $a! ! !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: '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: 'lint'! 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: 'lint'! missingYourself ^(OrderedCollection new) add: 1; add: 2; removeFirst! ! !RBRefactoryTestDataApp methodsFor: 'lint'! modifiesCollection | collection | collection := (1 to: 10) asOrderedCollection. collection do: [:each | each > 5 ifTrue: [collection remove: each]]. ^collection! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: 'nk 3/5/2005 14:51'! noIsNil: arg ^arg = nil or: [ arg ~= nil ]! ! !RBRefactoryTestDataApp methodsFor: 'lint'! precedence ^self isArray ifFalse: [self block + 5 * 34] ifTrue: [self printString = 10]! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: 'lr 2/26/2009 15:07'! refersToClass ^ RBRefactoryTestDataApp! ! !RBRefactoryTestDataApp methodsFor: 'lint'! release self printString! ! !RBRefactoryTestDataApp methodsFor: 'lint'! returnInEnsure [self error: 'asdf'] ensure: [^4]! ! !RBRefactoryTestDataApp methodsFor: 'lint'! returnsBooleanAndOther self isVariable ifTrue: [^false]. self printString! ! !RBRefactoryTestDataApp methodsFor: 'lint'! 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: 'nk 3/5/2005 15:28'! sendsDifferentSuper super printString! ! !RBRefactoryTestDataApp methodsFor: 'lint'! sizeCheck self isEmpty ifFalse: [self do: [:each | Transcript show: each; cr]]! ! !RBRefactoryTestDataApp methodsFor: 'lint'! stringConcatenation | string | string := '' yourself. (1 to: 10) do: [:i | string := string , i printString]. ^string! ! !RBRefactoryTestDataApp methodsFor: 'lint'! tempVarOverridesInstVar | temporaryVariable | temporaryVariable := 4. ^temporaryVariable! ! !RBRefactoryTestDataApp methodsFor: 'lint'! tempsReadBeforeWritten | temp | self isVariable ifTrue: [temp := 4]. ^temp! ! !RBRefactoryTestDataApp methodsFor: 'lint'! threeElementPoint ^5 @ 5 + 6 @ 6! ! !RBRefactoryTestDataApp methodsFor: 'lint'! toDo 1 to: self size do: [:i | (self at: i) printString]! ! !RBRefactoryTestDataApp methodsFor: 'lint'! toDoCollect | array | array := Array new: 10. 1 to: 10 do: [:i | array at: i put: i * i]. ^array! ! !RBRefactoryTestDataApp methodsFor: 'lint'! toDoWithIncrement | counter | counter := 0. 1 to: 10 by: 2 do: [:i | counter := counter + 2]. ^counter! ! !RBRefactoryTestDataApp methodsFor: 'lint'! usesAdd ^(1 to: 10) asOrderedCollection addAll: (11 to: 20)! ! !RBRefactoryTestDataApp methodsFor: 'lint' stamp: 'nk 2/25/2005 16:50'! variableAssignedLiteral temporaryVariable := #() ! ! !RBRefactoryTestDataApp methodsFor: 'lint'! whileTrue | i | i := 1. [i < self size] whileTrue: [(self at: i) printString. i := i + 1]! ! !RBRefactoryTestDataApp methodsFor: 'lint'! yourselfNotUsed self printString; printString; yourself! ! !RBRefactoryTestDataApp methodsFor: 'test'! callFoo ^self testFoo: 5! ! !RBRefactoryTestDataApp methodsFor: 'test'! callMethod ^self renameThisMethod: 5! ! !RBRefactoryTestDataApp methodsFor: 'test'! exampleCall ^self rename: 1 two: 2! ! !RBRefactoryTestDataApp methodsFor: 'test'! inlineFoo: aBlock | bar baz asdf | bar := aBlock value: self. baz := bar + bar. asdf := baz + bar. ^asdf! ! !RBRefactoryTestDataApp methodsFor: 'test'! inlineJunk | asdf | asdf := self inlineFoo: [:each | | temp | temp := each. temp , temp]. ^asdf foo: [:bar | | baz | baz := bar. baz * baz]! ! !RBRefactoryTestDataApp methodsFor: 'test'! inlineMethod | temp | temp := self foo; inlineMethod; bar. ^temp! ! !RBRefactoryTestDataApp methodsFor: 'test'! inlineParameterMethod: aSymbol ^aSymbol isSymbol! ! !RBRefactoryTestDataApp methodsFor: 'test'! moveDefinition | temp | ^(self collect: [:each | temp := each printString. temp , temp]) select: [:each | temp := each size. temp odd]! ! !RBRefactoryTestDataApp methodsFor: 'test'! noMoveDefinition | temp | ^(self collect: [:each | temp := each printString. temp , temp]) select: [:each | temp := each size + temp]! ! !RBRefactoryTestDataApp methodsFor: 'test'! rename: this two: argumentMethod ^self printString , this , argumentMethod! ! !RBRefactoryTestDataApp methodsFor: 'test'! renameThisMethod: anArg ^self! ! !RBRefactoryTestDataApp methodsFor: 'test'! selectorNotReferenced ^self selectorNotReferenced + 4! ! !RBRefactoryTestDataApp methodsFor: 'test'! sendInlineParameterMethod ^self inlineParameterMethod: #(#asdf)! ! !RBRefactoryTestDataApp methodsFor: 'test'! symbolReference ^#(#renameThisMethod: #(4 #renameThisMethod:))! ! !RBRefactoryTestDataApp methodsFor: 'test'! testFoo: anObject ^self class + anObject! ! !RBRefactoryTestDataApp methodsFor: 'test'! testMethod ^self class! ! !RBRefactoryTestDataApp methodsFor: 'test'! testMethod1 ^self testMethod1 , ([:each | each testMethod1] value: #(#(#testMethod1) 2 #testMethod1))! ! Object subclass: #RBRefactoryTyper instanceVariableNames: 'model class variableTypes bestGuesses variableMessages backpointers methodName selectorLookup' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Support'! !RBRefactoryTyper methodsFor: 'accessing'! guessTypesFor: anInstVarName ^bestGuesses at: anInstVarName ifAbsent: [self typesFor: anInstVarName]! ! !RBRefactoryTyper methodsFor: 'accessing'! guessTypesFor: anInstVarName in: aClass class = aClass ifFalse: [self runOn: aClass]. ^bestGuesses at: anInstVarName ifAbsent: [self typesFor: anInstVarName in: aClass]! ! !RBRefactoryTyper methodsFor: 'accessing'! 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: 'accessing'! selectedClass: aClass class := model classFor: aClass! ! !RBRefactoryTyper methodsFor: 'accessing'! typesFor: anInstVarName ^variableTypes at: anInstVarName ifAbsent: [Set new]! ! !RBRefactoryTyper methodsFor: 'accessing'! typesFor: anInstVarName in: aClass class = aClass ifFalse: [self runOn: aClass]. ^variableTypes at: anInstVarName ifAbsent: [Set new]! ! !RBRefactoryTyper methodsFor: 'assignments' stamp: 'lr 5/29/2010 18:10'! 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 isLiteral 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: '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: '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: 'computing types'! computeTypes variableMessages keysAndValuesDo: [:key :value | variableTypes at: key put: (self findTypeFor: value)]! ! !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: '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: 'computing types'! 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: 'computing types'! 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: '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'! 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: 'initialize-release'! initialize model := RBNamespace new. class := model classFor: Object. variableTypes := Dictionary new. variableMessages := Dictionary new. selectorLookup := IdentityDictionary new. bestGuesses := Dictionary new! ! !RBRefactoryTyper methodsFor: 'printing'! collectionNameFor: aString ^'-<1s>-' expandMacrosWith: aString! ! !RBRefactoryTyper methodsFor: 'printing'! 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: 'printing'! 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: 'printing'! 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: '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: '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: '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: '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: '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: 'private'! 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'! model ^model! ! !RBRefactoryTyper methodsFor: 'private'! model: aRBSmalltalk model := aRBSmalltalk! ! !RBRefactoryTyper methodsFor: 'private' stamp: 'lr 5/29/2010 10:01'! rootClasses ^ model rootClasses! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBRefactoryTyper class instanceVariableNames: ''! !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! ! !RBRefactoryTyper class methodsFor: 'instance creation'! newFor: aRBNamespace ^(self new) model: aRBNamespace; yourself! ! RBRefactoryClassChange subclass: #RBRefactoryVariableChange instanceVariableNames: 'variable' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Changes'! !RBRefactoryVariableChange methodsFor: 'comparing' stamp: 'lr 10/15/2010 09:37'! = aRefactoryVariableChange ^ super = aRefactoryVariableChange and: [ self variable = aRefactoryVariableChange variable ]! ! !RBRefactoryVariableChange methodsFor: 'comparing' stamp: 'lr 10/15/2010 09:37'! hash ^ self changeClassName hash bitXor: self variable hash! ! !RBRefactoryVariableChange methodsFor: 'initialize-release'! class: aBehavior variable: aString self changeClass: aBehavior. variable := aString! ! !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'! changeSymbol self subclassResponsibility! ! !RBRefactoryVariableChange methodsFor: 'private' stamp: 'lr 10/15/2010 09:43'! primitiveExecute self changeClass perform: self changeSymbol with: self changeObject! ! !RBRefactoryVariableChange methodsFor: 'private' stamp: 'lr 9/6/2010 21:29'! variable ^ variable! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBRefactoryVariableChange class instanceVariableNames: ''! !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! ! !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! ! RBBlockLintRule subclass: #RBRefersToClassRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBRefersToClassRule commentStamp: '' prior: 0! See my #rationale.! !RBRefersToClassRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 10:35'! category ^ 'Design Flaws'! ! !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'! group ^ 'Miscellaneous'! ! !RBRefersToClassRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Refers to class name instead of "self class"'! ! !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: '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 instanceVariableNames: ''! !RBRefersToClassRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBRefactoring subclass: #RBRegexRefactoring instanceVariableNames: 'matchers' classVariableNames: '' poolDictionaries: '' category: 'NautilusRefactoring-Refactorings'! !RBRegexRefactoring methodsFor: 'initialize'! initialize super initialize. matchers := OrderedCollection new! ! !RBRegexRefactoring methodsFor: 'preconditions'! preconditions ^ RBCondition empty! ! !RBRegexRefactoring methodsFor: 'searching'! replace: aFindString with: aReplaceString self replace: aFindString with: aReplaceString ignoreCase: false! ! !RBRegexRefactoring methodsFor: 'searching'! 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! ! !RBRegexRefactoring methodsFor: 'private'! 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: 'private'! 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 ]! ! RBTransformationRule subclass: #RBRemoveAssignmentWithoutEffectRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Manifest-Core'! !RBRemoveAssignmentWithoutEffectRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 14:05'! category ^ 'Optimization'! ! !RBRemoveAssignmentWithoutEffectRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/12/2012 14:02'! longDescription ^ 'Remove assignment has no effect. For example, var := var is unless'! ! !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: 'initialization' stamp: 'SimonAllier 2/8/2013 16:43'! initialize super initialize. self rewriteRule replace: '`var := `var' with: ''! ! RBRefactoryClassChange subclass: #RBRemoveClassChange instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Changes'! !RBRemoveClassChange methodsFor: 'accessing' stamp: 'lr 10/15/2010 09:10'! changeClass: aBehavior super changeClass: aBehavior. isMeta := false! ! !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 methodsFor: 'printing' stamp: 'lr 4/7/2010 08:20'! changeString ^ 'Remove ' , self displayClassName! ! !RBRemoveClassChange methodsFor: 'printing'! printOn: aStream aStream nextPutAll: self displayClassName; nextPutAll: ' removeFromSystem'; nextPut: $!!! ! !RBRemoveClassChange methodsFor: 'private'! primitiveExecute self changeClass removeFromSystem! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBRemoveClassChange class instanceVariableNames: ''! !RBRemoveClassChange class methodsFor: 'instance creation' stamp: 'lr 9/7/2010 19:44'! remove: aClass ^ self new changeClass: aClass! ! !RBRemoveClassChange class methodsFor: 'instance creation' stamp: 'lr 9/7/2010 19:45'! removeClassName: aSymbol ^ self new changeClassName: aSymbol! ! RBRefactoring subclass: #RBRemoveClassRefactoring instanceVariableNames: 'classNames' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBRemoveClassRefactoring methodsFor: 'initialize-release'! classNames: aClassNameCollection classNames := aClassNameCollection! ! !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: '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: 'printing'! storeOn: aStream aStream nextPut: $(. self class storeOn: aStream. aStream nextPutAll: ' classNames: '. classNames asArray storeOn: aStream. aStream nextPut: $)! ! !RBRemoveClassRefactoring methodsFor: 'transforming'! removeClasses classNames do: [:each | self model removeClassNamed: each]! ! !RBRemoveClassRefactoring methodsFor: 'transforming'! reparentSubclasses classNames do: [:each | | class | class := self model classNamed: each. self model reparentClasses: class subclasses copy to: class superclass]! ! !RBRemoveClassRefactoring methodsFor: 'transforming'! transform self reparentSubclasses; removeClasses! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBRemoveClassRefactoring class instanceVariableNames: ''! !RBRemoveClassRefactoring class methodsFor: 'instance creation'! classNames: aClassNameCollection ^self new classNames: aClassNameCollection! ! !RBRemoveClassRefactoring class methodsFor: 'instance creation'! model: aRBSmalltalk classNames: aClassNameCollection ^(self new) model: aRBSmalltalk; classNames: aClassNameCollection; yourself! ! RBRefactoringTest subclass: #RBRemoveClassTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !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)! ! RBRefactoryVariableChange subclass: #RBRemoveClassVariableChange instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Changes'! !RBRemoveClassVariableChange methodsFor: 'accessing' stamp: 'lr 10/15/2010 08:31'! changeClass: aBehavior super changeClass: aBehavior. isMeta := false! ! !RBRemoveClassVariableChange methodsFor: 'converting' stamp: 'lr 9/8/2011 20:10'! asUndoOperation ^ RBAddClassVariableChange add: self variable to: self changeClass! ! !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: 'private' stamp: 'lr 3/20/2011 11:28'! changeSymbol ^ #removeClassVarNamed:! ! RBVariableRefactoring subclass: #RBRemoveClassVariableRefactoring instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !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'! transform class removeClassVariable: variableName! ! RBRefactoringTest subclass: #RBRemoveClassVariableTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !RBRemoveClassVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testNonExistantName self shouldFail: (RBRemoveClassVariableRefactoring variable: #RecursiveSelfRule1 class: RBTransformationRuleTest)! ! !RBRemoveClassVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testReferencedVariable self shouldFail: (RBRemoveClassVariableRefactoring variable: #RecursiveSelfRule 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')! ! RBRefactoryVariableChange subclass: #RBRemoveInstanceVariableChange instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Changes'! !RBRemoveInstanceVariableChange methodsFor: 'converting' stamp: 'lr 9/8/2011 20:10'! asUndoOperation ^ RBAddInstanceVariableChange add: self variable to: self changeClass! ! !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:! ! RBVariableRefactoring subclass: #RBRemoveInstanceVariableRefactoring instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !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'! transform class removeInstanceVariable: variableName! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBRemoveInstanceVariableRefactoring class instanceVariableNames: ''! !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! ! !RBRemoveInstanceVariableRefactoring class methodsFor: 'as yet unclassified' stamp: 'lr 1/20/2010 08:43'! remove: variable from: class ^ self variable: variable class: class! ! RBRefactoringTest subclass: #RBRemoveInstanceVariableTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !RBRemoveInstanceVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testNonExistantName self shouldFail: (RBRemoveInstanceVariableRefactoring variable: 'name1' class: RBLintRuleTest)! ! !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: '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')! ! RBRefactoryClassChange subclass: #RBRemoveMethodChange instanceVariableNames: 'selector' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Changes'! !RBRemoveMethodChange methodsFor: 'comparing' stamp: 'lr 9/7/2010 19:10'! = aRemoveMethodChange super = aRemoveMethodChange ifFalse: [ ^ false ]. ^ selector = aRemoveMethodChange selector! ! !RBRemoveMethodChange methodsFor: 'comparing' stamp: 'lr 9/7/2010 19:11'! hash ^ selector hash! ! !RBRemoveMethodChange methodsFor: 'converting' stamp: 'lr 9/8/2011 20:10'! asUndoOperation ^ RBAddMethodChange compile: (self methodSourceFor: selector) in: self changeClass! ! !RBRemoveMethodChange methodsFor: 'initialize-release' stamp: 'lr 9/7/2010 19:11'! selector: aSymbol selector := aSymbol! ! !RBRemoveMethodChange methodsFor: 'printing' stamp: 'lr 4/7/2010 08:21'! changeString ^ 'Remove <1s>>>#<2s>' expandMacrosWith: self displayClassName with: 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: 'private' stamp: 'lr 9/7/2010 19:11'! selector ^ selector! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBRemoveMethodChange class instanceVariableNames: ''! !RBRemoveMethodChange class methodsFor: 'instance creation' stamp: 'lr 9/7/2010 19:45'! remove: aSymbol from: aClass ^ self new changeClass: aClass; selector: aSymbol; yourself! ! RBMethodRefactoring subclass: #RBRemoveMethodRefactoring instanceVariableNames: 'selectors' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBRemoveMethodRefactoring methodsFor: 'initialize-release'! removeMethods: selectorCollection from: aClass class := self classObjectFor: aClass. selectors := selectorCollection! ! !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: 'preconditions'! 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'! 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 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'! preconditions ^(selectors inject: RBCondition empty into: [:cond :each | cond & (RBCondition definesSelector: each in: class)]) & (RBCondition withBlock: [self checkSuperMethods. true])! ! !RBRemoveMethodRefactoring methodsFor: 'preconditions'! 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: 'printing'! 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: 'transforming'! transform selectors do: [:each | class removeMethod: each]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBRemoveMethodRefactoring class instanceVariableNames: ''! !RBRemoveMethodRefactoring class methodsFor: 'instance creation'! model: aRBSmalltalk removeMethods: selectorCollection from: aClass ^(self new) model: aRBSmalltalk; removeMethods: selectorCollection from: aClass; yourself! ! !RBRemoveMethodRefactoring class methodsFor: 'instance creation'! removeMethods: selectorCollection from: aClass ^self new removeMethods: selectorCollection from: aClass! ! RBRefactoringTest subclass: #RBRemoveMethodTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !RBRemoveMethodTest methodsFor: 'accessing' stamp: 'TestRunner 1/3/2010 12:35'! expectedFailures ^ #(testRemoveSameMethodButSendsSuper)! ! !RBRemoveMethodTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testRemoveReferenced self shouldFail: (RBRemoveMethodRefactoring removeMethods: #(#checkClass: ) from: RBBasicLintRuleTest)! ! !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'! 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)! ! !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)! ! RBChangeMethodNameRefactoring subclass: #RBRemoveParameterRefactoring instanceVariableNames: 'parameterIndex argument' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBRemoveParameterRefactoring methodsFor: 'initialize-release'! removeParameter: aString in: aClass selector: aSelector oldSelector := aSelector. class := self classObjectFor: aClass. argument := aString! ! !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'! 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: '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: '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 class instanceVariableNames: ''! !RBRemoveParameterRefactoring class methodsFor: 'instance creation'! model: aRBSmalltalk removeParameter: aString in: aClass selector: aSelector ^(self new) model: aRBSmalltalk; removeParameter: aString in: aClass selector: aSelector; yourself! ! !RBRemoveParameterRefactoring class methodsFor: 'instance creation'! removeParameter: aString in: aClass selector: aSelector ^self new removeParameter: aString in: aClass selector: aSelector! ! RBRefactoringTest subclass: #RBRemoveParameterTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !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:)! ! !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)! ! RBRefactoryVariableChange subclass: #RBRemovePoolVariableChange instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Changes'! !RBRemovePoolVariableChange methodsFor: 'accessing' stamp: 'lr 10/15/2010 08:31'! changeClass: aBehavior super changeClass: aBehavior. isMeta := false! ! !RBRemovePoolVariableChange methodsFor: 'converting' stamp: 'lr 9/8/2011 20:10'! asUndoOperation ^ RBAddPoolVariableChange add: self variable to: self changeClass! ! !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: 'private' stamp: 'lr 9/6/2010 21:31'! changeSymbol ^ #removeSharedPool:! ! RBCompositeRefactoryChange subclass: #RBRenameClassChange instanceVariableNames: 'oldName newName' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Changes'! !RBRenameClassChange methodsFor: '*NautilusRefactoring'! nameToDisplay ^ self printString! ! !RBRenameClassChange methodsFor: '*NautilusRefactoring'! textToDisplay ^ self printString! ! !RBRenameClassChange methodsFor: '*NautilusRefactoring'! whatToDisplayIn: aChangeBrowser | result | result := OrderedCollection with: self. ^ result, (self changes gather: [:e | e changes ])! ! !RBRenameClassChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 17:30'! changeClass ^ Smalltalk globals at: oldName asSymbol ifAbsent: [ Smalltalk globals at: newName asSymbol ]! ! !RBRenameClassChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 17:31'! newName ^ newName! ! !RBRenameClassChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 17:31'! oldName ^ oldName! ! !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: 'comparing' stamp: 'lr 9/6/2010 17:33'! = aRenameClassChange super class = aRenameClassChange class ifFalse: [ ^ false ]. ^oldName = aRenameClassChange oldName and: [ newName = aRenameClassChange newName ]! ! !RBRenameClassChange methodsFor: 'comparing' stamp: 'lr 5/18/2010 20:56'! hash ^ (self class hash bitXor: self oldName hash) bitXor: self newName hash! ! !RBRenameClassChange methodsFor: 'initialize-release'! rename: oldString to: newString oldName := oldString. newName := newString! ! !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 class instanceVariableNames: ''! !RBRenameClassChange class methodsFor: 'instance creation' stamp: 'lr 9/7/2010 19:43'! rename: oldString to: newString ^ self new rename: oldString to: newString; yourself! ! RBClassRefactoring subclass: #RBRenameClassRefactoring instanceVariableNames: 'newName class' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBRenameClassRefactoring methodsFor: 'initialize-release'! className: aName newName: aNewName className := aName asSymbol. class := self model classNamed: className. newName := aNewName asSymbol! ! !RBRenameClassRefactoring methodsFor: 'preconditions'! 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'! 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: 'transforming'! transform self model renameClass: class to: newName around: [self renameReferences]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBRenameClassRefactoring class instanceVariableNames: ''! !RBRenameClassRefactoring class methodsFor: 'instance creation'! model: aRBSmalltalk rename: aClass to: aNewName ^(self new) model: aRBSmalltalk; className: aClass name newName: aNewName; yourself! ! !RBRenameClassRefactoring class methodsFor: 'instance creation'! rename: aClass to: aNewName ^self new className: aClass name newName: aNewName! ! RBRefactoringTest subclass: #RBRenameClassTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !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: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testExistingName self shouldFail: (RBRenameClassRefactoring rename: self class to: #Object)! ! !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'! 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: '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'! 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')! ! RBRenameVariableChange subclass: #RBRenameClassVariableChange instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Changes'! !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'! 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: 'private' stamp: 'lr 9/8/2011 20:10'! removeOldVariable (RBRemoveClassVariableChange remove: oldName from: self changeClass) execute! ! RBVariableRefactoring subclass: #RBRenameClassVariableRefactoring instanceVariableNames: 'newName' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBRenameClassVariableRefactoring methodsFor: 'initialize-release'! rename: aVarName to: aName in: aClass self variable: aVarName class: aClass. newName := aName! ! !RBRenameClassVariableRefactoring methodsFor: 'preconditions'! 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: 'printing'! 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 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: 'transforming'! transform class renameClassVariable: variableName to: newName around: [self renameReferences]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBRenameClassVariableRefactoring class instanceVariableNames: ''! !RBRenameClassVariableRefactoring class methodsFor: 'instance creation'! model: aRBSmalltalk rename: aVarName to: aName in: aClass ^(self new) model: aRBSmalltalk; rename: aVarName to: aName in: aClass; yourself! ! !RBRenameClassVariableRefactoring class methodsFor: 'instance creation'! rename: aVarName to: aName in: aClass ^self new rename: aVarName to: aName in: aClass! ! RBRefactoringTest subclass: #RBRenameClassVariableTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !RBRenameClassVariableTest methodsFor: 'failure tests' stamp: 'lr 9/8/2011 20:11'! testAlreadyExistingName self shouldFail: (RBRenameClassVariableRefactoring rename: #RecursiveSelfRule to: self objectClassVariable in: RBTransformationRuleTest)! ! !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]]')! ! RBRenameVariableChange subclass: #RBRenameInstanceVariableChange instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Changes'! !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'! 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: 'private' stamp: 'lr 9/8/2011 20:10'! removeOldVariable (RBRemoveInstanceVariableChange remove: oldName from: self changeClass) execute! ! RBVariableRefactoring subclass: #RBRenameInstanceVariableRefactoring instanceVariableNames: 'newName' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBRenameInstanceVariableRefactoring methodsFor: 'initialize-release'! rename: aVarName to: aName in: aClass self variable: aVarName class: aClass. newName := aName! ! !RBRenameInstanceVariableRefactoring methodsFor: 'preconditions'! 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: 'printing'! 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 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: 'transforming'! transform class renameInstanceVariable: variableName to: newName around: [self renameReferences]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBRenameInstanceVariableRefactoring class instanceVariableNames: ''! !RBRenameInstanceVariableRefactoring class methodsFor: 'instance creation'! model: aRBSmalltalk rename: aVarName to: aName in: aClass ^(self new) model: aRBSmalltalk; rename: aVarName to: aName in: aClass; yourself! ! !RBRenameInstanceVariableRefactoring class methodsFor: 'instance creation'! rename: aVarName to: aName in: aClass ^self new rename: aVarName to: aName in: aClass! ! RBRefactoringTest subclass: #RBRenameInstanceVariableTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !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.')! ! RBChangeMethodNameRefactoring subclass: #RBRenameMethodRefactoring instanceVariableNames: 'hasPermutedArguments' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBRenameMethodRefactoring methodsFor: 'preconditions'! myConditions ^RBCondition withBlock: [oldSelector numArgs = newSelector numArgs] errorString: newSelector printString , ' doesn''t have the correct number of arguments.'! ! !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: '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'! hasPermutedArguments ^hasPermutedArguments isNil ifTrue: [hasPermutedArguments := super hasPermutedArguments] ifFalse: [hasPermutedArguments]! ! !RBRenameMethodRefactoring methodsFor: 'testing'! implementorsCanBePrimitives ^self hasPermutedArguments not! ! !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 class instanceVariableNames: ''! !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! ! !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! ! RBRefactoringTest subclass: #RBRenameMethodTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !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: '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'! 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')! ! !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: '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'! 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)! ! RBMethodRefactoring subclass: #RBRenameTemporaryRefactoring instanceVariableNames: 'selector interval oldName newName parseTree' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBRenameTemporaryRefactoring methodsFor: 'initialize-release'! 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'! 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 instanceVariableNames: ''! !RBRenameTemporaryRefactoring class methodsFor: 'instance creation'! model: aRBSmalltalk renameTemporaryFrom: anInterval to: newName in: aClass selector: aSelector ^(self new) model: aRBSmalltalk; class: aClass selector: aSelector interval: anInterval newName: newName; yourself! ! !RBRenameTemporaryRefactoring class methodsFor: 'instance creation'! renameTemporaryFrom: anInterval to: newName in: aClass selector: aSelector ^self new class: aClass selector: aSelector interval: anInterval newName: newName! ! RBRefactoringTest subclass: #RBRenameTemporaryTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !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: '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: '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]')! ! RBCompositeRefactoryChange subclass: #RBRenameVariableChange instanceVariableNames: 'className isMeta oldName newName' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Changes'! !RBRenameVariableChange methodsFor: '*NautilusRefactoring'! nameToDisplay ^ 'Rename ', self oldName, ' into ', self newName! ! !RBRenameVariableChange methodsFor: '*NautilusRefactoring'! textToDisplay self printString! ! !RBRenameVariableChange methodsFor: '*NautilusRefactoring'! whatToDisplayIn: aChangeBrowser | result | result := OrderedCollection with: self. ^ result, (self changes gather: [:e | e changes ])! ! !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: 'accessing' stamp: 'lr 9/6/2010 17:32'! changeClass: aBehavior isMeta := aBehavior isMeta. className := isMeta ifTrue: [ aBehavior soleInstance name ] ifFalse: [ aBehavior name ]! ! !RBRenameVariableChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 17:32'! changeClassName ^ className! ! !RBRenameVariableChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 17:32'! changeClassName: aSymbol className := aSymbol. isMeta isNil ifTrue: [ isMeta := false ]! ! !RBRenameVariableChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 17:32'! newName ^ newName! ! !RBRenameVariableChange methodsFor: 'accessing' stamp: 'lr 9/6/2010 17:32'! oldName ^ oldName! ! !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: 'comparing' stamp: 'lr 9/6/2010 17:33'! hash ^ (self class hash bitXor: self oldName hash) bitXor: self newName hash! ! !RBRenameVariableChange methodsFor: 'printing' stamp: 'lr 9/6/2010 17:34'! changeString ^ 'Rename ' , oldName , ' to ' , newName! ! !RBRenameVariableChange methodsFor: 'printing' stamp: 'lr 9/6/2010 21:17'! displayClassName ^ isMeta ifTrue: [ self changeClassName , ' class' ] ifFalse: [ self changeClassName asString ]! ! !RBRenameVariableChange methodsFor: 'printing' stamp: 'lr 9/6/2010 13:55'! printOn: aStream aStream nextPutAll: self displayString! ! !RBRenameVariableChange methodsFor: 'private'! addNewVariable self subclassResponsibility! ! !RBRenameVariableChange methodsFor: 'private'! copyOldValuesToNewVariable self subclassResponsibility! ! !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: 'private' stamp: 'lr 9/6/2010 13:46'! isMeta ^ isMeta! ! !RBRenameVariableChange methodsFor: 'private'! newName: aString newName := aString! ! !RBRenameVariableChange methodsFor: 'private'! oldName: aString oldName := aString! ! !RBRenameVariableChange methodsFor: 'private'! removeOldVariable self subclassResponsibility! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBRenameVariableChange class instanceVariableNames: ''! !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! ! RBParseTreeRule subclass: #RBReplaceRule instanceVariableNames: 'verificationBlock' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Matching'! !RBReplaceRule commentStamp: 'md 8/9/2005 14:56' prior: 0! 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: 'initialize-release'! initialize super initialize. verificationBlock := [:aNode | true]! ! !RBReplaceRule methodsFor: 'matching'! canMatch: aProgramNode ^verificationBlock value: aProgramNode! ! !RBReplaceRule methodsFor: 'matching'! foundMatchFor: aProgramNode self subclassResponsibility! ! !RBReplaceRule methodsFor: 'matching'! replace: aProgramNode with: newNode aProgramNode replaceMethodSource: newNode! ! RBParseTreeLintRule subclass: #RBReturnInEnsureRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBReturnInEnsureRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:27'! category ^ 'Potential Bugs'! ! !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: 'accessing' stamp: 'lr 5/15/2010 17:51'! rationale ^ 'Checks for return statements within ensure: blocks that can have unintended side-effects.'! ! !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 class instanceVariableNames: ''! !RBReturnInEnsureRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBProgramNode subclass: #RBReturnNode instanceVariableNames: 'return value' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Nodes'! !RBReturnNode commentStamp: '' prior: 0! 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: 'accessing'! children ^Array with: value! ! !RBReturnNode methodsFor: 'accessing'! start ^return! ! !RBReturnNode methodsFor: 'accessing'! stop ^value stop! ! !RBReturnNode methodsFor: 'accessing'! value ^value! ! !RBReturnNode methodsFor: 'accessing'! value: valueNode value := valueNode. value parent: self! ! !RBReturnNode methodsFor: 'accessing-token' stamp: 'lr 2/12/2010 19:21'! return ^ return! ! !RBReturnNode methodsFor: 'accessing-token' stamp: 'lr 2/12/2010 19:21'! return: anInteger return := anInteger! ! !RBReturnNode methodsFor: 'comparing'! = anObject self == anObject ifTrue: [^true]. self class = anObject class ifFalse: [^false]. ^self value = anObject value! ! !RBReturnNode methodsFor: 'comparing'! equalTo: anObject withMapping: aDictionary ^self class = anObject class and: [self value equalTo: anObject value withMapping: aDictionary]! ! !RBReturnNode methodsFor: 'comparing'! hash ^self value hash! ! !RBReturnNode methodsFor: 'copying' stamp: 'lr 11/1/2009 22:34'! postCopy super postCopy. self value: self value copy! ! !RBReturnNode methodsFor: 'initialize-release'! return: returnInteger value: aValueNode return := returnInteger. self value: aValueNode! ! !RBReturnNode methodsFor: 'matching' stamp: 'lr 11/24/2009 23:35'! copyInContext: aDictionary ^ self class new value: (self value copyInContext: aDictionary); yourself! ! !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: 'replacing'! replaceNode: aNode withNode: anotherNode value == aNode ifTrue: [self value: anotherNode]! ! !RBReturnNode methodsFor: 'testing'! containsReturn ^true! ! !RBReturnNode methodsFor: 'testing'! isReturn ^true! ! !RBReturnNode methodsFor: 'visitor' stamp: 'CamilloBruni 2/3/2012 15:54'! accept: aProgramNodeVisitor ^aProgramNodeVisitor visitReturnNode: self! ! !RBReturnNode methodsFor: 'visitor'! acceptVisitor: aProgramNodeVisitor ^aProgramNodeVisitor acceptReturnNode: self! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBReturnNode class instanceVariableNames: ''! !RBReturnNode class methodsFor: 'instance creation'! return: returnInteger value: aValueNode ^self new return: returnInteger value: aValueNode! ! !RBReturnNode class methodsFor: 'instance creation'! value: aNode ^self return: nil value: aNode! ! RBBlockLintRule subclass: #RBReturnsBooleanAndOtherRule instanceVariableNames: 'matcher' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBReturnsBooleanAndOtherRule commentStamp: '' prior: 0! See my #rationale.! !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: '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: '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: '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: 'running' stamp: 'lr 8/19/2009 20:54'! checkMethod: aContext | hasBool hasSelf | hasBool := false. hasSelf := aContext parseTree lastIsReturn not. (matcher executeTree: aContext parseTree initialAnswer: Set new) do: [ :each | hasBool := hasBool or: [ (each isLiteral 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 isLiteral and: [ (#(true false) includes: each value) not ]) ] ] ]. (hasSelf and: [ hasBool ]) ifTrue: [ result addClass: aContext selectedClass selector: aContext selector ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBReturnsBooleanAndOtherRule class instanceVariableNames: ''! !RBReturnsBooleanAndOtherRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBParseTreeLintRule subclass: #RBReturnsIfTrueRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBReturnsIfTrueRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:27'! category ^ 'Potential Bugs'! ! !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: '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: '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 class instanceVariableNames: ''! !RBReturnsIfTrueRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBLexicalScope subclass: #RBRootScope instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AST-Semantic-Scope'! !RBRootScope methodsFor: 'initialization' stamp: 'lr 4/27/2010 14:35'! initialize super initialize. self add: RBSelfBinding new. self add: RBSuperBinding new. self add: RBContextBinding new! ! !RBRootScope methodsFor: 'querying' stamp: 'lr 4/27/2010 14:10'! lookup: aString ifAbsent: aBlock ^ bindings at: aString ifAbsent: aBlock! ! !RBRootScope methodsFor: 'testing' stamp: 'lr 5/11/2010 19:12'! isRootScope ^ true! ! Object subclass: #RBScanner instanceVariableNames: 'stream buffer tokenStart currentCharacter characterType classificationTable comments errorBlock' classVariableNames: 'PatternVariableCharacter' poolDictionaries: '' category: 'AST-Core-Parser'! !RBScanner commentStamp: '' prior: 0! 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: 'lr 11/23/2009 14:18'! contents | contentsStream | contentsStream := WriteStream on: (Array new: 50). [ self atEnd ] whileFalse: [ contentsStream nextPut: self next ]. ^ contentsStream contents! ! !RBScanner methodsFor: 'accessing'! errorBlock: aBlock errorBlock := aBlock! ! !RBScanner methodsFor: 'accessing'! flush! ! !RBScanner methodsFor: 'accessing'! getComments | oldComments | comments isEmpty ifTrue: [^nil]. oldComments := comments. comments := OrderedCollection new: 1. ^oldComments! ! !RBScanner methodsFor: 'accessing' stamp: 'lr 11/2/2009 23:37'! 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: 'accessing'! nextPut: anObject "Provide an error notification that the receiver does not implement this message." self shouldNotImplement! ! !RBScanner methodsFor: 'accessing' stamp: 'lr 11/2/2009 23:37'! 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 scannerError: 'Unknown character'! ! !RBScanner methodsFor: 'error handling'! errorBlock ^errorBlock isNil ifTrue: [[:message :position | ]] ifFalse: [errorBlock]! ! !RBScanner methodsFor: 'error handling'! errorPosition ^stream position! ! !RBScanner methodsFor: 'error handling' stamp: 'CamilloBruni 10/31/2012 19:53'! scannerError: aString "Evaluate the block. If it returns raise an error" self errorBlock cull: aString cull: self errorPosition cull: self. self error: aString! ! !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: 'testing' stamp: 'lr 11/2/2009 23:37'! atEnd ^characterType = #eof! ! !RBScanner methodsFor: 'testing'! isReadable ^true! ! !RBScanner methodsFor: 'testing'! isWritable ^false! ! !RBScanner methodsFor: 'private'! 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: 'private' stamp: 'lr 11/2/2009 23:37'! previousStepPosition ^characterType = #eof ifTrue: [stream position] ifFalse: [stream position - 1]! ! !RBScanner methodsFor: 'private'! step stream atEnd ifTrue: [characterType := #eof. ^currentCharacter := nil]. currentCharacter := stream next. characterType := self classify: currentCharacter. ^currentCharacter! ! !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: '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: '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: '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 4/21/2010 16:09'! 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 scannerError: 'Expecting a literal type'! ! !RBScanner methodsFor: 'private-scanning'! scanLiteralArrayToken | token | token := RBLiteralArrayToken value: (String with: $# with: currentCharacter) start: tokenStart. self step. ^token! ! !RBScanner methodsFor: 'private-scanning'! scanLiteralCharacter | token | self step. "$" token := RBLiteralToken value: currentCharacter start: tokenStart stop: stream position. self step. "char" ^token! ! !RBScanner methodsFor: 'private-scanning' stamp: 'lr 3/7/2010 13:18'! scanLiteralString self step. [currentCharacter isNil ifTrue: [self scannerError: 'Unmatched '' in string literal.']. currentCharacter = $' and: [self step ~= $']] whileFalse: [buffer nextPut: currentCharacter. self step]. ^RBLiteralToken value: buffer contents start: tokenStart stop: self previousStepPosition! ! !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 6/4/2010 12:20'! scanNumber | start number stop string | start := stream position. stream position: start - 1. number := SqNumberParser parse: stream. 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: 'lr 11/2/2009 23:37'! scanPatternVariable buffer nextPut: currentCharacter. self step. currentCharacter = ${ ifTrue: [self step. ^RBPatternBlockToken value: '`{' start: tokenStart]. [characterType = #alphabetic] whileFalse: [characterType = #eof ifTrue: [self scannerError: 'Meta variable expected']. buffer nextPut: currentCharacter. self step]. ^self scanIdentifierOrKeyword! ! !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'! scanStringSymbol | literalToken | literalToken := self scanLiteralString. literalToken value: literalToken value asSymbol. ^literalToken! ! !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: 'lr 11/2/2009 23:37'! stripComment | start stop | start := stream position. [self step = $"] whileFalse: [characterType = #eof ifTrue: [self scannerError: 'Unmatched " in comment.']]. stop := stream position. self step. comments add: (start to: stop)! ! !RBScanner methodsFor: 'private-scanning' stamp: 'lr 11/2/2009 23:37'! stripSeparators [[characterType = #separator] whileTrue: [self step]. currentCharacter = $"] whileTrue: [self stripComment]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBScanner class instanceVariableNames: 'classificationTable'! !RBScanner class methodsFor: 'accessing' stamp: 'lr 9/2/2010 11:48'! classificationTable classificationTable isNil ifTrue: [ self initializeClassificationTable ]. ^ classificationTable! ! !RBScanner class methodsFor: 'accessing' stamp: 'lr 11/7/2009 15:31'! patternVariableCharacter ^ PatternVariableCharacter! ! !RBScanner class methodsFor: 'class initialization' stamp: 'lr 12/23/2009 16:40'! initialize self initializeClassificationTable! ! !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: '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: 'class initialization' stamp: 'lr 9/2/2010 11:47'! initializeUnderscore self classificationTable at: $_ asInteger put: (Scanner allowUnderscoreAsAssignment ifTrue: [ #special ] ifFalse: [ #alphabetic ])! ! !RBScanner class methodsFor: 'instance creation' stamp: 'lr 8/30/2010 11:56'! new self initializeUnderscore. ^ super new! ! !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: 'instance creation' stamp: 'lr 11/23/2009 14:50'! on: aStream errorBlock: aBlock | str | str := self new on: aStream. str errorBlock: aBlock; step; stripSeparators. ^str! ! !RBScanner class methodsFor: 'testing'! 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: 'testing'! isVariable: aString | scanner token | scanner := self on: (ReadStream on: aString) errorBlock: [:s :p | ^false]. token := scanner next. token isIdentifier ifFalse: [^false]. (token start = 1 and: [token stop = aString size]) ifFalse: [^false]. ^(aString includes: $.) not! ! RBParseTreeRule subclass: #RBSearchRule instanceVariableNames: 'answerBlock' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Matching'! !RBSearchRule commentStamp: 'md 8/9/2005 14:56' prior: 0! 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'! searchFor: aString thenDo: aBlock self searchString: aString. answerBlock := aBlock! ! !RBSearchRule methodsFor: 'initialize-release'! searchForMethod: aString thenDo: aBlock self methodSearchString: aString. answerBlock := aBlock! ! !RBSearchRule methodsFor: 'initialize-release'! searchForTree: aBRProgramNode thenDo: aBlock searchTree := aBRProgramNode. answerBlock := aBlock! ! !RBSearchRule methodsFor: 'testing'! canMatch: aProgramNode owner answer: (answerBlock value: aProgramNode value: owner answer). ^true! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBSearchRule class instanceVariableNames: ''! !RBSearchRule class methodsFor: 'instance creation'! searchFor: aString thenDo: aBlock ^self new searchFor: aString thenDo: aBlock! ! !RBSearchRule class methodsFor: 'instance creation'! searchForMethod: aString thenDo: aBlock ^self new searchForMethod: aString thenDo: aBlock! ! !RBSearchRule class methodsFor: 'instance creation'! searchForTree: aBRProgramNode thenDo: aBlock ^self new searchForTree: aBRProgramNode thenDo: aBlock! ! TestCase subclass: #RBSearchTest instanceVariableNames: 'classSearches currentSelector' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !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:56'! buildMessageSearch self createSearchWith: '``@receiver -> ``@arg' selectors: #(#superSends #superSends ) inClass: RBTransformationRuleTest! ! !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: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'! buildMethodTitleSearch self createMethodSearchWith: 'initialize | `@temps | `@.Stmts' selectors: #(#initialize ) inClass: RBBasicLintRuleTest! ! !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: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: '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: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: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 10/19/2011 20:10'! currentSelector ^ currentSelector! ! !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: '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]]! ! RBParseTreeLintRule subclass: #RBSearchingLiteralRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBSearchingLiteralRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:28'! category ^ 'Optimization'! ! !RBSearchingLiteralRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Intention revealing'! ! !RBSearchingLiteralRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Uses or''s instead of a searching literal'! ! !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: '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: 'private' stamp: 'lr 2/24/2009 00:26'! isSearchingLiteralExpression: aMessageNode | equalNode expressionNode | equalNode := aMessageNode selector = #| ifTrue: [aMessageNode arguments first] ifFalse: [aMessageNode receiver]. expressionNode := equalNode receiver isLiteral ifTrue: [equalNode arguments first] ifFalse: [equalNode receiver]. ^self isSearchingLiteralExpression: aMessageNode for: expressionNode! ! !RBSearchingLiteralRule methodsFor: 'private' stamp: 'lr 2/24/2009 00:26'! 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 isLiteral]) or: [aSearchingNode arguments first = anObjectNode and: [aSearchingNode receiver isLiteral]]]. 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 class instanceVariableNames: ''! !RBSearchingLiteralRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBBrowserEnvironmentWrapper subclass: #RBSelectorEnvironment instanceVariableNames: 'classSelectors metaClassSelectors' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Environment'! !RBSelectorEnvironment methodsFor: 'accessing' stamp: 'rr 4/19/2004 16:06'! asSelectorEnvironment ^ self! ! !RBSelectorEnvironment methodsFor: 'accessing'! 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: 'accessing'! selectorsForClass: aClass do: aBlock ^(self privateSelectorsForClass: aClass) do: [:each | (aClass includesSelector: each) ifTrue: [aBlock value: each]]! ! !RBSelectorEnvironment methodsFor: 'accessing-classes' stamp: 'lr 2/26/2009 13:35'! classNames ^ IdentitySet new addAll: classSelectors keys; addAll: metaClassSelectors keys; yourself! ! !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: '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: '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: '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: 'initialize-release'! classSelectors: classSelectorDictionary metaClassSelectors: metaClassSelectorDictionary classSelectors := classSelectorDictionary. metaClassSelectors := metaClassSelectorDictionary! ! !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: 'initialize-release'! initialize super initialize. classSelectors := IdentityDictionary new. metaClassSelectors := IdentityDictionary new! ! !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: 'printing'! 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: 'removing'! removeClass: aClass aClass isMeta ifTrue: [metaClassSelectors removeKey: aClass soleInstance name ifAbsent: []] ifFalse: [classSelectors removeKey: aClass name ifAbsent: []]! ! !RBSelectorEnvironment methodsFor: 'removing'! 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: '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: 'testing'! includesClass: aClass ^(self privateSelectorsForClass: aClass) isEmpty not and: [super includesClass: aClass]! ! !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: 'testing'! includesSelector: aSelector in: aClass ^(environment includesSelector: aSelector in: aClass) and: [self privateIncludesSelector: aSelector inClass: aClass]! ! !RBSelectorEnvironment methodsFor: 'testing'! isEmpty ^classSelectors isEmpty and: [metaClassSelectors isEmpty]! ! !RBSelectorEnvironment methodsFor: 'testing' stamp: 'lr 8/7/2009 13:00'! isSelectorEnvironment ^ true! ! !RBSelectorEnvironment methodsFor: 'private'! defaultLabel ^'some methods'! ! !RBSelectorEnvironment methodsFor: 'private'! privateIncludesSelector: aSelector inClass: aClass ^(self privateSelectorsForClass: aClass) includes: aSelector! ! !RBSelectorEnvironment methodsFor: 'private'! privateSelectorsForClass: aClass ^aClass isMeta ifTrue: [metaClassSelectors at: aClass soleInstance name ifAbsent: [#()]] ifFalse: [classSelectors at: aClass name ifAbsent: [#()]]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBSelectorEnvironment class instanceVariableNames: ''! !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: 'lr 9/14/2010 13:05'! implementorsOf: aSelector in: anEnvironment | classDict metaDict selectors | classDict := IdentityDictionary new. metaDict := IdentityDictionary new. selectors := IdentitySet with: aSelector. anEnvironment classesDo: [ :class | ((class includesSelector: 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! ! !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: '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! ! RBSpecialBinding subclass: #RBSelfBinding instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AST-Semantic-Binding'! !RBSelfBinding methodsFor: 'accessing' stamp: 'lr 4/27/2010 14:34'! name ^ 'self'! ! !RBSelfBinding methodsFor: 'testing-type' stamp: 'lr 4/28/2010 09:29'! isSelfBinding ^ true! ! RBVariableNode subclass: #RBSelfNode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Nodes'! !RBSelfNode commentStamp: '' prior: 0! I am a specialized version for the 'self'! !RBSelfNode methodsFor: 'testing' stamp: 'CamilloBruni 12/15/2011 14:33'! isSelf ^ true! ! !RBSelfNode methodsFor: 'visitor' stamp: 'CamilloBruni 12/15/2011 14:17'! accept: aProgramNodeVisitor ^ aProgramNodeVisitor visitSelfNode: self! ! !RBSelfNode methodsFor: 'visitor' stamp: 'CamilloBruni 12/9/2011 14:36'! acceptVisitor: aProgramNodeVisitor ^ aProgramNodeVisitor acceptSelfNode: self! ! Error subclass: #RBSemanticAnnotationMissing instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AST-Semantic-Exceptions'! !RBSemanticAnnotationMissing methodsFor: 'testing' stamp: 'lr 9/2/2010 13:51'! isResumable ^ true! ! RBProgramNodeVisitor subclass: #RBSemanticAnnotator instanceVariableNames: 'scope' classVariableNames: '' poolDictionaries: '' category: 'AST-Semantic'! !RBSemanticAnnotator methodsFor: 'visiting' stamp: 'lr 5/11/2010 22:25'! start: aProgramNode self visitNode: aProgramNode methodNode! ! !RBSemanticAnnotator methodsFor: 'visiting' stamp: 'lr 5/29/2010 20:27'! start: aProgramNode scope: aLexicalScope scope := aLexicalScope. self start: aProgramNode! ! !RBSemanticAnnotator methodsFor: 'visiting' stamp: 'lr 4/27/2010 15:34'! visitArgument: aNode scope add: (RBArgumentBinding node: aNode)! ! !RBSemanticAnnotator methodsFor: 'visitor-dispatching' stamp: 'lr 4/27/2010 15:29'! acceptBlockNode: aNode self scope: aNode with: RBBlockScope during: [ super acceptBlockNode: aNode ]! ! !RBSemanticAnnotator methodsFor: 'visitor-dispatching' stamp: 'lr 4/27/2010 15:27'! acceptMethodNode: aNode self scope: aNode with: RBMethodScope during: [ super acceptMethodNode: aNode ]! ! !RBSemanticAnnotator methodsFor: 'visitor-dispatching' stamp: 'lr 4/27/2010 15:40'! acceptSequenceNode: aNode aNode temporaries do: [ :each | scope add: (RBTemporaryBinding node: each) ]. aNode statements do: [ :each | self visitNode: each ]! ! !RBSemanticAnnotator methodsFor: 'visitor-dispatching' stamp: 'lr 6/7/2010 14:27'! acceptVariableNode: aNode | binding | binding := scope lookup: aNode name ifAbsent: [ self undeclaredVariable: aNode ]. aNode propertyAt: #variableBinding put: binding. binding addAccessor: aNode. aNode isUsed ifTrue: [ binding addReader: aNode ]. aNode isWrite ifTrue: [ binding addWriter: aNode ]! ! !RBSemanticAnnotator methodsFor: 'private' stamp: 'lr 6/7/2010 14:59'! scope: aNode with: aClass during: aBlock scope := aClass owner: scope node: aNode. ^ aBlock ensure: [ scope := scope owner ]! ! !RBSemanticAnnotator methodsFor: 'private' stamp: 'lr 9/2/2010 13:52'! undeclaredVariable: aNode ^ aNode lexicalScope add: (RBUndeclaredVariableNotification node: aNode)! ! TestCase subclass: #RBSemanticTest instanceVariableNames: 'instVar' classVariableNames: 'ClassVar' poolDictionaries: '' category: 'AST-Tests-Semantic'! !RBSemanticTest methodsFor: 'testing' stamp: 'lr 6/4/2010 15:41'! testAccessors | tree binding | tree := self parseExpression: '| var | var'. binding := tree lexicalScope bindingOf: 'var'. self assert: binding node = tree temporaries first. self assert: binding accessors size = 1. self assert: binding accessors first = tree statements first. self assert: binding readers isEmpty. self assert: binding writers isEmpty! ! !RBSemanticTest methodsFor: 'testing' stamp: 'lr 9/2/2010 13:58'! testMissing | tree | tree := self parseExpression: 'a'. self should: [ RBVariableNode new lexicalScope ] raise: RBSemanticAnnotationMissing. self shouldnt: [ tree lexicalScope ] raise: RBSemanticAnnotationMissing. self should: [ RBVariableNode new variableBinding ] raise: RBSemanticAnnotationMissing. self shouldnt: [ tree variableBinding ] raise: RBSemanticAnnotationMissing. self deny: RBVariableNode new hasVariableBinding. self assert: tree hasVariableBinding! ! !RBSemanticTest methodsFor: 'testing' stamp: 'lr 6/4/2010 15:39'! testReadWriter | tree binding | tree := self parseExpression: '| var | ^ var := 1'. binding := tree lexicalScope bindingOf: 'var'. self assert: binding node = tree temporaries first. self assert: binding accessors size = 1. self assert: binding accessors first = tree statements first value variable. self assert: binding readers size = 1. self assert: binding readers first = tree statements first value variable. self assert: binding writers size = 1. self assert: binding writers first = tree statements first value variable.! ! !RBSemanticTest methodsFor: 'testing' stamp: 'lr 6/4/2010 15:40'! testReader | tree binding | tree := self parseExpression: '| var | ^ var'. binding := tree lexicalScope bindingOf: 'var'. self assert: binding node = tree temporaries first. self assert: binding accessors size = 1. self assert: binding accessors first = tree statements first value. self assert: binding readers size = 1. self assert: binding readers first = tree statements first value. self assert: binding writers isEmpty! ! !RBSemanticTest methodsFor: 'testing' stamp: 'lr 6/4/2010 15:40'! testWriter | tree binding | tree := self parseExpression: '| var | var := 1'. binding := tree lexicalScope bindingOf: 'var'. self assert: binding node = tree temporaries first. self assert: binding accessors size = 1. self assert: binding accessors first = tree statements first variable. self assert: binding readers isEmpty. self assert: binding writers size = 1. self assert: binding writers first = tree statements first variable! ! !RBSemanticTest methodsFor: 'testing-bindings' stamp: 'lr 9/10/2010 13:24'! testBlockArgumentBinding | tree binding | tree := self parseExpression: '[ :arg | ]'. binding := tree arguments first variableBinding. self assert: binding isArgumentBinding. self deny: binding isContextBinding. self deny: binding isInstanceBinding. self deny: binding isLiteralBinding. self deny: binding isSelfBinding. self deny: binding isSuperBinding. self deny: binding isTemporaryBinding. self deny: binding isUndeclaredBinding. self deny: binding isAccessed. self assert: binding accessors isEmpty. self deny: binding isRead. self assert: binding readers isEmpty. self deny: binding isWritten. self assert: binding writers isEmpty. self assert: binding isReadonly. self assert: binding name = 'arg'. self assert: binding printString isString. self assert: binding node = tree arguments first. self assert: binding scope = tree lexicalScope! ! !RBSemanticTest methodsFor: 'testing-bindings' stamp: 'lr 9/10/2010 13:24'! testBlockTemporaryBinding | tree binding | tree := self parseExpression: '[ | tmp | ]'. binding := tree body temporaries first variableBinding. self deny: binding isArgumentBinding. self deny: binding isContextBinding. self deny: binding isInstanceBinding. self deny: binding isLiteralBinding. self deny: binding isSelfBinding. self deny: binding isSuperBinding. self assert: binding isTemporaryBinding. self deny: binding isUndeclaredBinding. self deny: binding isAccessed. self assert: binding accessors isEmpty. self deny: binding isRead. self assert: binding readers isEmpty. self deny: binding isWritten. self assert: binding writers isEmpty. self deny: binding isReadonly. self assert: binding name = 'tmp'. self assert: binding printString isString. self assert: binding node = tree body temporaries first. self assert: binding scope = tree lexicalScope! ! !RBSemanticTest methodsFor: 'testing-bindings' stamp: 'lr 9/10/2010 13:24'! testClassVariableBinding | tree binding | tree := self parseExpression: 'ClassVar'. binding := tree variableBinding. self deny: binding isArgumentBinding. self deny: binding isContextBinding. self deny: binding isInstanceBinding. self assert: binding isLiteralBinding. self deny: binding isSelfBinding. self deny: binding isSuperBinding. self deny: binding isTemporaryBinding. self deny: binding isUndeclaredBinding. self assert: binding isAccessed. self deny: binding accessors isEmpty. self deny: binding isRead. self assert: binding readers isEmpty. self deny: binding isWritten. self assert: binding writers isEmpty. self deny: binding isReadonly. self assert: binding name = 'ClassVar'. self assert: binding printString isString. self assert: binding binding = (self class bindingOf: 'ClassVar'). self assert: binding scope notNil! ! !RBSemanticTest methodsFor: 'testing-bindings' stamp: 'lr 9/10/2010 13:24'! testGlobalVariableBinding | tree binding | tree := self parseExpression: self class name. binding := tree variableBinding. self deny: binding isArgumentBinding. self deny: binding isContextBinding. self deny: binding isInstanceBinding. self assert: binding isLiteralBinding. self deny: binding isSelfBinding. self deny: binding isSuperBinding. self deny: binding isTemporaryBinding. self deny: binding isUndeclaredBinding. self assert: binding isAccessed. self deny: binding accessors isEmpty. self deny: binding isRead. self assert: binding readers isEmpty. self deny: binding isWritten. self assert: binding writers isEmpty. self deny: binding isReadonly. self assert: binding name = self class name. self assert: binding printString isString. self assert: binding binding = (self class bindingOf: self class name). self assert: binding scope notNil! ! !RBSemanticTest methodsFor: 'testing-bindings' stamp: 'cwp 4/10/2011 08:43'! testInstanceVariableBinding | tree binding | tree := self parseExpression: 'instVar'. binding := tree variableBinding. self deny: binding isArgumentBinding. self deny: binding isContextBinding. self assert: binding isInstanceBinding. self deny: binding isLiteralBinding. self deny: binding isSelfBinding. self deny: binding isSuperBinding. self deny: binding isTemporaryBinding. self deny: binding isUndeclaredBinding. self assert: binding isAccessed. self deny: binding accessors isEmpty. self deny: binding isRead. self assert: binding readers isEmpty. self deny: binding isWritten. self assert: binding writers isEmpty. self deny: binding isReadonly. self assert: binding name = 'instVar'. self assert: binding printString isString. self assert: binding index = (self class allInstVarNames indexOf: 'instVar'). self assert: binding scope notNil! ! !RBSemanticTest methodsFor: 'testing-bindings' stamp: 'lr 9/10/2010 13:24'! testMethodArgumentBinding | tree binding | tree := self parseMethod: 'foo: arg'. binding := tree arguments first variableBinding. self assert: binding isArgumentBinding. self deny: binding isContextBinding. self deny: binding isInstanceBinding. self deny: binding isLiteralBinding. self deny: binding isSelfBinding. self deny: binding isSuperBinding. self deny: binding isTemporaryBinding. self deny: binding isUndeclaredBinding. self deny: binding isAccessed. self assert: binding accessors isEmpty. self deny: binding isRead. self assert: binding readers isEmpty. self deny: binding isWritten. self assert: binding writers isEmpty. self assert: binding isReadonly. self assert: binding name = 'arg'. self assert: binding printString isString. self assert: binding node = tree arguments first. self assert: binding scope = tree lexicalScope! ! !RBSemanticTest methodsFor: 'testing-bindings' stamp: 'lr 9/10/2010 13:24'! testMethodTemporaryBinding | tree binding | tree := self parseMethod: 'foo | tmp |'. binding := tree body temporaries first variableBinding. self deny: binding isArgumentBinding. self deny: binding isContextBinding. self deny: binding isInstanceBinding. self deny: binding isLiteralBinding. self deny: binding isSelfBinding. self deny: binding isSuperBinding. self assert: binding isTemporaryBinding. self deny: binding isUndeclaredBinding. self deny: binding isAccessed. self assert: binding accessors isEmpty. self deny: binding isRead. self assert: binding readers isEmpty. self deny: binding isWritten. self assert: binding writers isEmpty. self deny: binding isReadonly. self assert: binding name = 'tmp'. self assert: binding printString isString. self assert: binding node = tree body temporaries first. self assert: binding scope = tree lexicalScope! ! !RBSemanticTest methodsFor: 'testing-bindings' stamp: 'lr 9/10/2010 13:24'! testSpecialContextBinding | tree binding | tree := self parseExpression: 'thisContext'. binding := tree variableBinding. self deny: binding isArgumentBinding. self assert: binding isContextBinding. self deny: binding isInstanceBinding. self deny: binding isLiteralBinding. self deny: binding isSelfBinding. self deny: binding isSuperBinding. self deny: binding isTemporaryBinding. self deny: binding isUndeclaredBinding. self assert: binding isAccessed. self deny: binding accessors isEmpty. self deny: binding isRead. self assert: binding readers isEmpty. self deny: binding isWritten. self assert: binding writers isEmpty. self assert: binding isReadonly. self assert: binding name = 'thisContext'. self assert: binding printString isString. self deny: binding scope isNil! ! !RBSemanticTest methodsFor: 'testing-bindings' stamp: 'lr 9/10/2010 13:24'! testSpecialSelfBinding | tree binding | tree := self parseExpression: 'self'. binding := tree variableBinding. self deny: binding isArgumentBinding. self deny: binding isContextBinding. self deny: binding isInstanceBinding. self deny: binding isLiteralBinding. self assert: binding isSelfBinding. self deny: binding isSuperBinding. self deny: binding isTemporaryBinding. self deny: binding isUndeclaredBinding. self assert: binding isAccessed. self deny: binding accessors isEmpty. self deny: binding isRead. self assert: binding readers isEmpty. self deny: binding isWritten. self assert: binding writers isEmpty. self assert: binding isReadonly. self assert: binding name = 'self'. self assert: binding printString isString. self deny: binding scope isNil! ! !RBSemanticTest methodsFor: 'testing-bindings' stamp: 'lr 9/10/2010 13:24'! testSpecialSuperBinding | tree binding | tree := self parseExpression: 'super'. binding := tree variableBinding. self deny: binding isArgumentBinding. self deny: binding isContextBinding. self deny: binding isInstanceBinding. self deny: binding isLiteralBinding. self deny: binding isSelfBinding. self assert: binding isSuperBinding. self deny: binding isTemporaryBinding. self deny: binding isUndeclaredBinding. self assert: binding isAccessed. self deny: binding accessors isEmpty. self deny: binding isRead. self assert: binding readers isEmpty. self deny: binding isWritten. self assert: binding writers isEmpty. self assert: binding isReadonly. self assert: binding name = 'super'. self assert: binding printString isString. self deny: binding scope isNil! ! !RBSemanticTest methodsFor: 'testing-bindings' stamp: 'lr 9/10/2010 13:24'! testUndeclaredBinding | tree binding | tree := self parseExpression: '[ undecl ]'. binding := tree body statements first variableBinding. self deny: binding isArgumentBinding. self deny: binding isContextBinding. self deny: binding isInstanceBinding. self deny: binding isLiteralBinding. self deny: binding isSelfBinding. self deny: binding isSuperBinding. self deny: binding isTemporaryBinding. self assert: binding isUndeclaredBinding. self assert: binding isAccessed. self deny: binding accessors isEmpty. self deny: binding isRead. self assert: binding readers isEmpty. self deny: binding isWritten. self assert: binding writers isEmpty. self deny: binding isReadonly. self assert: binding name = 'undecl'. self assert: binding printString isString. self assert: binding node = tree body statements first. self assert: binding scope notNil! ! !RBSemanticTest methodsFor: 'testing-bindings' stamp: 'lr 9/10/2010 13:24'! testUndeclaredHandled | seen tree binding | seen := false. tree := [ self parseExpression: '[ undecl ]' ] on: RBUndeclaredVariableNotification do: [ :err | seen := true. err resume: (RBLiteralBinding binding: (err node name -> 123)) ]. self assert: seen. binding := tree body statements first variableBinding. self deny: binding isArgumentBinding. self deny: binding isContextBinding. self deny: binding isInstanceBinding. self assert: binding isLiteralBinding. self deny: binding isSelfBinding. self deny: binding isSuperBinding. self deny: binding isTemporaryBinding. self deny: binding isUndeclaredBinding. self assert: binding isAccessed. self deny: binding accessors isEmpty. self deny: binding isRead. self assert: binding readers isEmpty. self deny: binding isWritten. self assert: binding writers isEmpty. self deny: binding isReadonly. self assert: binding name = 'undecl'. self assert: binding printString isString. self assert: binding binding key = 'undecl'. self assert: binding binding value = 123. self assert: binding scope notNil! ! !RBSemanticTest methodsFor: 'testing-fixtures' stamp: 'lr 5/26/2010 18:48'! testCascadeReceiver | tree receiver receiver1 receiver2 | tree := self parseExpression: 'self foo; bar'. receiver := tree receiver. receiver1 := tree messages first receiver. receiver2 := tree messages last receiver. self assert: receiver variableBinding = receiver1 variableBinding. self assert: receiver variableBinding = receiver2 variableBinding! ! !RBSemanticTest methodsFor: 'testing-fixtures' stamp: 'lr 6/7/2010 14:54'! testMultipleScopes | tree block1 variable1 block2 variable2 | tree := self parseExpression: '[ :a | a ]. [ | a | a ]'. block1 := tree statements first. variable1 := block1 arguments first. block2 := tree statements last. variable2 := block2 body temporaries first. self deny: variable1 variableBinding = variable2 variableBinding. self assert: variable1 variableBinding = block1 body statements first variableBinding. self deny: variable2 variableBinding = variable1 variableBinding. self assert: variable2 variableBinding = block2 body statements first variableBinding. self assert: variable1 variableBinding scope = block1 lexicalScope. self assert: variable2 variableBinding scope = block2 lexicalScope! ! !RBSemanticTest methodsFor: 'testing-fixtures' stamp: 'lr 6/7/2010 15:14'! testShadowedVariables | tree variable1 variable2 variable3 variable4 | tree := self parseExpression: '| a | [ :a | a ]. a'. variable1 := tree temporaries first. variable2 := tree statements first arguments first. variable3 := tree statements first body statements first. variable4 := tree statements last. self deny: variable1 variableBinding isShadowing. self assert: variable2 variableBinding isShadowing. self assert: variable3 variableBinding isShadowing. self deny: variable4 variableBinding isShadowing. self assert: variable1 variableBinding = variable4 variableBinding. self deny: variable1 variableBinding = variable3 variableBinding. self deny: variable2 variableBinding = variable4 variableBinding. self assert: variable2 variableBinding = variable3 variableBinding. ! ! !RBSemanticTest methodsFor: 'testing-scopes' stamp: 'lr 5/11/2010 21:56'! testBlockScope | tree scope | tree := self parseExpression: '[ :arg | | tmp | ]'. scope := tree lexicalScope. self assert: scope isBlockScope. self deny: scope isLiteralScope. self deny: scope isMethodScope. self deny: scope isRootScope. self deny: scope isVariableScope. self assert: scope node = tree. self assert: (scope lookup: 'arg') isArgumentBinding. self assert: (scope lookup: 'arg') scope = scope. self assert: (scope lookup: 'arg') name = 'arg'. self assert: (scope lookup: 'tmp') isTemporaryBinding. self assert: (scope lookup: 'tmp') scope = scope. self assert: (scope lookup: 'tmp') name = 'tmp'. self should: [ scope lookup: 'something' ] raise: Error. self assert: (scope lookup: 'something' ifAbsent: [ #nothing ]) = #nothing ! ! !RBSemanticTest methodsFor: 'testing-scopes' stamp: 'lr 6/7/2010 15:00'! testLiteralScope | scope literals | scope := RBLiteralScope owner: RBRootScope new class: RBMessageNode. self deny: scope isBlockScope. self assert: scope isLiteralScope. self deny: scope isMethodScope. self deny: scope isRootScope. self deny: scope isVariableScope. self assert: scope theClass = RBMessageNode. literals := OrderedCollection new. literals addAll: (RBMessageNode allClassVarNames). literals addAll: (RBProgramNode allSubclasses collect: [ :each | each name ]). literals do: [ :name | self assert: (scope lookup: name) isLiteralBinding. self assert: (scope lookup: name) scope = scope. self assert: (scope lookup: name) name = name ]. self assert: (scope lookup: 'self') scope = scope owner. self assert: (scope lookup: 'super') scope = scope owner. self assert: (scope lookup: 'thisContext') scope = scope owner. self should: [ scope lookup: 'something' ] raise: Error. self assert: (scope lookup: 'something' ifAbsent: [ #nothing ]) = #nothing ! ! !RBSemanticTest methodsFor: 'testing-scopes' stamp: 'lr 5/11/2010 21:56'! testMethodScope | tree scope | tree := self parseMethod: 'foo: arg | tmp |'. scope := tree lexicalScope. self deny: scope isBlockScope. self deny: scope isLiteralScope. self assert: scope isMethodScope. self deny: scope isRootScope. self deny: scope isVariableScope. self assert: scope node = tree. self assert: (scope lookup: 'arg') isArgumentBinding. self assert: (scope lookup: 'arg') scope = scope. self assert: (scope lookup: 'arg') name = 'arg'. self assert: (scope lookup: 'tmp') isTemporaryBinding. self assert: (scope lookup: 'tmp') scope = scope. self assert: (scope lookup: 'tmp') name = 'tmp'. self should: [ scope lookup: 'something' ] raise: Error. self assert: (scope lookup: 'something' ifAbsent: [ #nothing ]) = #nothing ! ! !RBSemanticTest methodsFor: 'testing-scopes' stamp: 'lr 5/11/2010 19:20'! testRootScope | scope | scope := RBRootScope new. self deny: scope isBlockScope. self deny: scope isLiteralScope. self deny: scope isMethodScope. self assert: scope isRootScope. self deny: scope isVariableScope. self assert: (scope lookup: 'self') isSelfBinding. self assert: (scope lookup: 'self') scope = scope. self assert: (scope lookup: 'super') isSuperBinding. self assert: (scope lookup: 'super') scope = scope. self assert: (scope lookup: 'thisContext') isContextBinding. self assert: (scope lookup: 'thisContext') scope = scope. self should: [ scope lookup: 'something' ] raise: Error. self assert: (scope lookup: 'something' ifAbsent: [ #nothing ]) = #nothing ! ! !RBSemanticTest methodsFor: 'testing-scopes' stamp: 'lr 6/7/2010 15:00'! testVariableScope | scope | scope := RBVariableScope owner: RBRootScope new class: RBMessageNode. self deny: scope isBlockScope. self deny: scope isLiteralScope. self deny: scope isMethodScope. self deny: scope isRootScope. self assert: scope isVariableScope. self assert: scope theClass = RBMessageNode. RBMessageNode allInstVarNames keysAndValuesDo: [ :index :name | self assert: (scope lookup: name) isInstanceBinding. self assert: (scope lookup: name) scope = scope. self assert: (scope lookup: name) name = name. self assert: (scope lookup: name) index = index ]. self assert: (scope lookup: 'self') scope = scope owner. self assert: (scope lookup: 'super') scope = scope owner. self assert: (scope lookup: 'thisContext') scope = scope owner. self should: [ scope lookup: 'something' ] raise: Error. self assert: (scope lookup: 'something' ifAbsent: [ #nothing ]) = #nothing ! ! !RBSemanticTest methodsFor: 'utilities' stamp: 'lr 5/29/2010 20:33'! parseExpression: aString ^ (RBParser parseExpression: aString) annotateInClass: self class; yourself! ! !RBSemanticTest methodsFor: 'utilities' stamp: 'lr 5/29/2010 20:33'! parseMethod: aString ^ (RBParser parseMethod: aString) annotateInClass: self class; yourself! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBSemanticTest class instanceVariableNames: ''! !RBSemanticTest class methodsFor: 'accessing' stamp: 'lr 4/27/2010 16:17'! packageNamesUnderTest ^ #('AST-Semantic')! ! RBParseTreeLintRule subclass: #RBSendsDeprecatedMethodToGlobalRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBSendsDeprecatedMethodToGlobalRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:28'! category ^ 'Design Flaws'! ! !RBSendsDeprecatedMethodToGlobalRule methodsFor: 'accessing' stamp: 'lr 3/17/2010 17:54'! group ^ 'Pharo bugs'! ! !RBSendsDeprecatedMethodToGlobalRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Sends a deprecated message to a known global'! ! !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 9/4/2010 14:04'! selectors ^ #(deprecated: deprecated:on:in: deprecated:explanation: deprecated:block: greaseDeprecatedApi:details:)! ! !RBSendsDeprecatedMethodToGlobalRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:12'! severity ^ #error! ! !RBSendsDeprecatedMethodToGlobalRule methodsFor: 'initialization' stamp: 'lr 9/8/2011 20:25'! initialize | patterns pattern wellKnownGlobals | super initialize. patterns := OrderedCollection new. wellKnownGlobals := IdentityDictionary new. Smalltalk globals keysAndValuesDo: [ :name :object | (object isBehavior or: [ object isTrait ]) 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 class instanceVariableNames: ''! !RBSendsDeprecatedMethodToGlobalRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBBlockLintRule subclass: #RBSendsDifferentSuperRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBSendsDifferentSuperRule commentStamp: '' prior: 0! 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: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 14:08'! category ^ 'Design Flaws'! ! !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: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Checks for methods whose source sends a different super message.'! ! !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 instanceVariableNames: ''! !RBSendsDifferentSuperRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBParseTreeLintRule subclass: #RBSendsUnknownMessageToGlobalRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBSendsUnknownMessageToGlobalRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:29'! category ^ 'Bugs'! ! !RBSendsUnknownMessageToGlobalRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Bugs'! ! !RBSendsUnknownMessageToGlobalRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Sends unknown message to global'! ! !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 5/15/2010 15:04'! severity ^ #error! ! !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 class instanceVariableNames: ''! !RBSendsUnknownMessageToGlobalRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBBlockLintRule subclass: #RBSentNotImplementedRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBSentNotImplementedRule commentStamp: '' prior: 0! 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'! group ^ 'Bugs'! ! !RBSentNotImplementedRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Messages sent but not implemented'! ! !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 5/15/2010 15:04'! severity ^ #error! ! !RBSentNotImplementedRule methodsFor: 'running' stamp: 'lr 2/23/2009 23:17'! 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 canUnderstand: each) not ] ifNone: [ nil ] ] ]. message notNil ifTrue: [ result addSearchString: message. result addClass: aContext selectedClass selector: aContext selector ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBSentNotImplementedRule class instanceVariableNames: ''! !RBSentNotImplementedRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBProgramNode subclass: #RBSequenceNode instanceVariableNames: 'leftBar rightBar statements periods temporaries' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Nodes'! !RBSequenceNode commentStamp: '' prior: 0! 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' 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: 'accessing'! allDefinedVariables ^(self temporaryNames asOrderedCollection) addAll: super allDefinedVariables; yourself! ! !RBSequenceNode methodsFor: 'accessing'! allTemporaryVariables ^(self temporaryNames asOrderedCollection) addAll: super allTemporaryVariables; yourself! ! !RBSequenceNode methodsFor: 'accessing'! children ^(OrderedCollection new) addAll: self temporaries; addAll: self statements; yourself! ! !RBSequenceNode methodsFor: 'accessing'! 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: 'accessing'! removeTemporaryNamed: aName temporaries := temporaries reject: [:each | each name = aName]! ! !RBSequenceNode methodsFor: 'accessing'! start ^leftBar isNil ifTrue: [statements isEmpty ifTrue: [1] ifFalse: [statements first start]] ifFalse: [leftBar]! ! !RBSequenceNode methodsFor: 'accessing'! statements ^statements! ! !RBSequenceNode methodsFor: 'accessing'! statements: stmtCollection statements := stmtCollection. statements do: [:each | each parent: self]! ! !RBSequenceNode methodsFor: 'accessing'! stop ^(periods isEmpty ifTrue: [0] ifFalse: [periods last]) max: (statements isEmpty ifTrue: [0] ifFalse: [statements last stop])! ! !RBSequenceNode methodsFor: 'accessing'! temporaries ^temporaries! ! !RBSequenceNode methodsFor: 'accessing'! temporaries: tempCollection temporaries := tempCollection. temporaries do: [:each | each parent: self]! ! !RBSequenceNode methodsFor: 'accessing'! temporaryNames ^temporaries collect: [:each | each name]! ! !RBSequenceNode methodsFor: 'accessing'! temporaryVariables ^(super temporaryVariables asOrderedCollection) addAll: self temporaryNames; yourself! ! !RBSequenceNode methodsFor: 'accessing-token' stamp: 'lr 1/11/2010 15:42'! leftBar ^ leftBar! ! !RBSequenceNode methodsFor: 'accessing-token' stamp: 'lr 2/12/2010 19:22'! leftBar: anInteger leftBar := anInteger! ! !RBSequenceNode methodsFor: 'accessing-token' stamp: 'lr 11/1/2009 20:30'! periods ^ periods! ! !RBSequenceNode methodsFor: 'accessing-token' stamp: 'lr 2/12/2010 19:21'! periods: anArray periods := anArray! ! !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: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: '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: 'adding nodes' stamp: 'lr 1/4/2012 21:42'! addNodeFirst: aNode aNode parent: self. statements := statements asOrderedCollection addFirst: aNode; yourself. ^ aNode! ! !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:44'! addNodes: aCollection before: anotherNode aCollection do: [ :each | self addNode: each before: anotherNode ]. ^ aCollection! ! !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: '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: 'adding nodes' stamp: 'lr 1/4/2012 21:45'! addTemporariesNamed: aCollection ^ aCollection collect: [ :each | self addTemporaryNamed: each ]! ! !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: 'comparing'! = 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: '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: 'comparing' stamp: 'lr 3/7/2010 13:48'! hash ^ (self hashForCollection: self temporaries) bitXor: (self hashForCollection: self statements)! ! !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: 'initialize-release' stamp: 'lr 2/19/2010 14:44'! initialize super initialize. periods := statements := temporaries := #()! ! !RBSequenceNode methodsFor: 'initialize-release'! leftBar: leftInteger temporaries: variableNodes rightBar: rightInteger leftBar := leftInteger. self temporaries: variableNodes. rightBar := rightInteger! ! !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: '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: 'querying'! bestNodeFor: anInterval | node | node := super bestNodeFor: anInterval. node == self ifTrue: [(temporaries isEmpty and: [statements size == 1]) ifTrue: [^statements first]]. ^node! ! !RBSequenceNode methodsFor: 'querying'! whichNodeIsContainedBy: anInterval | node | node := super whichNodeIsContainedBy: anInterval. node == self ifTrue: [(temporaries isEmpty and: [statements size == 1]) ifTrue: [^statements first]]. ^node! ! !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'! removeNode: aNode self replaceNode: aNode withNodes: #()! ! !RBSequenceNode methodsFor: 'replacing'! 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: 'replacing'! 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: 'testing'! defines: aName ^temporaries anySatisfy: [:each | each name = aName]! ! !RBSequenceNode methodsFor: 'testing'! directlyUses: aNode ^false! ! !RBSequenceNode methodsFor: 'testing'! 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: 'testing'! isSequence ^true! ! !RBSequenceNode methodsFor: 'testing'! lastIsReturn ^statements notEmpty and: [statements last lastIsReturn]! ! !RBSequenceNode methodsFor: 'testing'! references: aVariableName ^statements anySatisfy: [:each | each references: aVariableName]! ! !RBSequenceNode methodsFor: 'testing'! uses: aNode statements isEmpty ifTrue: [^false]. aNode == statements last ifFalse: [^false]. ^self isUsed! ! !RBSequenceNode methodsFor: 'visitor' stamp: 'CamilloBruni 2/3/2012 15:55'! accept: aProgramNodeVisitor ^aProgramNodeVisitor visitSequenceNode: self! ! !RBSequenceNode methodsFor: 'visitor'! acceptVisitor: aProgramNodeVisitor ^aProgramNodeVisitor acceptSequenceNode: self! ! !RBSequenceNode methodsFor: 'private'! 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 class instanceVariableNames: ''! !RBSequenceNode class methodsFor: 'instance creation'! leftBar: leftInteger temporaries: variableNodes rightBar: rightInteger ^(self new) leftBar: leftInteger temporaries: variableNodes rightBar: rightInteger; yourself! ! !RBSequenceNode class methodsFor: 'instance creation'! statements: statementNodes ^self temporaries: #() statements: statementNodes! ! !RBSequenceNode class methodsFor: 'instance creation'! temporaries: variableNodes statements: statementNodes ^(self new) temporaries: variableNodes; statements: statementNodes; yourself! ! RBAssignmentToken subclass: #RBShortAssignmentToken instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Tokens'! !RBShortAssignmentToken methodsFor: 'private' stamp: 'lr 11/1/2009 20:45'! length ^ 1! ! RBParseTreeLintRule subclass: #RBSizeCheckRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBSizeCheckRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:30'! category ^ 'Optimization'! ! !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: '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: '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: 'private' stamp: 'lr 2/24/2009 20:47'! selectors ^ #( collect: do: reject: select: )! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBSizeCheckRule class instanceVariableNames: ''! !RBSizeCheckRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! Object subclass: #RBSmallDictionary instanceVariableNames: 'keys values tally' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Matching'! !RBSmallDictionary commentStamp: 'md 4/1/2007 12:34' prior: 0! RBSmallDictionary is a special dictionary optimized for small collections. In addition to the normal dictionary protocol, it also supports an #empty message which "empties" the collection but may hang on to the original elements (so it could collect garbage). Without #empty we would either need to create a new dictionary or explicitly remove everything from the dictionary. Both of these take more time and #empty. Instance Variables: array array of keys (we don't use Associations for our key value pairs) tally the size of the dictionary values array of our values ! !RBSmallDictionary methodsFor: 'accessing' stamp: 'lr 12/29/2009 12:16'! at: aKey "Answer the value associated with aKey. Raise an exception, if no such key is defined." ^ self at: aKey ifAbsent: [ self errorKeyNotFound ]! ! !RBSmallDictionary methodsFor: 'accessing' stamp: 'lr 12/29/2009 12:05'! at: aKey ifAbsent: aBlock "Answer the value associated with aKey. Evaluate aBlock, if no such key is defined." | index | index := self findIndexFor: aKey. ^ index = 0 ifFalse: [ values at: index ] ifTrue: [ aBlock value ]! ! !RBSmallDictionary methodsFor: 'accessing' stamp: 'lr 12/29/2009 12:05'! at: aKey ifAbsentPut: aBlock "Answer the value associated with aKey. Evaluate aBlock, if no such key is defined and store the return value." | index | index := self findIndexFor: aKey. ^ index = 0 ifFalse: [ values at: index ] ifTrue: [ self privateAt: aKey put: aBlock value ]! ! !RBSmallDictionary methodsFor: 'accessing' stamp: 'lr 12/29/2009 12:06'! at: aKey put: aValue "Set the value of aKey to be aValue." | index | index := self findIndexFor: aKey. ^ index = 0 ifFalse: [ values at: index put: aValue ] ifTrue: [ self privateAt: aKey put: aValue ]! ! !RBSmallDictionary methodsFor: 'accessing' stamp: 'lr 12/29/2009 12:27'! empty tally := 0! ! !RBSmallDictionary methodsFor: 'accessing' stamp: 'lr 12/29/2009 12:27'! keys ^ keys copyFrom: 1 to: tally! ! !RBSmallDictionary methodsFor: 'accessing' stamp: 'lr 12/29/2009 12:27'! size ^ tally! ! !RBSmallDictionary methodsFor: 'accessing' stamp: 'lr 12/29/2009 12:27'! values ^ values copyFrom: 1 to: tally! ! !RBSmallDictionary methodsFor: 'copying' stamp: 'lr 12/29/2009 12:10'! postCopy super postCopy. keys := keys copy. values := values copy! ! !RBSmallDictionary methodsFor: 'enumerating' stamp: 'lr 12/29/2009 12:27'! keysAndValuesDo: aBlock 1 to: tally do: [ :index | aBlock value: (keys at: index) value: (values at: index) ]! ! !RBSmallDictionary methodsFor: 'enumerating' stamp: 'lr 12/29/2009 12:27'! keysDo: aBlock 1 to: tally do: [ :each | aBlock value: (keys at: each) ]! ! !RBSmallDictionary methodsFor: 'enumerating' stamp: 'lr 12/29/2009 12:27'! valuesDo: aBlock 1 to: tally do: [ :index | aBlock value: (values at: index) ]! ! !RBSmallDictionary methodsFor: 'initialization' stamp: 'lr 12/29/2009 12:27'! initialize: anInteger tally := 0. keys := Array new: anInteger. values := Array new: anInteger! ! !RBSmallDictionary methodsFor: 'removing' stamp: 'lr 12/29/2009 12:41'! removeKey: aKey "Remove aKey from the receiver, raise an exception if the element is missing." ^ self removeKey: aKey ifAbsent: [ self errorKeyNotFound ]! ! !RBSmallDictionary methodsFor: 'removing' stamp: 'lr 12/29/2009 12:27'! removeKey: aKey ifAbsent: aBlock "Remove aKey from the receiver, evaluate aBlock if the element is missing." | index value | index := self findIndexFor: aKey. index = 0 ifTrue: [ ^ aBlock value ]. value := values at: index. index to: tally - 1 do: [ :i | keys at: i put: (keys at: i + 1). values at: i put: (values at: i + 1) ]. keys at: tally put: nil. values at: tally put: nil. tally := tally - 1. ^ value! ! !RBSmallDictionary methodsFor: 'testing' stamp: 'lr 12/29/2009 12:13'! includesKey: aKey "Answer whether the receiver has a key equal to aKey." ^ (self findIndexFor: aKey) ~= 0! ! !RBSmallDictionary methodsFor: 'testing' stamp: 'lr 12/29/2009 12:27'! isEmpty ^ tally = 0! ! !RBSmallDictionary methodsFor: 'private' stamp: 'lr 12/29/2009 12:16'! errorKeyNotFound self error: 'Key not found'! ! !RBSmallDictionary methodsFor: 'private' stamp: 'lr 12/29/2009 12:27'! findIndexFor: aKey 1 to: tally do: [ :index | (keys at: index) = aKey ifTrue: [ ^ index ] ]. ^ 0! ! !RBSmallDictionary methodsFor: 'private' stamp: 'lr 12/29/2009 12:27'! grow | newKeys newValues | newKeys := Array new: 2 * tally. newValues := Array new: 2 * tally. 1 to: tally do: [ :index | newKeys at: index put: (keys at: index). newValues at: index put: (values at: index) ]. keys := newKeys. values := newValues! ! !RBSmallDictionary methodsFor: 'private' stamp: 'lr 12/29/2009 12:27'! privateAt: aKey put: aValue tally = keys size ifTrue: [ self grow ]. keys at: (tally := tally + 1) put: aKey. ^ values at: tally put: aValue! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBSmallDictionary class instanceVariableNames: ''! !RBSmallDictionary class methodsFor: 'instance creation' stamp: 'lr 12/29/2009 12:14'! new ^ self new: 2! ! !RBSmallDictionary class methodsFor: 'instance creation' stamp: 'lr 12/29/2009 12:14'! new: anInteger ^ self basicNew initialize: anInteger! ! TestCase subclass: #RBSmallDictionaryTest instanceVariableNames: 'dict' classVariableNames: '' poolDictionaries: '' category: 'AST-Tests-Core'! !RBSmallDictionaryTest methodsFor: 'running' stamp: 'lr 12/29/2009 12:54'! setUp super setUp. dict := RBSmallDictionary new! ! !RBSmallDictionaryTest methodsFor: 'testing' stamp: 'lr 12/29/2009 12:56'! testAtError dict at: #a put: 1. self shouldnt: [ dict at: #a ] raise: Error. self should: [ dict at: #b ] raise: Error! ! !RBSmallDictionaryTest methodsFor: 'testing' stamp: 'lr 12/29/2009 12:56'! testAtIfAbsent dict at: #a put: 666. self assert: (dict at: #a ifAbsent: [ nil ]) = 666. self assert: (dict at: #b ifAbsent: [ nil ]) isNil! ! !RBSmallDictionaryTest methodsFor: 'testing' stamp: 'lr 12/29/2009 13:02'! testAtPut self assert: (dict at: #a put: 3) = 3. self assert: (dict at: #a) = 3. self assert: (dict at: #a put: 4) = 4. self assert: (dict at: #a) = 4. self assert: (dict at: nil put: 5) = 5. self assert: (dict at: nil) = 5 ! ! !RBSmallDictionaryTest methodsFor: 'testing' stamp: 'lr 12/29/2009 13:08'! testCopy | copy | dict at: 'France' put: 'Paris'. dict at: 'Italie' put: 'Rome'. copy := dict copy. copy at: 'Germany' put: 'Berlin'. dict at: 'Switzerland' put: 'Bern'. self assert: copy size = 3. self assert: (copy includesKey: 'Germany'). self deny: (copy includesKey: 'Switzerland'). self assert: dict size = 3. self assert: (dict includesKey: 'Switzerland'). self deny: (dict includesKey: 'Germany') ! ! !RBSmallDictionaryTest methodsFor: 'testing' stamp: 'lr 12/29/2009 13:01'! testEmpty dict at: 'France' put: 'Paris'. dict at: 'Italie' put: 'Rome'. dict empty. self assert: dict isEmpty. self deny: (dict includesKey: 'France'). self deny: (dict includesKey: 'Italie'). self assert: dict keys isEmpty. self assert: dict values isEmpty! ! !RBSmallDictionaryTest methodsFor: 'testing' stamp: 'lr 12/29/2009 12:56'! testIncludesKey dict at: 'Italie' put: nil. dict at: 'France' put: 'Paris'. self assert: (dict includesKey: 'Italie'). self assert: (dict includesKey: 'France'). self deny: (dict includesKey: 'Switzerland')! ! !RBSmallDictionaryTest methodsFor: 'testing' stamp: 'lr 12/29/2009 13:05'! testKeys dict at: 'France' put: 'Paris'. dict at: 'Italie' put: 'Rome'. self assert: dict keys = #('France' 'Italie')! ! !RBSmallDictionaryTest methodsFor: 'testing' stamp: 'lr 12/29/2009 13:04'! testKeysAndValuesDo | keys values | dict at: 'France' put: 'Paris'. dict at: 'Italie' put: 'Rome'. keys := OrderedCollection new. values := OrderedCollection new. dict keysAndValuesDo: [ :key :value | keys add: key. values add: value ]. self assert: keys asArray = #('France' 'Italie'). self assert: values asArray = #('Paris' 'Rome')! ! !RBSmallDictionaryTest methodsFor: 'testing' stamp: 'lr 12/29/2009 13:05'! testKeysDo | keys | dict at: 'France' put: 'Paris'. dict at: 'Italie' put: 'Rome'. keys := OrderedCollection new. dict keysDo: [ :each | keys add: each ]. self assert: keys asArray = #('France' 'Italie')! ! !RBSmallDictionaryTest methodsFor: 'testing' stamp: 'lr 12/29/2009 12:59'! testRemoveKey dict at: #a put: 1. dict at: #b put: 2. self assert: (dict keys size) = 2. self assert: (dict removeKey: #a) = 1. self assert: (dict keys size) = 1. self assert: (dict at: #a ifAbsent: [ true ]). self assert: (dict at: #b) = 2. self should: [ dict removeKey: #a ] raise: Error! ! !RBSmallDictionaryTest methodsFor: 'testing' stamp: 'lr 12/29/2009 13:00'! testRemoveKeyIfAbsent dict at: #a put: 1. dict at: #b put: 2. self assert: (dict keys size) = 2. self assert: (dict removeKey: #a ifAbsent: [ false ]) = 1. self assert: (dict keys size) = 1. self assert: (dict at: #a ifAbsent: [ true ]). self assert: (dict at: #b) = 2. self assert: (dict removeKey: #a ifAbsent: [ true ])! ! !RBSmallDictionaryTest methodsFor: 'testing' stamp: 'lr 12/29/2009 13:05'! testValues dict at: 'France' put: 'Paris'. dict at: 'Italie' put: 'Rome'. self assert: dict values = #('Paris' 'Rome')! ! !RBSmallDictionaryTest methodsFor: 'testing' stamp: 'lr 12/29/2009 13:04'! testValuesDo | values | dict at: 'France' put: 'Paris'. dict at: 'Italie' put: 'Rome'. values := OrderedCollection new. dict valuesDo: [ :each | values add: each ].. self assert: values asArray = #('Paris' 'Rome')! ! Object subclass: #RBSmalllintChecker instanceVariableNames: 'rule environment context methodBlock' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics'! !RBSmalllintChecker methodsFor: 'accessing'! context: aSmalllintContext context := aSmalllintContext! ! !RBSmalllintChecker methodsFor: 'accessing'! environment: aBrowserEnvironment environment := aBrowserEnvironment! ! !RBSmalllintChecker methodsFor: 'accessing'! methodBlock: aBlock methodBlock := aBlock! ! !RBSmalllintChecker methodsFor: 'accessing'! rule: aLintRule rule := aLintRule! ! !RBSmalllintChecker methodsFor: 'actions' stamp: 'lr 1/21/2010 23:43'! run rule resetResult. environment classesDo: [ :class | class isTrait ifFalse: [ self checkClass: class. self checkMethodsForClass: class ] ]! ! !RBSmalllintChecker methodsFor: 'initialize-release' stamp: 'lr 9/8/2011 20:32'! initialize methodBlock := []. environment := RBSelectorEnvironment new. context := RBSmalllintContext newNoCache! ! !RBSmalllintChecker methodsFor: 'initialize-release'! release context release. super release! ! !RBSmalllintChecker methodsFor: 'private'! checkClass: aClass context selectedClass: aClass. (environment definesClass: aClass) ifTrue: [rule checkClass: context]! ! !RBSmalllintChecker methodsFor: 'private'! checkMethodsForClass: aClass ^environment selectorsForClass: aClass do: [:each | context selector: each. rule checkMethod: context. methodBlock value]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBSmalllintChecker class instanceVariableNames: ''! !RBSmalllintChecker class methodsFor: 'instance creation' stamp: 'lr 9/8/2011 20:15'! newWithContext ^(self new) context: RBSmalllintContext new; yourself! ! !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'! runRule: aLintRule onEnvironment: aBrowserEnvironment (self new) rule: aLintRule; environment: aBrowserEnvironment; run. ^aLintRule! ! Object subclass: #RBSmalllintContext instanceVariableNames: 'class selector parseTree literals literalSemaphore literalProcess selectors compiledMethod selfMessages superMessages messages' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics'! !RBSmalllintContext methodsFor: 'accessing'! compiledMethod ^compiledMethod notNil ifTrue: [compiledMethod] ifFalse: [compiledMethod := class compiledMethodAt: selector]! ! !RBSmalllintContext methodsFor: 'accessing'! instVarNames ^self selectedClass allInstVarNames! ! !RBSmalllintContext methodsFor: 'accessing'! literals literalSemaphore isNil ifTrue: [literals isNil ifTrue: [self computeLiterals. literalSemaphore wait]] ifFalse: [literalSemaphore wait]. ^literals! ! !RBSmalllintContext methodsFor: 'accessing'! messages messages isNil ifTrue: [self computeMessages]. ^messages! ! !RBSmalllintContext methodsFor: 'accessing'! parseTree ^parseTree isNil ifTrue: [parseTree := self buildParseTree] ifFalse: [parseTree]! ! !RBSmalllintContext methodsFor: 'accessing'! protocol ^self selectedClass whichCategoryIncludesSelector: self selector! ! !RBSmalllintContext methodsFor: 'accessing'! protocols ^Array with: self protocol! ! !RBSmalllintContext methodsFor: 'accessing'! selectedClass ^class! ! !RBSmalllintContext methodsFor: 'accessing'! selectedClass: anObject class := anObject. self selector: nil! ! !RBSmalllintContext methodsFor: 'accessing'! selector ^selector! ! !RBSmalllintContext methodsFor: 'accessing'! selector: anObject selector := anObject. parseTree := compiledMethod := selfMessages := superMessages := messages := nil! ! !RBSmalllintContext methodsFor: 'accessing'! selectors literalSemaphore isNil ifTrue: [selectors isNil ifTrue: [self computeLiterals. literalSemaphore wait]] ifFalse: [literalSemaphore wait]. ^selectors! ! !RBSmalllintContext methodsFor: 'accessing'! selfMessages selfMessages isNil ifTrue: [self computeMessages]. ^selfMessages! ! !RBSmalllintContext methodsFor: 'accessing' stamp: 'nk 2/26/2005 10:19'! sourceCode ^self selectedClass sourceCodeAt: self selector ifAbsent: [ '' ].! ! !RBSmalllintContext methodsFor: 'accessing'! superMessages superMessages isNil ifTrue: [self computeMessages]. ^superMessages! ! !RBSmalllintContext methodsFor: 'initialize-release'! initialize self computeLiterals! ! !RBSmalllintContext methodsFor: 'initialize-release'! release literalProcess notNil ifTrue: [literalProcess terminate]. super release! ! !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: 'testing'! implements: aSelector ^self selectors includes: aSelector! ! !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: '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: 'testing'! uses: anObject ^self literals includes: anObject! ! !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: 'private'! buildParseTree | tree | tree := self selectedClass parseTreeFor: self selector. tree isNil ifTrue: [^RBParser parseMethod: 'method']. ^tree! ! !RBSmalllintContext methodsFor: 'private'! 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'! computeLiterals literalSemaphore := Semaphore new. literalProcess := [self primitiveComputeLiterals] fork! ! !RBSmalllintContext methodsFor: 'private'! computeLiteralsForClass: aClass (selectors addAll: aClass selectors) do: [:sel | self computeLiteralsForSelector: sel in: aClass. Processor yield]! ! !RBSmalllintContext methodsFor: 'private'! computeLiteralsForSelector: aSelector in: aClass | method | method := aClass compiledMethodAt: aSelector ifAbsent: [nil]. method isNil ifTrue: [^self]. self addLiteralsFor: method! ! !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: '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: 'private'! signalProcesses: aSemaphore aSemaphore isNil ifTrue: [^self]. [aSemaphore isEmpty] whileFalse: [aSemaphore signal]! ! !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 class instanceVariableNames: ''! !RBSmalllintContext class methodsFor: 'instance creation'! newNoCache ^self basicNew! ! TestCase subclass: #RBSmalllintTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Critics'! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:13'! testAsOrderedCollectionNotNeeded 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'! testAssignmentInIfTrue 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:13'! testAtIfAbsent self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'CamilloBruni 1/15/2013 23:56'! testBadMessage self ruleFor: self currentSelector plusSelectors: #(codeCruftLeftInMethods collectionMessagesToExternalObject)! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testBooleanPrecedence 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'! testCollectSelectNotUsed self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testCollectionMessagesToExternalObject 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:15'! testConsistencyCheck self ruleFor: self currentSelector plusSelectors: #(#noIsNil: )! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testContains self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testDetectContains 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'! testEndTrueFalse self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testEqualNotUsed self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testEqualsTrue self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 9/8/2011 20:32'! 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:15'! testExtraBlock self ruleFor: self currentSelector plusSelectors: #(#testMethod1 )! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testFileBlocks self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 9/7/2010 20:58'! testFloatEqualityComparison 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'! testGuardingClause 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:14'! testIfTrueReturns 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:14'! testLiteralArrayCharacters self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 9/7/2010 20:58'! testLiteralArrayContainsComma self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:12'! testLongMethods self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testMinMax self ruleFor: self currentSelector! ! !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'! testModifiesCollection self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 9/7/2010 20:56'! testOnlyReadOrWrittenTemporary self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testPrecedence self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:12'! testRefersToClass self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testReturnInEnsure self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:12'! testReturnsBooleanAndOther 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'! testSearchingLiteral 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'! testSizeCheck self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testStringConcatenation self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:12'! testTempVarOverridesInstVar 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'! testTempsReadBeforeWritten self ruleFor: self currentSelector plusSelectors: #(#inlineTemporary #noMoveDefinition #tempsReadBeforeWritten #equalNotUsed #fileBlocks #referencesConditionFor:)! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testThreeElementPoint 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'! testToDoCollect self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testToDoWithIncrement self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 9/7/2010 20:41'! testUnclassifiedMethods self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 9/7/2010 20:50'! testUncommonMessageSend 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:14'! testUsesAdd 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'! testWhileTrue self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'tests' stamp: 'lr 2/26/2009 16:14'! testYourselfNotUsed self ruleFor: self currentSelector! ! !RBSmalllintTest methodsFor: 'private'! checkRule: aLintRule isEqualTo: anEnvironment | returnedEnvironment | returnedEnvironment := aLintRule result. self compare: returnedEnvironment to: anEnvironment. self compare: anEnvironment to: returnedEnvironment! ! !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: 'private' stamp: 'lr 12/24/2008 16:50'! currentSelector ^ testSelector! ! !RBSmalllintTest methodsFor: 'private' stamp: 'lr 2/26/2009 16:10'! ruleFor: aSelector self ruleFor: aSelector plusSelectors: #()! ! !RBSmalllintTest methodsFor: 'private' stamp: 'lr 9/8/2011 20:32'! 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: (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 methodsFor: 'private' stamp: 'lr 9/8/2011 20:32'! smalllintTestEnvironment | classEnvironment | classEnvironment := RBClassEnvironment new. classEnvironment addClass: RBSmalllintTestObject. ^ classEnvironment! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBSmalllintTest class instanceVariableNames: ''! !RBSmalllintTest class methodsFor: 'accessing' stamp: 'lr 9/5/2010 10:48'! packageNamesUnderTest ^ #('Refactoring-Critics')! ! Object subclass: #RBSmalllintTestObject instanceVariableNames: 'temporaryVariable' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Critics'! !RBSmalllintTestObject methodsFor: 'as yet unclassified' stamp: 'lr 9/7/2010 20:41'! unclassifiedMethods "intentionally unclassified method"! ! !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:12'! assignmentInBlock [^self printString] ensure: [self close]! ! !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 21:06'! assignmentWithoutEffect | a | a := 1. a := 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'! badMessage self become: String new! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! booleanPrecedence ^true & 4 = 45! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:47'! codeCruftLeftInMethods self halt! ! !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'! collectionMessagesToExternalObject self someObject collection remove: 10! ! !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:12'! consistencyCheck ^(1 to: 10) at: 1! ! !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'! detectContains ^(1 to: 10) do: [:each | each > 2 ifTrue: [^each]]! ! !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'! endTrueFalse self isVariable ifTrue: [self printString. self isVariable printString] ifFalse: [self printString. ^4]! ! !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'! equalsTrue ^true == self! ! !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'! fileBlocks | file | ^ [file := 'asdf' asFilename readStream. file contents] ensure: [file close]! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:59'! floatEqualityComparison ^ 1.0 = 1! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! fullBlocks ^[thisContext]! ! !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'! ifTrueReturns self isSymbol ifFalse: [^true]. ^false! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! isLiteral ^false! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! justSendsSuper super justSendsSuper! ! !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:58'! literalArrayContainsComma ^ #(#,)! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! 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]! ! !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'! 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:12'! noIsNil: arg ^arg = nil or: [ arg ~= nil ]! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:56'! onlyReadOrWrittenTemporary | a | a := 1! ! !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:17'! refersToClass ^ RBSmalllintTestObject! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! release self printString! ! !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'! returnsBooleanAndOther self isVariable ifTrue: [^false]. self printString! ! !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:12'! sendsDifferentSuper super printString! ! !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'! stringConcatenation | string | string := '' yourself. (1 to: 10) do: [:i | string := string , i printString]. ^string! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! tempVarOverridesInstVar | temporaryVariable | temporaryVariable := 4. ^temporaryVariable! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 21:03'! temporaryVariableCapitalization | Capital | Capital := 'Bern'. ^ Capital! ! !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'! threeElementPoint ^5 @ 5 + 6 @ 6! ! !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: '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'! toDoWithIncrement | counter | counter := 0. 1 to: 10 by: 2 do: [:i | counter := counter + 2]. ^counter! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:55'! uncommonMessageSend true false! ! !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'! usesAdd ^(1 to: 10) asOrderedCollection addAll: (11 to: 20)! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:43'! usesTrue ^ True! ! !RBSmalllintTestObject methodsFor: 'methods' stamp: 'lr 9/7/2010 20:12'! variableAssignedLiteral temporaryVariable := #() ! ! !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 20:12'! yourselfNotUsed self printString; printString; yourself! ! RBRegexRefactoring subclass: #RBSourceRegexRefactoring instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'NautilusRefactoring-Refactorings'! !RBSourceRegexRefactoring methodsFor: 'transforming'! 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. (self parseSelector: replacement) = selector ifFalse: [ class removeMethod: selector ]. class compile: replacement classified: protocols ] ] ] ]! ! !RBSourceRegexRefactoring methodsFor: 'private'! parseMethod: aString ^ [ RBParser parseMethod: aString ] on: Error do: [ :err | nil ]! ! !RBSourceRegexRefactoring methodsFor: 'private'! parseSelector: aString ^ RBParser parseMethodPattern: aString! ! RBVariableBinding subclass: #RBSpecialBinding instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AST-Semantic-Binding'! !RBSpecialBinding methodsFor: 'testing' stamp: 'lr 4/27/2010 14:35'! isReadonly ^ true! ! RBValueToken subclass: #RBSpecialCharacterToken instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Tokens'! !RBSpecialCharacterToken commentStamp: 'md 8/9/2005 14:53' prior: 0! RBSpecialCharacterToken is the first class representation of special characters. ! !RBSpecialCharacterToken methodsFor: 'testing'! isSpecial ^true! ! !RBSpecialCharacterToken methodsFor: 'private'! length ^1! ! Object subclass: #RBSpellChecker instanceVariableNames: '' classVariableNames: 'Default' poolDictionaries: '' category: 'Refactoring-Spelling'! !RBSpellChecker methodsFor: 'public' stamp: 'lr 12/22/2010 13:33'! check: aString "Answer a collection of ranges of spell errors in aString." ^ #()! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBSpellChecker class instanceVariableNames: ''! !RBSpellChecker class methodsFor: 'accessing' stamp: 'lr 9/5/2009 23:57'! default ^ Default ifNil: [ Default := self createInstance ]! ! !RBSpellChecker class methodsFor: 'initialization' stamp: 'lr 9/5/2009 23:54'! initialize Smalltalk addToShutDownList: self! ! !RBSpellChecker class methodsFor: 'initialization' stamp: 'lr 2/8/2009 12:24'! shutDown Default := nil! ! !RBSpellChecker class methodsFor: 'initialization' stamp: 'lr 9/5/2009 23:54'! unload Smalltalk removeFromShutDownList: self! ! !RBSpellChecker class methodsFor: 'private' stamp: 'lr 9/5/2009 23:57'! createInstance ^ RBMacSpellChecker isSupported ifTrue: [ RBMacSpellChecker new ] ifFalse: [ RBInternalSpellChecker new ]! ! RBBlockLintRule subclass: #RBSpellingRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Spelling'! !RBSpellingRule commentStamp: '' prior: 0! Abstract superclass. See subclasses.! !RBSpellingRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 11:24'! category ^ 'Spelling'! ! !RBSpellingRule methodsFor: 'accessing' stamp: 'lr 2/24/2009 07:56'! group ^ 'Spelling'! ! !RBSpellingRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 18:05'! rationale ^ 'Checks for spelling errors in ' , self name asLowercase , '.'! ! !RBSpellingRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:12'! severity ^ #information! ! !RBSpellingRule methodsFor: 'normalization' stamp: 'lr 1/23/2010 16:27'! normalizeCamelCase: aString "An ugly long method to get rid of camel case strings." | input output char | input := aString readStream. output := WriteStream on: (String new: 2 * aString size). [ input atEnd ] whileFalse: [ output nextPut: (char := input next). char isLetter ifTrue: [ [ input atEnd not and: [ input peek isLowercase ] ] whileTrue: [ output nextPut: input next ]. (input atEnd not and: [ input peek isSeparator not ]) ifTrue: [ output space ] ] ifFalse: [ char isDigit ifTrue: [ [ input atEnd not and: [ input peek isDigit ] ] whileTrue: [ output nextPut: input next ]. (input atEnd not and: [ input peek isSeparator not ]) ifTrue: [ output space ] ] ] ]. ^ output contents! ! !RBSpellingRule methodsFor: 'normalization' stamp: 'lr 1/21/2010 20:43'! normalizeIdentifier: aString ^ self normalizeCamelCase: (aString copyReplaceAll: '_' with: ' ')! ! !RBSpellingRule methodsFor: 'normalization' stamp: 'lr 1/21/2010 21:04'! normalizeLiteral: aLiteral | stream | stream := WriteStream on: String new. self normalizeLiteral: aLiteral on: stream. ^ stream contents! ! !RBSpellingRule methodsFor: 'normalization' stamp: 'lr 1/23/2010 16:45'! normalizeLiteral: aLiteral on: aStream aLiteral isSymbol ifTrue: [ ^ aStream nextPutAll: (self normalizeSelector: aLiteral) ]. aLiteral isString ifTrue: [ ^ aStream nextPutAll: aLiteral ]. aLiteral isCharacter ifTrue: [ ^ aStream nextPut: aLiteral ]. aLiteral isCollection ifTrue: [ ^ aLiteral do: [ :each | self normalizeLiteral: each on: aStream ] separatedBy: [ aStream nextPut: $ ] ]. aStream print: aLiteral! ! !RBSpellingRule methodsFor: 'normalization' stamp: 'lr 1/21/2010 20:41'! normalizeSelector: aString ^ self normalizeIdentifier: (aString copyReplaceAll: ':' with: ' ')! ! !RBSpellingRule methodsFor: 'public' stamp: 'lr 12/22/2010 13:56'! check: aString ^ (RBSpellChecker default check: aString) collect: [ :each | aString copyFrom: each first to: each last ]! ! !RBSpellingRule methodsFor: 'public' stamp: 'lr 1/21/2010 20:43'! checkIdentifier: aString ^ self check: (self normalizeIdentifier: aString)! ! !RBSpellingRule methodsFor: 'public' stamp: 'lr 1/21/2010 21:21'! checkLiteral: aLiteral ^ self check: (self normalizeLiteral: aLiteral)! ! !RBSpellingRule methodsFor: 'public' stamp: 'lr 1/21/2010 21:06'! checkSelector: aString ^ self check: (self normalizeSelector: aString)! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBSpellingRule class instanceVariableNames: ''! !RBSpellingRule 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" ^'SpellingRule'! ! !RBSpellingRule class methodsFor: 'testing' stamp: 'lr 2/24/2009 17:09'! isVisible ^ self name ~= #RBSpellingRule! ! RBMethodRefactoring subclass: #RBSplitCascadeRefactoring instanceVariableNames: 'selector selectedInterval parseTree cascadeNode beforeNodes afterNodes ancestorNode' classVariableNames: '' poolDictionaries: '' category: 'NautilusRefactoring-Refactorings'! !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: 'initialization'! split: anInterval from: aSelector in: aClass class := self classObjectFor: aClass. selector := aSelector. selectedInterval := anInterval! ! !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: '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 methodsFor: 'preconditions'! preconditions ^ (RBCondition definesSelector: selector in: class) & (RBCondition withBlock: [ self findCascadeNode; findAncestorNode; findMessageNodes. true ])! ! !RBSplitCascadeRefactoring methodsFor: 'transforming'! 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: 'transforming'! 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: 'transforming'! transform self extractReceiver. self splitCascade! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBSplitCascadeRefactoring class instanceVariableNames: ''! !RBSplitCascadeRefactoring class methodsFor: 'instance-creation'! model: aNamespace split: anInterval from: aSelector in: aClass ^ self new model: aNamespace; split: anInterval from: aSelector in: aClass; yourself! ! !RBSplitCascadeRefactoring class methodsFor: 'instance-creation'! split: anInterval from: aSelector in: aClass ^ self new split: anInterval from: aSelector in: aClass; yourself! ! RBRefactoring subclass: #RBSplitClassRefactoring instanceVariableNames: 'class instanceVariables newClassName referenceVariableName newClass' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBSplitClassRefactoring methodsFor: 'initialize-release'! class: aClass instanceVariables: instVars newClassName: className referenceVariableName: newVariable class := self model classFor: aClass. instanceVariables := instVars. newClassName := className. referenceVariableName := newVariable! ! !RBSplitClassRefactoring methodsFor: 'preconditions'! 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: 'printing'! 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: 'transforming'! abstractVariableReferences instanceVariables do: [:each | self abstractReferenceTo: each]! ! !RBSplitClassRefactoring methodsFor: 'transforming'! createNewClass self addClass; addInstanceVariables! ! !RBSplitClassRefactoring methodsFor: 'transforming' stamp: 'lr 9/8/2011 20:11'! createReference self performComponentRefactoring: (RBAddInstanceVariableRefactoring variable: referenceVariableName class: class)! ! !RBSplitClassRefactoring methodsFor: 'transforming'! transform self createNewClass; createReference; abstractVariableReferences! ! !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: 'private-transforming' stamp: 'lr 9/8/2011 20:11'! addClass self performComponentRefactoring: (RBAddClassRefactoring model: self model addClass: newClassName superclass: Object subclasses: #() category: class category). newClass := self model classNamed: newClassName! ! !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 class instanceVariableNames: ''! !RBSplitClassRefactoring class methodsFor: 'instance creation'! class: class instanceVariables: instVars newClassName: className referenceVariableName: newVariable ^(self new) class: class instanceVariables: instVars newClassName: className referenceVariableName: newVariable; yourself! ! !RBSplitClassRefactoring class methodsFor: 'instance creation'! model: aRBSmalltalk class: class instanceVariables: instVars newClassName: className referenceVariableName: newVariable ^(self new) model: aRBSmalltalk; class: class instanceVariables: instVars newClassName: className referenceVariableName: newVariable; yourself! ! RBParseTreeLintRule subclass: #RBStringConcatenationRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBStringConcatenationRule commentStamp: '' prior: 0! 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: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:31'! category ^ 'Optimization'! ! !RBStringConcatenationRule methodsFor: '*Manifest-Core' stamp: 'Sd 11/30/2012 16:51'! 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 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: '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: '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: '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 class instanceVariableNames: ''! !RBStringConcatenationRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBReplaceRule subclass: #RBStringReplaceRule instanceVariableNames: 'replaceTree' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Matching'! !RBStringReplaceRule commentStamp: 'md 8/9/2005 14:56' prior: 0! 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'! methodReplaceString: replaceString replaceTree := RBParser parseRewriteMethod: replaceString! ! !RBStringReplaceRule methodsFor: 'initialize-release'! 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'! searchFor: searchString replaceWith: replaceString self searchString: searchString. self replaceString: replaceString! ! !RBStringReplaceRule methodsFor: 'initialize-release'! searchFor: searchString replaceWith: replaceString when: aBlock self searchFor: searchString replaceWith: replaceString. verificationBlock := aBlock! ! !RBStringReplaceRule methodsFor: 'initialize-release'! searchForMethod: searchString replaceWith: replaceString self methodSearchString: searchString. self methodReplaceString: replaceString! ! !RBStringReplaceRule methodsFor: 'initialize-release'! searchForMethod: searchString replaceWith: replaceString when: aBlock self searchForMethod: searchString replaceWith: replaceString. verificationBlock := aBlock! ! !RBStringReplaceRule methodsFor: 'initialize-release'! searchForTree: aBRProgramNode replaceWith: replaceNode searchTree := aBRProgramNode. replaceTree := replaceNode! ! !RBStringReplaceRule methodsFor: 'initialize-release'! searchForTree: aBRProgramNode replaceWith: replaceString when: aBlock self searchForTree: aBRProgramNode replaceWith: replaceString. verificationBlock := aBlock! ! !RBStringReplaceRule methodsFor: 'matching'! foundMatchFor: aProgramNode | newNode | newNode := replaceTree copyInContext: self context. aProgramNode replaceMethodSource: newNode. newNode copyCommentsFrom: aProgramNode. ^newNode! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBStringReplaceRule class instanceVariableNames: ''! !RBStringReplaceRule class methodsFor: 'instance creation'! searchFor: searchString replaceWith: replaceString ^self new searchFor: searchString replaceWith: replaceString! ! !RBStringReplaceRule class methodsFor: 'instance creation'! searchFor: searchString replaceWith: replaceString when: aBlock ^self new searchFor: searchString replaceWith: replaceString when: aBlock! ! !RBStringReplaceRule class methodsFor: 'instance creation'! searchForMethod: searchString replaceWith: replaceString ^(self new) searchForMethod: searchString replaceWith: replaceString; yourself! ! !RBStringReplaceRule class methodsFor: 'instance creation'! searchForMethod: searchString replaceWith: replaceString when: aBlock ^self new searchForMethod: searchString replaceWith: replaceString when: aBlock! ! !RBStringReplaceRule class methodsFor: 'instance creation'! searchForTree: aRBProgramNode replaceWith: replaceString ^self new searchForTree: aRBProgramNode replaceWith: replaceString! ! !RBStringReplaceRule class methodsFor: 'instance creation'! searchForTree: aRBProgramNode replaceWith: replaceString when: aBlock ^self new searchForTree: aRBProgramNode replaceWith: replaceString when: aBlock! ! Object subclass: #RBStringReplacement instanceVariableNames: 'startPosition stopPosition string' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Nodes'! !RBStringReplacement commentStamp: '' prior: 0! 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'! startPosition ^startPosition! ! !RBStringReplacement methodsFor: 'accessing'! stopPosition ^stopPosition! ! !RBStringReplacement methodsFor: 'accessing'! string ^string! ! !RBStringReplacement methodsFor: 'initialize-release'! startPosition: anInteger startPosition := anInteger! ! !RBStringReplacement methodsFor: 'initialize-release'! stopPosition: anInteger stopPosition := anInteger! ! !RBStringReplacement methodsFor: 'initialize-release'! string: aString string := aString! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBStringReplacement class instanceVariableNames: ''! !RBStringReplacement class methodsFor: 'instance creation'! replaceFrom: startInteger to: stopInteger with: aString ^(self new) startPosition: startInteger; stopPosition: stopInteger; string: aString; yourself! ! RBClassToRename subclass: #RBSubclassOfClassToRename instanceVariableNames: 'rewriteRule1' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core-Data'! !RBSubclassOfClassToRename methodsFor: 'accessing'! calls ^self rewriteRule1: self name , self rewriteRule1! ! !RBSubclassOfClassToRename methodsFor: 'accessing'! calls1 ^self rewriteRule1: (self rewriteRule1: self calls)! ! !RBSubclassOfClassToRename methodsFor: 'accessing'! name ^rewriteRule1! ! !RBSubclassOfClassToRename methodsFor: 'accessing'! rewriteRule1 ^rewriteRule1! ! !RBSubclassOfClassToRename methodsFor: 'accessing'! rewriteRule1: anObject ^rewriteRule1 := anObject! ! !RBSubclassOfClassToRename methodsFor: 'performing' stamp: 'lr 2/26/2009 14:51'! reference ^ RBClassToRename new! ! !RBSubclassOfClassToRename methodsFor: 'performing' stamp: 'lr 2/26/2009 14:51'! symbolReference ^ #RBClassToRename! ! RBBlockLintRule subclass: #RBSubclassResponsibilityNotDefinedRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBSubclassResponsibilityNotDefinedRule commentStamp: '' prior: 0! 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: 'lr 2/23/2009 23:17'! group ^ 'Bugs'! ! !RBSubclassResponsibilityNotDefinedRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Subclass responsibility not defined'! ! !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 5/15/2010 15:04'! severity ^ #error! ! !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 instanceVariableNames: ''! !RBSubclassResponsibilityNotDefinedRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBSpecialBinding subclass: #RBSuperBinding instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AST-Semantic-Binding'! !RBSuperBinding methodsFor: 'accessing' stamp: 'lr 4/27/2010 14:34'! name ^ 'super'! ! !RBSuperBinding methodsFor: 'testing-type' stamp: 'lr 4/28/2010 09:29'! isSuperBinding ^ true! ! RBVariableNode subclass: #RBSuperNode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Nodes'! !RBSuperNode commentStamp: '' prior: 0! I am a specialized variable node for 'super'! !RBSuperNode methodsFor: 'testing' stamp: 'CamilloBruni 12/15/2011 14:33'! isSuper ^ true! ! !RBSuperNode methodsFor: 'visitor' stamp: 'CamilloBruni 12/15/2011 14:17'! accept: aProgramNodeVisitor ^aProgramNodeVisitor visitSuperNode: self! ! !RBSuperNode methodsFor: 'visitor' stamp: 'CamilloBruni 8/30/2011 16:54'! acceptVisitor: aProgramNodeVisitor ^aProgramNodeVisitor acceptSuperNode: self! ! RBBlockLintRule subclass: #RBSuperSendsNewRule instanceVariableNames: 'matcher' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBSuperSendsNewRule commentStamp: '' prior: 0! See my #rationale.! !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: '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: '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: '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: '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 instanceVariableNames: ''! !RBSuperSendsNewRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBTransformationRule subclass: #RBSuperSendsRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-TransformationRules'! !RBSuperSendsRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:52'! category ^ 'Design Flaws'! ! !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: '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 class instanceVariableNames: ''! !RBSuperSendsRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBMethodRefactoring subclass: #RBSwapMethodRefactoring instanceVariableNames: 'target selector' classVariableNames: '' poolDictionaries: '' category: 'NautilusRefactoring-Refactorings'! !RBSwapMethodRefactoring commentStamp: 'lr 10/19/2007 09:16' prior: 0! Move a method from the class to the instance side, or vice versa. Normally this is not considered to be a refactoring.! !RBSwapMethodRefactoring methodsFor: 'initialization'! swapMethod: aSelector in: aClass class := self classObjectFor: aClass. target := self classObjectFor: (class isMeta ifTrue: [ class theNonMetaClass ] ifFalse: [ class theMetaClass ]). selector := aSelector! ! !RBSwapMethodRefactoring methodsFor: 'preconditions'! 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: 'preconditions'! preconditions ^ (RBCondition definesSelector: selector in: class) & (RBCondition definesSelector: selector in: target) not & (RBCondition withBlock: [ self checkInstVars. true ])! ! !RBSwapMethodRefactoring methodsFor: 'transforming'! transform target compile: (class sourceCodeFor: selector) classified: (class protocolsFor: selector). class removeMethod: selector! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBSwapMethodRefactoring class instanceVariableNames: ''! !RBSwapMethodRefactoring class methodsFor: 'instance-creation'! model: aRBSmalltalk swapMethod: aSelector in: aClass ^ self new model: aRBSmalltalk; swapMethod: aSelector in: aClass; yourself! ! !RBSwapMethodRefactoring class methodsFor: 'instance-creation'! swapMethod: aSelector in: aClass ^ self new swapMethod: aSelector in: aClass! ! RBBlockLintRule subclass: #RBTempVarOverridesInstVarRule instanceVariableNames: 'matcher varName vars' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBTempVarOverridesInstVarRule commentStamp: '' prior: 0! See my #rationale.! !RBTempVarOverridesInstVarRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 13:59'! category ^ 'Potential Bugs'! ! !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: '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: 'initialization' stamp: 'lr 11/2/2009 00:14'! initialize super initialize. matcher := RBParseTreeSearcher new. matcher matchesArgument: '`var' do: [:aNode :answer | answer or: [varName := aNode name. vars includes: varName]]! ! !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 instanceVariableNames: ''! !RBTempVarOverridesInstVarRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBLocalBinding subclass: #RBTemporaryBinding instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AST-Semantic-Binding'! !RBTemporaryBinding methodsFor: 'testing-type' stamp: 'lr 4/28/2010 09:36'! isTemporaryBinding ^ true! ! RBVariableNode subclass: #RBTemporaryNode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Nodes'! !RBTemporaryNode commentStamp: '' prior: 0! I am a specialized variable node for temporary variables! !RBTemporaryNode methodsFor: 'testing' stamp: 'CamilloBruni 12/15/2011 14:32'! isTemp ^ true! ! !RBTemporaryNode methodsFor: 'visitor' stamp: 'CamilloBruni 12/15/2011 14:23'! accept: aProgramNodeVisitor ^aProgramNodeVisitor visitTemporaryNode: self! ! !RBTemporaryNode methodsFor: 'visitor' stamp: 'CamilloBruni 12/15/2011 14:23'! acceptVisitor: aProgramNodeVisitor ^aProgramNodeVisitor acceptTemporaryNode: self! ! RBMethodRefactoring subclass: #RBTemporaryToInstanceVariableRefactoring instanceVariableNames: 'selector temporaryVariableName' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBTemporaryToInstanceVariableRefactoring methodsFor: 'initialize-release'! class: aClass selector: aSelector variable: aVariableName class := self classObjectFor: aClass. selector := aSelector. temporaryVariableName := aVariableName! ! !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'! preconditions ^(RBCondition definesSelector: selector in: class) & (RBCondition hierarchyOf: class definesVariable: temporaryVariableName asString) not & (RBCondition withBlock: [self checkForValidTemporaryVariable. true])! ! !RBTemporaryToInstanceVariableRefactoring methodsFor: 'printing'! 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 instanceVariableNames: ''! !RBTemporaryToInstanceVariableRefactoring class methodsFor: 'instance creation'! class: aClass selector: aSelector variable: aVariableName ^self new class: aClass selector: aSelector variable: aVariableName! ! !RBTemporaryToInstanceVariableRefactoring class methodsFor: 'instance creation'! model: aRBSmalltalk class: aClass selector: aSelector variable: aVariableName ^(self new) model: aRBSmalltalk; class: aClass selector: aSelector variable: aVariableName; yourself! ! RBRefactoringTest subclass: #RBTemporaryToInstanceVariableTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !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: 'set up' stamp: 'md 7/25/2005 15:17'! setUp super setUp. model := Compiler evaluate: self abstractVariableTestData.! ! !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')! ! RBBlockLintRule subclass: #RBTemporaryVariableCapitalizationRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBTemporaryVariableCapitalizationRule commentStamp: '' prior: 0! See my #rationale.! !RBTemporaryVariableCapitalizationRule methodsFor: '*Manifest-Core' stamp: 'Simon 8/30/2012 14:20'! category ^ 'Style'! ! !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 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: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Temporary and argument variable names should start with a lowercase letter.'! ! !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 class instanceVariableNames: ''! !RBTemporaryVariableCapitalizationRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBSpellingRule subclass: #RBTemporaryVariableNamesSpellingRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Spelling'! !RBTemporaryVariableNamesSpellingRule commentStamp: '' prior: 0! See #name for the area where I check spelling.! !RBTemporaryVariableNamesSpellingRule methodsFor: 'accessing' stamp: 'lr 2/24/2009 07:57'! name ^ 'Temporary variable names'! ! !RBTemporaryVariableNamesSpellingRule methodsFor: 'running' stamp: 'lr 1/21/2010 21:32'! checkMethod: aContext aContext parseTree allTemporaryVariables do: [ :name | (self checkIdentifier: name) do: [ :each | result addSearchString: each; addClass: aContext selectedClass selector: aContext selector ] ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBTemporaryVariableNamesSpellingRule class instanceVariableNames: ''! !RBTemporaryVariableNamesSpellingRule 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" ^'TemporaryVariableNamesSpellingRule'! ! RBBlockLintRule subclass: #RBTempsReadBeforeWrittenRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBTempsReadBeforeWrittenRule commentStamp: '' prior: 0! See my #rationale.! !RBTempsReadBeforeWrittenRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 13:40'! category ^ 'Potential Bugs'! ! !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: '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: '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 instanceVariableNames: ''! !RBTempsReadBeforeWrittenRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBVariableNode subclass: #RBThisContextNode instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Nodes'! !RBThisContextNode commentStamp: '' prior: 0! I represent the specialized variable named 'thisContext'! !RBThisContextNode methodsFor: 'as yet unclassified' stamp: 'CamilloBruni 8/30/2011 16:54'! acceptVisitor: aProgramNodeVisitor ^aProgramNodeVisitor acceptThisContextNode: self! ! RBParseTreeLintRule subclass: #RBThreeElementPointRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBThreeElementPointRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:32'! category ^ 'Potential Bugs'! ! !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: '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: '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 class instanceVariableNames: ''! !RBThreeElementPointRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBParseTreeLintRule subclass: #RBToDoCollectRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBToDoCollectRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:33'! category ^ 'Coding Idiom Violation'! ! !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: 'accessing' stamp: 'lr 5/15/2010 17:39'! rationale ^ 'Checks for users of to:do: when the shorter collect: would work.'! ! !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 class instanceVariableNames: ''! !RBToDoCollectRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBParseTreeLintRule subclass: #RBToDoRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBToDoRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:33'! category ^ 'Coding Idiom Violation'! ! !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: '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: '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 class instanceVariableNames: ''! !RBToDoRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBParseTreeLintRule subclass: #RBToDoWithIncrementRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBToDoWithIncrementRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:33'! category ^ 'Coding Idiom Violation'! ! !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: 'accessing' stamp: 'lr 5/15/2010 17:42'! rationale ^ 'Checks for users of to:do: that also increment or decrement a counter.'! ! !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 class instanceVariableNames: ''! !RBToDoWithIncrementRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! Object subclass: #RBToken instanceVariableNames: 'sourcePointer comments' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Tokens'! !RBToken commentStamp: '' prior: 0! 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'! comments ^comments! ! !RBToken methodsFor: 'accessing'! comments: anObject comments := anObject! ! !RBToken methodsFor: 'accessing'! length ^self subclassResponsibility! ! !RBToken methodsFor: 'accessing'! removePositions sourcePointer := nil! ! !RBToken methodsFor: 'accessing' stamp: 'lr 2/18/2010 17:25'! start ^ sourcePointer ifNil: [ 0 ]! ! !RBToken methodsFor: 'accessing' stamp: 'lr 2/18/2010 17:25'! stop ^ sourcePointer isNil ifTrue: [ -1 ] ifFalse: [ self start + self length - 1 ]! ! !RBToken methodsFor: 'initialize-release'! start: anInteger sourcePointer := anInteger! ! !RBToken methodsFor: 'printing'! printOn: aStream aStream nextPut: $ ; nextPutAll: self class name! ! !RBToken methodsFor: 'testing'! isAssignment ^false! ! !RBToken methodsFor: 'testing'! isBinary ^false! ! !RBToken methodsFor: 'testing'! isIdentifier ^false! ! !RBToken methodsFor: 'testing'! isKeyword ^false! ! !RBToken methodsFor: 'testing'! isLiteral ^self isLiteralToken! ! !RBToken methodsFor: 'testing'! isLiteralArrayToken ^false! ! !RBToken methodsFor: 'testing'! isLiteralToken ^false! ! !RBToken methodsFor: 'testing'! isPatternBlock ^false! ! !RBToken methodsFor: 'testing'! isPatternVariable ^false! ! !RBToken methodsFor: 'testing'! isSpecial ^false! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBToken class instanceVariableNames: ''! !RBToken class methodsFor: 'instance creation'! start: anInterval ^self new start: anInterval! ! RBLintRule subclass: #RBTransformationRule instanceVariableNames: 'rewriteRule builder class' classVariableNames: 'RecursiveSelfRule' poolDictionaries: '' category: 'Refactoring-Critics'! !RBTransformationRule commentStamp: '' prior: 0! A RBTransformationRule is a special rule that not only detects problems but also can automatically transform the good.! !RBTransformationRule methodsFor: '*Manifest-Core'! isTransformationRule ^ true ! ! !RBTransformationRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:46'! changes ^ builder changes! ! !RBTransformationRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:46'! problemCount ^ builder problemCount! ! !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: 'accessing' stamp: 'lr 2/23/2009 23:23'! rewriteRule ^ rewriteRule! ! !RBTransformationRule methodsFor: 'initialization' stamp: 'lr 11/2/2009 00:14'! initialize super initialize. rewriteRule := RBParseTreeRewriter new! ! !RBTransformationRule methodsFor: 'running' stamp: 'lr 11/1/2009 22:59'! checkMethod: aContext (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: 'running' stamp: 'lr 9/8/2011 20:10'! resetResult builder := RBCompositeRefactoryChange named: self name! ! !RBTransformationRule methodsFor: 'testing' stamp: 'lr 2/23/2009 23:47'! hasConflicts ^ true! ! !RBTransformationRule methodsFor: 'testing' stamp: 'lr 2/23/2009 23:47'! isEmpty ^ builder changes isEmpty! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBTransformationRule class instanceVariableNames: ''! !RBTransformationRule class methodsFor: '*Manifest-Core'! 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! ! !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: 'accessing' stamp: 'lr 2/23/2009 23:49'! recursiveSelfRule ^ RecursiveSelfRule! ! !RBTransformationRule class methodsFor: 'initialization' stamp: 'lr 2/23/2009 23:48'! initialize self initializeRecursiveSelfRule! ! !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: 'testing' stamp: 'lr 2/24/2009 17:09'! isVisible ^ self name ~= #RBTransformationRule! ! RBFooLintRuleTest subclass: #RBTransformationRuleTest instanceVariableNames: 'rewriteRule builder class' classVariableNames: 'RecursiveSelfRule' poolDictionaries: '' category: 'Refactoring-Tests-Core-Data'! !RBTransformationRuleTest methodsFor: 'accessing'! 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: 'accessing'! problemCount ^builder problemCount! ! !RBTransformationRuleTest methodsFor: 'accessing' stamp: 'lr 9/8/2011 20:10'! resetResult builder := RBCompositeRefactoryChange new! ! !RBTransformationRuleTest methodsFor: 'initialize-release'! rewriteUsing: searchReplacer rewriteRule := searchReplacer. self resetResult! ! !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'! hasConflicts ^true! ! !RBTransformationRuleTest methodsFor: 'testing'! isEmpty ^builder changes isEmpty! ! !RBTransformationRuleTest methodsFor: 'private'! 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 class instanceVariableNames: ''! !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: 'class initialization'! nuke RecursiveSelfRule := nil! ! !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: 'transformations'! 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'! 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'! 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'! 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: 'transformations'! 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'! 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'! 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'! 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'! 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'! superSends ^(self new) name: 'Rewrite super messages to self messages when both refer to same method'; superSends; yourself! ! !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'! ! RBTransformationRule subclass: #RBTranslateLiteralsInMenusRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-TransformationRules'! !RBTranslateLiteralsInMenusRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 11:22'! category ^ 'Potential Bugs'! ! !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: '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 class instanceVariableNames: ''! !RBTranslateLiteralsInMenusRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBBlockLintRule subclass: #RBUnclassifiedMethodsRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBUnclassifiedMethodsRule commentStamp: '' prior: 0! See my #rationale.! !RBUnclassifiedMethodsRule methodsFor: '*Manifest-Core' stamp: 'Simon 8/30/2012 14:57'! category ^ 'Style'! ! !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: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'All methods should be put into a protocol (method category) for better readability.'! ! !RBUnclassifiedMethodsRule methodsFor: 'running' stamp: 'lr 2/23/2009 23:17'! checkMethod: aContext (aContext selectedClass organization categoryOfElement: aContext selector) = Categorizer default ifTrue: [ result addClass: aContext selectedClass selector: aContext selector ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBUnclassifiedMethodsRule class instanceVariableNames: ''! !RBUnclassifiedMethodsRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBBlockLintRule subclass: #RBUncommonMessageSendRule instanceVariableNames: 'literalNames' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBUncommonMessageSendRule commentStamp: '' prior: 0! See my #rationale.! !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: '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: '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: 'initialization' stamp: 'SeanDeNigris 1/31/2013 09:45'! initialize super initialize. literalNames := self commonLiterals.! ! !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 instanceVariableNames: ''! !RBUncommonMessageSendRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBParseTreeLintRule subclass: #RBUnconditionalRecursionRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBUnconditionalRecursionRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:34'! category ^ 'Potential Bugs'! ! !RBUnconditionalRecursionRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Possible bugs'! ! !RBUnconditionalRecursionRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Unconditional recursion'! ! !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 5/15/2010 17:55'! severity ^ #error! ! !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 class instanceVariableNames: ''! !RBUnconditionalRecursionRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBLocalBinding subclass: #RBUndeclaredBinding instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AST-Semantic-Binding'! !RBUndeclaredBinding methodsFor: 'testing-type' stamp: 'lr 4/28/2010 09:36'! isUndeclaredBinding ^ true! ! RBBlockLintRule subclass: #RBUndeclaredReferenceRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBUndeclaredReferenceRule commentStamp: '' prior: 0! See my #rationale.! !RBUndeclaredReferenceRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 13:42'! category ^ 'Bugs'! ! !RBUndeclaredReferenceRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Bugs'! ! !RBUndeclaredReferenceRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'References an undeclared variable'! ! !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 5/15/2010 15:04'! severity ^ #error! ! !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 class instanceVariableNames: ''! !RBUndeclaredReferenceRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! Notification subclass: #RBUndeclaredVariableNotification instanceVariableNames: 'node' classVariableNames: '' poolDictionaries: '' category: 'AST-Semantic-Exceptions'! !RBUndeclaredVariableNotification methodsFor: 'accessing' stamp: 'lr 6/7/2010 14:29'! node ^ node! ! !RBUndeclaredVariableNotification methodsFor: 'accessing' stamp: 'lr 6/7/2010 14:29'! node: aNode node := aNode! ! !RBUndeclaredVariableNotification methodsFor: 'configuration' stamp: 'lr 6/7/2010 14:30'! defaultAction ^ RBUndeclaredBinding node: self node! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBUndeclaredVariableNotification class instanceVariableNames: ''! !RBUndeclaredVariableNotification class methodsFor: 'signalling' stamp: 'lr 6/7/2010 14:31'! node: aVariableNode ^ self new node: aVariableNode; signal: aVariableNode name , ' is undeclared'! ! RBTransformationRule subclass: #RBUnderscoreAssignmentRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-TransformationRules'! !RBUnderscoreAssignmentRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:52'! category ^ 'Style'! ! !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: 'initialization' stamp: 'lr 11/7/2009 18:31'! initialize super initialize. self rewriteRule replace: '`var := ``@object' with: '`var := ``@object' when: [ :node | node assignmentOperator = '_' ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBUnderscoreAssignmentRule class instanceVariableNames: ''! !RBUnderscoreAssignmentRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBParseTreeLintRule subclass: #RBUnnecessaryAssignmentRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBUnnecessaryAssignmentRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:34'! category ^ 'Optimization'! ! !RBUnnecessaryAssignmentRule methodsFor: 'accessing' stamp: 'lr 3/13/2009 13:55'! group ^ 'Unnecessary code'! ! !RBUnnecessaryAssignmentRule methodsFor: 'accessing' stamp: 'lr 3/13/2009 13:55'! name ^ 'Unnecessary assignment to a temporary variable'! ! !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 5/15/2010 15:10'! severity ^ #information! ! !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 class instanceVariableNames: ''! !RBUnnecessaryAssignmentRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBParseTreeLintRule subclass: #RBUnoptimizedAndOrRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBUnoptimizedAndOrRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:34'! category ^ 'Optimization'! ! !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: 'accessing' stamp: 'lr 5/15/2010 17:46'! rationale ^ 'Checks for inefficient nesting of logical conditions.'! ! !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 class instanceVariableNames: ''! !RBUnoptimizedAndOrRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBParseTreeLintRule subclass: #RBUnoptimizedToDoRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBUnoptimizedToDoRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:35'! category ^ 'Optimization'! ! !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: 'accessing' stamp: 'lr 5/15/2010 17:48'! rationale ^ 'Checks for inefficient uses of to:do: that create an unnecessary Interval instance.'! ! !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 class instanceVariableNames: ''! !RBUnoptimizedToDoRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBBlockLintRule subclass: #RBUnpackagedCodeRule instanceVariableNames: 'packages package' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBUnpackagedCodeRule commentStamp: '' prior: 0! See my #rationale.! !RBUnpackagedCodeRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 13:43'! category ^'Potential Bugs'! ! !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: '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: 'initialization' stamp: 'EstebanLorenzano 9/12/2012 13:37'! initialize super initialize. packages := MCWorkingCopy allManagers inject: #() into: [ :all :each | all, (each packageSet packages) ]! ! !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 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: '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 class instanceVariableNames: ''! !RBUnpackagedCodeRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBBlockLintRule subclass: #RBUnreferencedVariablesRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBUnreferencedVariablesRule commentStamp: '' prior: 0! See my #rationale.! !RBUnreferencedVariablesRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 13:44'! category ^ 'Design Flaws'! ! !RBUnreferencedVariablesRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Unnecessary code'! ! !RBUnreferencedVariablesRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Variables not referenced'! ! !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 9/8/2011 20:32'! resultClass ^ RBVariableEnvironment! ! !RBUnreferencedVariablesRule methodsFor: 'accessing' stamp: 'lr 5/15/2010 15:10'! severity ^ #information! ! !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 instanceVariableNames: ''! !RBUnreferencedVariablesRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBTransformationRule subclass: #RBUnwindBlocksRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-TransformationRules'! !RBUnwindBlocksRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:54'! category ^ 'Optimization'! ! !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: '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 class instanceVariableNames: ''! !RBUnwindBlocksRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBParseTreeLintRule subclass: #RBUsesAddRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBUsesAddRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:35'! category ^ 'Potential Bugs'! ! !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: '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: '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 class instanceVariableNames: ''! !RBUsesAddRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBBlockLintRule subclass: #RBUsesTrueRule instanceVariableNames: 'trueBinding falseBinding' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBUsesTrueRule commentStamp: '' prior: 0! See my #rationale.! !RBUsesTrueRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 13:46'! category ^ 'Bugs'! ! !RBUsesTrueRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Bugs'! ! !RBUsesTrueRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Uses True/False instead of true/false'! ! !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 5/15/2010 15:04'! severity ^ #error! ! !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: '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 instanceVariableNames: ''! !RBUsesTrueRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBBlockLintRule subclass: #RBUtilityMethodsRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBUtilityMethodsRule commentStamp: '' prior: 0! See my #rationale.! !RBUtilityMethodsRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 13:46'! category ^ 'Design Flaws'! ! !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: '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: '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 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: 'private' stamp: 'lr 2/24/2009 00:18'! utilityProtocols ^ #('*utilit*')! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBUtilityMethodsRule class instanceVariableNames: ''! !RBUtilityMethodsRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBProgramNode subclass: #RBValueNode instanceVariableNames: 'parentheses' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Nodes'! !RBValueNode commentStamp: '' prior: 0! 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: 'accessing'! addParenthesis: anInterval parentheses isNil ifTrue: [parentheses := OrderedCollection new: 1]. parentheses add: anInterval! ! !RBValueNode methodsFor: 'accessing'! parentheses ^parentheses isNil ifTrue: [#()] ifFalse: [parentheses]! ! !RBValueNode methodsFor: 'accessing'! start ^parentheses isNil ifTrue: [self startWithoutParentheses] ifFalse: [parentheses last first]! ! !RBValueNode methodsFor: 'accessing'! startWithoutParentheses ^self subclassResponsibility! ! !RBValueNode methodsFor: 'accessing'! stop ^parentheses isNil ifTrue: [self stopWithoutParentheses] ifFalse: [parentheses last last]! ! !RBValueNode methodsFor: 'accessing'! stopWithoutParentheses ^self subclassResponsibility! ! !RBValueNode methodsFor: 'testing'! containedBy: anInterval ^anInterval first <= self startWithoutParentheses and: [anInterval last >= self stopWithoutParentheses]! ! !RBValueNode methodsFor: 'testing'! hasParentheses ^self parentheses notEmpty! ! !RBValueNode methodsFor: 'testing'! isValue ^true! ! !RBValueNode methodsFor: 'testing'! needsParenthesis ^self subclassResponsibility! ! RBToken subclass: #RBValueToken instanceVariableNames: 'value' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Tokens'! !RBValueToken commentStamp: '' prior: 0! 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: 'accessing'! value ^value! ! !RBValueToken methodsFor: 'accessing'! value: anObject value := anObject! ! !RBValueToken methodsFor: 'initialize-release'! value: aString start: anInteger value := aString. sourcePointer := anInteger! ! !RBValueToken methodsFor: 'printing' stamp: 'CamilloBruni 2/20/2012 23:11'! printOn: aStream super printOn: aStream. aStream nextPut: $(. value printOn: aStream. aStream nextPutAll: ')'! ! !RBValueToken methodsFor: 'private'! length ^value size! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBValueToken class instanceVariableNames: ''! !RBValueToken class methodsFor: 'instance creation'! value: aString start: anInteger ^self new value: aString start: anInteger! ! RBBlockLintRule subclass: #RBVariableAssignedLiteralRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBVariableAssignedLiteralRule commentStamp: '' prior: 0! See my #rationale.! !RBVariableAssignedLiteralRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 13:48'! category ^ 'Design Flaws'! ! !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: '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 9/8/2011 20:32'! resultClass ^ RBVariableEnvironment! ! !RBVariableAssignedLiteralRule methodsFor: 'running' stamp: 'lr 11/2/2009 00:14'! 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 isLiteral ] ]. tree := defClass parseTreeFor: selector. tree notNil ifTrue: [ (searcher executeTree: tree initialAnswer: nil) == true ifTrue: [ result addClass: aContext selectedClass instanceVariable: each ] ] ] ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBVariableAssignedLiteralRule class instanceVariableNames: ''! !RBVariableAssignedLiteralRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! Object subclass: #RBVariableBinding instanceVariableNames: 'scope accessors readers writers' classVariableNames: '' poolDictionaries: '' category: 'AST-Semantic-Binding'! !RBVariableBinding methodsFor: 'accessing' stamp: 'lr 6/4/2010 15:03'! accessors "Answer the nodes that access the receiver." ^ accessors! ! !RBVariableBinding methodsFor: 'accessing' stamp: 'lr 4/27/2010 14:30'! name "Answer the name of the variable." self subclassResponsibility! ! !RBVariableBinding methodsFor: 'accessing' stamp: 'lr 5/11/2010 22:17'! readers "Answer the nodes that read from the receiver." ^ readers! ! !RBVariableBinding methodsFor: 'accessing' stamp: 'lr 4/27/2010 14:06'! scope "Answer the owning scope." ^ scope! ! !RBVariableBinding methodsFor: 'accessing' stamp: 'lr 5/11/2010 22:18'! writers "Answer the nodes that write to the receiver." ^ writers! ! !RBVariableBinding methodsFor: 'initialization' stamp: 'lr 6/4/2010 14:59'! initialize accessors := readers := writers := #()! ! !RBVariableBinding methodsFor: 'initialization' stamp: 'lr 4/27/2010 14:06'! setScope: aLexicalScope scope := aLexicalScope! ! !RBVariableBinding methodsFor: 'printing' stamp: 'lr 4/27/2010 14:30'! printOn: aStream super printOn: aStream. aStream nextPutAll: ' name: '; print: self name! ! !RBVariableBinding methodsFor: 'protected' stamp: 'lr 6/4/2010 14:59'! addAccessor: aProgramNode accessors := accessors copyWith: aProgramNode! ! !RBVariableBinding methodsFor: 'protected' stamp: 'lr 5/11/2010 22:28'! addReader: aProgramNode readers := readers copyWith: aProgramNode! ! !RBVariableBinding methodsFor: 'protected' stamp: 'lr 5/11/2010 22:28'! addWriter: aProgramNode writers := writers copyWith: aProgramNode! ! !RBVariableBinding methodsFor: 'testing' stamp: 'lr 6/4/2010 15:03'! isAccessed "Answer true if the receiving binding is accessed." ^ self accessors notEmpty! ! !RBVariableBinding methodsFor: 'testing' stamp: 'CamilloBruni 12/5/2011 15:05'! isArgument ^ self isArgumentBinding! ! !RBVariableBinding methodsFor: 'testing' stamp: 'CamilloBruni 12/5/2011 15:05'! isContext ^ self isContextBinding! ! !RBVariableBinding methodsFor: 'testing' stamp: 'CamilloBruni 12/5/2011 15:05'! isInstance ^ self isInstanceBinding! ! !RBVariableBinding methodsFor: 'testing' stamp: 'CamilloBruni 12/5/2011 15:06'! isLiteral ^ self isLiteralBinding! ! !RBVariableBinding methodsFor: 'testing' stamp: 'lr 4/28/2010 09:33'! isRead "Answer true if the receiving binding is read." ^ self readers notEmpty! ! !RBVariableBinding methodsFor: 'testing' stamp: 'lr 4/27/2010 14:35'! isReadonly "Answer if the receiving binding is readonly." ^ false! ! !RBVariableBinding methodsFor: 'testing' stamp: 'CamilloBruni 7/30/2012 13:03'! isSelf ^ self isSelfBinding! ! !RBVariableBinding methodsFor: 'testing' stamp: 'lr 6/7/2010 15:09'! isShadowing "Answer true if the receiving shadows another variable in a parent scope." self scope isRootScope ifTrue: [ ^ false ]. self scope owner lookup: self name ifAbsent: [ ^ false ]. ^ true! ! !RBVariableBinding methodsFor: 'testing' stamp: 'CamilloBruni 12/5/2011 15:06'! isSuper ^ self isSuperBinding! ! !RBVariableBinding methodsFor: 'testing' stamp: 'CamilloBruni 12/5/2011 15:06'! isTemp ^ self isTemporaryBinding! ! !RBVariableBinding methodsFor: 'testing' stamp: 'CamilloBruni 12/5/2011 15:06'! isUndeclared ^ self isUndeclaredBinding! ! !RBVariableBinding methodsFor: 'testing' stamp: 'lr 4/28/2010 09:33'! isWritten "Answer true if the receiving binding is written." ^ self writers notEmpty! ! !RBVariableBinding methodsFor: 'testing-type' stamp: 'lr 4/28/2010 09:35'! isArgumentBinding ^ false! ! !RBVariableBinding methodsFor: 'testing-type' stamp: 'lr 4/28/2010 09:34'! isContextBinding ^ false! ! !RBVariableBinding methodsFor: 'testing-type' stamp: 'lr 4/28/2010 09:35'! isInstanceBinding ^ false! ! !RBVariableBinding methodsFor: 'testing-type' stamp: 'lr 4/28/2010 09:35'! isLiteralBinding ^ false! ! !RBVariableBinding methodsFor: 'testing-type' stamp: 'lr 4/28/2010 09:34'! isSelfBinding ^ false! ! !RBVariableBinding methodsFor: 'testing-type' stamp: 'lr 4/28/2010 09:34'! isSuperBinding ^ false! ! !RBVariableBinding methodsFor: 'testing-type' stamp: 'lr 4/28/2010 09:35'! isTemporaryBinding ^ false! ! !RBVariableBinding methodsFor: 'testing-type' stamp: 'lr 4/28/2010 09:35'! isUndeclaredBinding ^ false! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBVariableBinding class instanceVariableNames: ''! !RBVariableBinding class methodsFor: 'instance creation' stamp: 'lr 4/27/2010 14:07'! new ^ self basicNew initialize! ! RBBrowserEnvironmentWrapper subclass: #RBVariableEnvironment instanceVariableNames: 'instanceVariables instanceVariableReaders instanceVariableWriters classVariables selectorCache' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Environment'! !RBVariableEnvironment methodsFor: 'accessing'! addClass: aClass classVariable: aSymbol (classVariables at: aClass name ifAbsentPut: [Set new]) add: aSymbol. self flushCachesFor: aClass. self addSearchString: aSymbol! ! !RBVariableEnvironment methodsFor: 'accessing'! addClass: aClass instanceVariable: aString (instanceVariables at: aClass name ifAbsentPut: [Set new]) add: aString. self flushCachesFor: aClass. self addSearchString: aString! ! !RBVariableEnvironment methodsFor: 'accessing'! addClass: aClass instanceVariableReader: aString (instanceVariableReaders at: aClass name ifAbsentPut: [Set new]) add: aString. self flushCachesFor: aClass. self addSearchString: aString! ! !RBVariableEnvironment methodsFor: 'accessing'! addClass: aClass instanceVariableWriter: aString (instanceVariableWriters at: aClass name ifAbsentPut: [Set new]) add: aString. self flushCachesFor: aClass. self addSearchString: aString! ! !RBVariableEnvironment methodsFor: 'accessing'! classNamesWithVariables | classNames | classNames := Set new. classNames addAll: instanceVariables keys; addAll: instanceVariableReaders keys; addAll: instanceVariableWriters keys; addAll: classVariables keys. ^classNames! ! !RBVariableEnvironment methodsFor: 'accessing'! classVariablesFor: aClass ^classVariables at: aClass name ifAbsent: [#()]! ! !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: 'lr 9/8/2011 20:32'! 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 whichSelectorsReallyRead: aString) do: [:sel | selectorEnvironment addClass: each selector: sel]]]. ^selectorEnvironment! ! !RBVariableEnvironment methodsFor: 'accessing'! 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: 'accessing'! numberVariables ^self accessorMethods inject: 0 into: [:sum :each | sum + ((self perform: each) inject: 0 into: [:s :e | s + e size])]! ! !RBVariableEnvironment methodsFor: 'accessing'! problemCount ^self numberVariables! ! !RBVariableEnvironment methodsFor: 'accessing'! 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: 'accessing'! 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: 'accessing'! 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'! 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: 'copying'! copyDictionary: aDictionary | copy | copy := Dictionary new: aDictionary size. aDictionary keysAndValuesDo: [:key :value | copy at: key put: value]. ^copy! ! !RBVariableEnvironment methodsFor: 'copying'! postCopy super postCopy. instanceVariables := self copyDictionary: instanceVariables. instanceVariableReaders := self copyDictionary: instanceVariableReaders. instanceVariableWriters := self copyDictionary: instanceVariableWriters. classVariables := self copyDictionary: classVariables. selectorCache := nil! ! !RBVariableEnvironment methodsFor: 'initialize-release'! initialize super initialize. instanceVariables := Dictionary new. classVariables := Dictionary new. instanceVariableReaders := Dictionary new. instanceVariableWriters := Dictionary new! ! !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: 'testing'! includesCategory: aCategory ^(self classNamesFor: aCategory) isEmpty not! ! !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: 'testing'! includesProtocol: aProtocol in: aClass ^(self selectorsFor: aProtocol in: aClass) isEmpty not! ! !RBVariableEnvironment methodsFor: 'testing'! includesSelector: aSymbol in: aClass ^(environment includesSelector: aSymbol in: aClass) and: [(self selectorCacheFor: aClass) includes: aSymbol]! ! !RBVariableEnvironment methodsFor: 'testing' stamp: 'TestRunner 1/3/2010 11:29'! isEmpty ^ self accessorMethods allSatisfy: [ :each | (self perform: each) isEmpty ]! ! !RBVariableEnvironment methodsFor: 'testing' stamp: 'lr 1/3/2010 11:11'! isVariableEnvironment ^ true! ! !RBVariableEnvironment methodsFor: 'private'! accessorMethods ^#(#instanceVariables #instanceVariableReaders #instanceVariableWriters #classVariables)! ! !RBVariableEnvironment methodsFor: 'private'! 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: '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: '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: 'private'! classVariables ^classVariables! ! !RBVariableEnvironment methodsFor: 'private'! classVariables: anObject classVariables := anObject! ! !RBVariableEnvironment methodsFor: 'private'! computeSelectorCacheFor: aClass ^(self instanceVariableSelectorsFor: aClass) addAll: (self classVariableSelectorsFor: aClass); yourself! ! !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: 'private'! instanceVariableReaders ^instanceVariableReaders! ! !RBVariableEnvironment methodsFor: 'private'! instanceVariableReaders: anObject instanceVariableReaders := anObject! ! !RBVariableEnvironment methodsFor: 'private' stamp: 'lr 4/29/2010 19:35'! instanceVariableSelectorsFor: aClass | selectors | selectors := Set new. #(#instanceVariables #instanceVariableReaders #instanceVariableWriters) with: #(#whichSelectorsAccess: #whichSelectorsReallyRead: #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'! instanceVariableWriters ^instanceVariableWriters! ! !RBVariableEnvironment methodsFor: 'private'! instanceVariableWriters: anObject instanceVariableWriters := anObject! ! !RBVariableEnvironment methodsFor: 'private'! instanceVariables ^instanceVariables! ! !RBVariableEnvironment methodsFor: 'private'! instanceVariables: anObject instanceVariables := anObject! ! !RBVariableEnvironment methodsFor: 'private'! selectorCache ^selectorCache isNil ifTrue: [selectorCache := Dictionary new] ifFalse: [selectorCache]! ! !RBVariableEnvironment methodsFor: 'private' stamp: 'lr 11/25/2009 00:42'! selectorCacheFor: aClass ^self selectorCache at: aClass name ifAbsentPut: [ self computeSelectorCacheFor: aClass ]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBVariableEnvironment class instanceVariableNames: ''! !RBVariableEnvironment class methodsFor: 'instance creation' stamp: 'lr 4/29/2010 19:35'! 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 whichSelectorsReallyRead: aString) isEmpty ifFalse: [newEnv addClass: cls instanceVariableReader: aString]]. ^newEnv! ! !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: 'lr 4/29/2010 19:35'! 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 whichSelectorsReallyRead: aString) isEmpty not or: [(cls whichSelectorsAssign: aString) isEmpty not]) ifTrue: [newEnv addClass: cls instanceVariable: 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: 'lr 9/8/2011 20:25'! readersOfInstanceVariable: aString in: aClass ^ self on: RBBrowserEnvironment new readersOfInstanceVariable: aString in: aClass! ! !RBVariableEnvironment class methodsFor: 'instance creation' stamp: 'lr 9/8/2011 20:25'! referencesToClassVariable: aSymbol in: aClass ^ self on: RBBrowserEnvironment new referencesToClassVariable: aSymbol in: aClass! ! !RBVariableEnvironment class methodsFor: 'instance creation' stamp: 'lr 9/8/2011 20:25'! referencesToInstanceVariable: aString in: aClass ^ self on: RBBrowserEnvironment new referencesToInstanceVariable: aString in: aClass! ! !RBVariableEnvironment class methodsFor: 'instance creation' stamp: 'lr 9/8/2011 20:25'! writersOfInstanceVariable: aString in: aClass ^ self on: RBBrowserEnvironment new writersOfInstanceVariable: aString in: aClass! ! RBValueNode subclass: #RBVariableNode instanceVariableNames: 'token' classVariableNames: '' poolDictionaries: '' category: 'AST-Core-Nodes'! !RBVariableNode commentStamp: 'md 8/9/2005 15:00' prior: 0! 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: '*ast-semantic-accessing' stamp: 'CamilloBruni 12/5/2011 15:04'! binding ^ self variableBinding! ! !RBVariableNode methodsFor: '*ast-semantic-accessing' stamp: 'lr 5/11/2010 22:23'! variableBinding ^ self propertyAt: #variableBinding ifAbsent: [ self semanticAnnotationMissing ]! ! !RBVariableNode methodsFor: '*ast-semantic-testing' stamp: 'lr 9/2/2010 13:45'! hasVariableBinding ^ self hasProperty: #variableBinding! ! !RBVariableNode methodsFor: 'accessing' stamp: 'CamilloBruni 2/6/2012 14:05'! name ^token value asSymbol! ! !RBVariableNode methodsFor: 'accessing'! precedence ^0! ! !RBVariableNode methodsFor: 'accessing'! startWithoutParentheses ^token start! ! !RBVariableNode methodsFor: 'accessing'! stopWithoutParentheses ^token stop! ! !RBVariableNode methodsFor: 'accessing' stamp: 'lr 2/18/2010 17:44'! token ^ token! ! !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: 'comparing'! equalTo: anObject withMapping: aDictionary ^self class = anObject class and: [(aDictionary at: self name ifAbsentPut: [anObject name]) = anObject name]! ! !RBVariableNode methodsFor: 'comparing'! hash ^self name hash! ! !RBVariableNode methodsFor: 'initialize-release'! identifierToken: anIdentifierToken token := anIdentifierToken! ! !RBVariableNode methodsFor: 'matching' stamp: 'lr 11/24/2009 23:43'! copyInContext: aDictionary ^ self class identifierToken: token copy removePositions! ! !RBVariableNode methodsFor: 'replacing'! replaceSourceFrom: aNode self addReplacement: (RBStringReplacement replaceFrom: aNode start to: aNode stop with: self name)! ! !RBVariableNode methodsFor: 'replacing'! replaceSourceWith: aNode self addReplacement: (RBStringReplacement replaceFrom: self start to: self stop with: aNode formattedCode)! ! !RBVariableNode methodsFor: 'testing'! isImmediateNode ^true! ! !RBVariableNode methodsFor: 'testing' stamp: 'TestRunner 11/2/2009 21:18'! isRead ^ self isWrite not and: [ self isUsed ]! ! !RBVariableNode methodsFor: 'testing'! isVariable ^true! ! !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: 'testing'! needsParenthesis ^false! ! !RBVariableNode methodsFor: 'testing'! references: aVariableName ^self name = aVariableName! ! !RBVariableNode methodsFor: 'visitor' stamp: 'CamilloBruni 2/3/2012 16:35'! accept: aProgramNodeVisitor ^aProgramNodeVisitor visitVariableNode: self! ! !RBVariableNode methodsFor: 'visitor'! acceptVisitor: aProgramNodeVisitor ^aProgramNodeVisitor acceptVariableNode: self! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBVariableNode class instanceVariableNames: ''! !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'! named: aString ^self identifierToken: (RBIdentifierToken value: aString start: 0)! ! !RBVariableNode class methodsFor: 'instance creation' stamp: 'CamilloBruni 12/5/2011 19:19'! withToken: anIdentifierToken ^(self new) identifierToken: anIdentifierToken; yourself! ! RBBlockLintRule subclass: #RBVariableNotDefinedRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBVariableNotDefinedRule commentStamp: '' prior: 0! See my #rationale.! !RBVariableNotDefinedRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 13:49'! category ^ 'Bugs'! ! !RBVariableNotDefinedRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Bugs'! ! !RBVariableNotDefinedRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Variable used, but not defined anywhere'! ! !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 5/15/2010 15:04'! severity ^ #error! ! !RBVariableNotDefinedRule methodsFor: 'running' stamp: 'lr 7/23/2010 08:04'! checkMethod: aContext aContext compiledMethod literals do: [ :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 class instanceVariableNames: ''! !RBVariableNotDefinedRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBRefactoring subclass: #RBVariableRefactoring instanceVariableNames: 'class variableName' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Core-Refactorings'! !RBVariableRefactoring methodsFor: 'initialize-release'! variable: aVarName class: aClass class := self classObjectFor: aClass. variableName := aVarName! ! !RBVariableRefactoring methodsFor: 'printing'! storeOn: aStream aStream nextPut: $(. self class storeOn: aStream. aStream nextPutAll: ' variable: '. variableName storeOn: aStream. aStream nextPutAll: ' class: '. class storeOn: aStream. aStream nextPut: $)! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RBVariableRefactoring class instanceVariableNames: ''! !RBVariableRefactoring class methodsFor: 'instance creation'! model: aRBSmalltalk variable: aVarName class: aClass ^(self new) model: aRBSmalltalk; variable: aVarName class: aClass; yourself! ! !RBVariableRefactoring class methodsFor: 'instance creation'! variable: aVarName class: aClass ^self new variable: aVarName class: aClass! ! RBBlockLintRule subclass: #RBVariableReferencedOnceRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-BlockRules'! !RBVariableReferencedOnceRule commentStamp: '' prior: 0! See my #rationale.! !RBVariableReferencedOnceRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/6/2012 13:49'! category ^ 'Design Flaws'! ! !RBVariableReferencedOnceRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! group ^ 'Unnecessary code'! ! !RBVariableReferencedOnceRule methodsFor: 'accessing' stamp: 'lr 2/23/2009 23:17'! name ^ 'Variable referenced in only one method and always assigned first'! ! !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 5/15/2010 15:10'! severity ^ #information! ! !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 instanceVariableNames: ''! !RBVariableReferencedOnceRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBClassScope subclass: #RBVariableScope instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'AST-Semantic-Scope'! !RBVariableScope methodsFor: 'initialization' stamp: 'lr 4/27/2010 15:21'! setClass: aClass super setClass: aClass. aClass allInstVarNames keysAndValuesDo: [ :index :name | self add: (RBInstanceBinding name: name index: index) ]! ! !RBVariableScope methodsFor: 'testing' stamp: 'lr 5/11/2010 19:12'! isVariableScope ^ true! ! RBRefactoringBrowserTest subclass: #RBVariableTypeTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Tests-Core'! !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'! 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'! 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))! ! !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))! ! RBParseTreeLintRule subclass: #RBWhileTrueRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBWhileTrueRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:36'! category ^ 'Coding Idiom Violation'! ! !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: 'accessing' stamp: 'lr 5/15/2010 17:39'! rationale ^ 'Checks for users of whileTrue: when the shorter to:do: would work.'! ! !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 class instanceVariableNames: ''! !RBWhileTrueRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! RBParseTreeLintRule subclass: #RBYourselfNotUsedRule instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Refactoring-Critics-ParseTreeRules'! !RBYourselfNotUsedRule methodsFor: '*Manifest-Core' stamp: 'SimonAllier 9/7/2012 10:36'! category ^ 'Optimization'! ! !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: 'accessing' stamp: 'lr 2/23/2009 23:17'! rationale ^ 'Check for methods sending the yourself message when it is not necessary.'! ! !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 class instanceVariableNames: ''! !RBYourselfNotUsedRule class methodsFor: '*Manifest-Core'! 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! ! !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'! ! QuotedPrintableMimeConverter subclass: #RFC2047MimeConverter instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Network-MIME'! !RFC2047MimeConverter commentStamp: '' prior: 0! 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: '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: '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: '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: '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: '?=']! ! !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: '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! ! RGNamedDefinition subclass: #RGAbstractContainer instanceVariableNames: 'elements' classVariableNames: '' poolDictionaries: '' category: 'Ring-Core-Containers'! !RGAbstractContainer commentStamp: 'VeronicaUquillas 5/12/2011 10:59' prior: 0! 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: 'accessing' stamp: 'VeronicaUquillas 4/14/2011 10:21'! elements "Retrieves the elements" ^elements! ! !RGAbstractContainer methodsFor: 'adding/removing' stamp: 'VeronicaUquillas 4/14/2011 12:17'! addElement: anObject anObject addInContainer: self! ! !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: 'adding/removing' stamp: 'VeronicaUquillas 4/14/2011 12:17'! removeElement: anObject anObject removeFromContainer: self! ! !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: 'initialize-release' stamp: 'VeronicaUquillas 4/14/2011 10:20'! initialize super initialize. elements:= IdentityDictionary new.! ! !RGAbstractContainer methodsFor: 'iterating elements' stamp: 'VeronicaUquillas 4/13/2011 15:21'! elementsDo: aBlock elements values do:[ :collection| collection do:[ :each| aBlock value: each ] ]! ! !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: '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 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: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: 'managing elements groups' stamp: 'VeronicaUquillas 4/15/2011 09:48'! removeElementsCategorized: aSymbol "Deletes a group of elements" elements removeKey: aSymbol ifAbsent:[ ]! ! !RGAbstractContainer methodsFor: 'testing' stamp: 'VeronicaUquillas 7/29/2011 10:51'! includesElement: anRGDefinition ^anRGDefinition isIncludedInContainer: self! ! !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 4/13/2011 16:03'! includesElementNamed: elementName in: aCollection | aSymbol | aSymbol:= elementName asSymbol. ^aCollection isDictionary ifTrue: [ aCollection includesKey: aSymbol ] ifFalse:[ (aCollection detect:[ :each| each name = aSymbol ] ifNone:[ nil ]) notNil ]! ! RGGlobalDefinition subclass: #RGBehaviorDefinition instanceVariableNames: 'superclass methods protocols' classVariableNames: '' poolDictionaries: '' category: 'Ring-Core-Kernel'! !RGBehaviorDefinition commentStamp: 'VeronicaUquillas 5/9/2011 14:30' prior: 0! An RGBehaviorDefinition is an abstract definition for class-alike entities (e.g. classes, traits) Instance Variables methods: protocols: superclass: ! !RGBehaviorDefinition methodsFor: '*NautilusCommon' stamp: 'BenjaminVanRyseghem 9/1/2011 14:41'! addCategory: newName before: aCategory ^ self addProtocol: newName! ! !RGBehaviorDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 11/17/2010 11:01'! methods ^methods! ! !RGBehaviorDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 5/2/2011 16:24'! methods: aDictionary methods:= aDictionary! ! !RGBehaviorDefinition methodsFor: 'accessing'! package self subclassResponsibility! ! !RGBehaviorDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 4/13/2011 16:43'! protocols "retrieves the protocols of the class" ^protocols! ! !RGBehaviorDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 3/21/2011 16:58'! protocols: aCollection "set the protocols of the class" protocols:= aCollection! ! !RGBehaviorDefinition methodsFor: 'accessing'! realClass "Retrieves the current class existing in the runtime environment" ^self rootEnvironment classNamed: self name ! ! !RGBehaviorDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 11/17/2010 11:01'! superclass ^superclass! ! !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'! theMetaClass self subclassResponsibility! ! !RGBehaviorDefinition methodsFor: 'accessing'! theNonMetaClass self subclassResponsibility! ! !RGBehaviorDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 7/27/2011 18:03'! 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 := Scanner new scanTokens: self traitCompositionSource. ^tokens select: [:each | each first isUppercase].! ! !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: '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: '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 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: '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: '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: '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: '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: '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 methods' stamp: 'VeronicaUquillas 8/8/2011 12:47'! extensionMethods ^self methods select:[ :each | each isExtension ]! ! !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 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: 'accessing methods' stamp: 'VeronicaUquillas 4/13/2011 23:51'! methodsInProtocol: aString "Retrieves the methods classified in protocol named aString" ^methods select:[ :each| each protocol = aString ]! ! !RGBehaviorDefinition methodsFor: 'accessing methods' stamp: 'VeronicaUquillas 3/21/2011 17:23'! selectors "Retrieves the method selectors" ^methods keys! ! !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: '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: '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: 'adding/removing methods' stamp: 'VeronicaUquillas 4/29/2011 13:59'! removeSelector: selector "Removes a method named as selector" methods removeKey: selector ifAbsent:[]! ! !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: '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: '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: '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: '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 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: 'annotations' stamp: 'VeronicaUquillas 6/28/2011 15:22'! superclassName "Retrieves the name of the superclass if exists" ^self annotationNamed: self class superclassNameKey! ! !RGBehaviorDefinition methodsFor: 'annotations' stamp: 'VeronicaUquillas 6/28/2011 15:21'! superclassName: aSymbol self annotationNamed: self class superclassNameKey put: aSymbol! ! !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: '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: 'compatibility' stamp: 'VeronicaUquillas 4/14/2011 11:13'! soleInstance "to be depracated in the future" ^self theNonMetaClass! ! !RGBehaviorDefinition methodsFor: 'initialize-release' stamp: 'VeronicaUquillas 5/12/2011 10:33'! initialize super initialize. methods:= IdentityDictionary new. protocols:= Set new.! ! !RGBehaviorDefinition methodsFor: 'managing container' stamp: 'VeronicaUquillas 5/9/2011 14:34'! addInContainer: aRGContainer aRGContainer addClass: self! ! !RGBehaviorDefinition methodsFor: 'managing container' stamp: 'VeronicaUquillas 5/9/2011 14:34'! isIncludedInContainer: aRGContainer ^aRGContainer includesClass: self! ! !RGBehaviorDefinition methodsFor: 'managing container' stamp: 'VeronicaUquillas 5/9/2011 14:34'! removeFromContainer: aRGContainer aRGContainer removeClass: self! ! !RGBehaviorDefinition methodsFor: 'printing' stamp: 'VeronicaUquillas 11/17/2010 14:31'! printOn: aStream aStream nextPutAll: self name! ! !RGBehaviorDefinition methodsFor: 'printing' stamp: 'VeronicaUquillas 2/25/2011 19:25'! storeOn: aStream aStream nextPutAll: self name! ! !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: '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 9/19/2011 16:51'! hasMetaclass ^ false! ! !RGBehaviorDefinition methodsFor: 'testing' stamp: 'VeronicaUquillas 4/13/2011 16:40'! hasMethods "validates the existance of methods" ^methods notEmpty! ! !RGBehaviorDefinition methodsFor: 'testing' stamp: 'VeronicaUquillas 3/21/2011 17:03'! hasProtocols "Validates the existance of protocols" ^protocols notEmpty! ! !RGBehaviorDefinition methodsFor: 'testing' stamp: 'VeronicaUquillas 11/24/2010 16:40'! hasSuperclass ^superclass notNil! ! !RGBehaviorDefinition methodsFor: 'testing' stamp: 'VeronicaUquillas 3/22/2011 16:38'! hasTraitComposition ^self traitCompositionSource ~= '{}'! ! !RGBehaviorDefinition methodsFor: 'testing' stamp: 'VeronicaUquillas 4/13/2011 17:15'! includesProtocol: aString "Looks for a protocols named = aString" ^(protocols detect:[ :each| each = aString ] ifNone:[ nil ]) notNil ! ! !RGBehaviorDefinition methodsFor: 'testing' stamp: 'VeronicaUquillas 4/13/2011 16:41'! isDefined "If the class exists in the environment" ^self realClass notNil ! ! !RGBehaviorDefinition methodsFor: 'testing'! isMeta "By default is considered a non-meta class" ^false! ! !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: 'tools' stamp: 'BenjaminVanRyseghem 2/8/2012 17:10'! browse ^ Smalltalk tools browser fullOnClass: self realClass selector: nil! ! !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: 'private' stamp: 'VeronicaUquillas 4/29/2011 13:58'! removeMethod: aRGMethodDefinition from: aCollection "Removes aRGMethodDefinition from the collection received" aCollection removeKey: aRGMethodDefinition selector ifAbsent:[]! ! "-- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- -- "! RGBehaviorDefinition class instanceVariableNames: ''! !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'! allSuperclassesKey ^#allSuperclasses! ! !RGBehaviorDefinition class methodsFor: 'class-annotations' stamp: 'VeronicaUquillas 6/28/2011 15:17'! definitionSourceKey ^#definitionSource! ! !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'! subclassesKey ^#subclasses! ! !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'! 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! ! RGClassDescriptionDefinition subclass: #RGClassDefinition instanceVariableNames: 'metaClass comment classVariables poolDictionaries category package' classVariableNames: '' poolDictionaries: '' category: 'Ring-Core-Kernel'! !RGClassDefinition commentStamp: 'VeronicaUquillas 4/19/2011 16:01' prior: 0! RGClassDefinition is the concrete representation of a class (no trait)! !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: '*NautilusCommon' stamp: 'BenjaminVanRyseghem 9/1/2011 14:18'! definition ^ self realClass definition! ! !RGClassDefinition methodsFor: '*NautilusCommon' stamp: 'BenjaminVanRyseghem 8/28/2011 18:33'! inheritsFrom: aClass ^ self realClass inheritsFrom: aClass! ! !RGClassDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 4/14/2011 11:15'! category "retrieves a tag for its package" ^category! ! !RGClassDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 3/21/2011 16:53'! category: aSymbol "stores a tag for its package" category := aSymbol! ! !RGClassDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 4/28/2011 21:30'! classVariables ^classVariables! ! !RGClassDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 5/2/2011 16:26'! classVariables: aCollection classVariables:= aCollection! ! !RGClassDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 4/27/2011 10:45'! comment "Retrieves the comment definition object" ^comment! ! !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: 'accessing' stamp: 'VeronicaUquillas 4/14/2011 12:40'! package "Retrieves the package in which this class is contained, if exists" ^package! ! !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 8/2/2011 13:37'! poolDictionaries "Keeps the pool variable relationship of the receiver" ^poolDictionaries! ! !RGClassDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 5/2/2011 16:26'! poolDictionaries: aCollection poolDictionaries:= aCollection! ! !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/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 12/2/2010 18:27'! theMetaClass ^metaClass! ! !RGClassDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 12/2/2010 18:27'! theNonMetaClass ^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: 'behavior' stamp: 'VeronicaUquillas 5/12/2011 13:20'! withMetaclass: aRGMetaclassDefinition "Registers explicitly the metaclass of a class" metaClass:= aRGMetaclassDefinition. metaClass baseClass: self. ! ! !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/28/2011 21:27'! addClassVariable: aRCClassVariable self addVariable: (aRCClassVariable parent: self) in: classVariables! ! !RGClassDefinition methodsFor: 'class variables' stamp: 'VeronicaUquillas 11/24/2010 17:24'! addClassVariables: aCollection aCollection do: [:var | self addClassVarNamed: var ]! ! !RGClassDefinition methodsFor: 'class variables' stamp: 'VeronicaUquillas 2/25/2011 20:38'! allClassVarNames ^self allClassVariables collect:[ :cvar| cvar name ]! ! !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 4/29/2011 09:39'! classVarNamed: aString ^classVariables detect:[ :v| v name = aString asSymbol ] ifNone:[ nil ]! ! !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: '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/29/2011 13:39'! removeClassVariable: aRGClassVariableDefinition self removeVariable: aRGClassVariableDefinition from: classVariables! ! !RGClassDefinition methodsFor: 'initialize-release' stamp: 'VeronicaUquillas 4/28/2011 21:30'! initialize super initialize. classVariables:= OrderedCollection new. poolDictionaries:= OrderedCollection new.! ! !RGClassDefinition methodsFor: 'managing pool users' stamp: 'VeronicaUquillas 8/2/2011 13:54'! addUser: aRGClassDefinition "The receiver registers the aRGClassDefinition as an user. An reinforces its status as a shared pool." aRGClassDefinition isClass ifFalse:[ ^self ]. (aRGClassDefinition theNonMetaClass poolDictNamed: self name) isNil ifTrue: [ aRGClassDefinition theNonMetaClass addPoolDictNamed: self name ]. self isPool: true. self users add: aRGClassDefinition theNonMetaClass! ! !RGClassDefinition methodsFor: 'managing pool users' stamp: 'VeronicaUquillas 8/2/2011 13:46'! includesUser: aRGBehaviorDefinition ^self users includes: aRGBehaviorDefinition! ! !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: 'managing pool users' stamp: 'VeronicaUquillas 8/2/2011 13:41'! isPool: aBoolean ^self annotationNamed: self class isPoolKey put: aBoolean! ! !RGClassDefinition methodsFor: 'managing pool users' stamp: 'VeronicaUquillas 8/2/2011 13:46'! removeUser: aRGClassDefinition "Removes this RGClassDefinition from the users of the receiver" aRGClassDefinition isClass ifFalse:[ ^self ]. aRGClassDefinition theNonMetaClass removePoolDictNamed: self name. self users remove: aRGClassDefinition theNonMetaClass ifAbsent:[ ]! ! !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: 'pool dictionaries' stamp: 'VeronicaUquillas 5/15/2011 18:07'! addPoolDictNamed: poolName | var | var:= self factory createPoolVariableNamed: poolName parent: self. self addVariable: var in: poolDictionaries. ^var! ! !RGClassDefinition methodsFor: 'pool dictionaries' stamp: 'VeronicaUquillas 4/14/2011 11:19'! addPoolDictionaries: aCollection aCollection do:[ :var| self addPoolDictNamed: var ]! ! !RGClassDefinition methodsFor: 'pool dictionaries' stamp: 'VeronicaUquillas 9/29/2011 12:41'! addPoolDictionary: aRGPoolVariableDefinition self addVariable: (aRGPoolVariableDefinition parent: self) in: poolDictionaries! ! !RGClassDefinition methodsFor: 'pool dictionaries' stamp: 'VeronicaUquillas 2/26/2011 13:48'! allPoolDictNames ^self allPoolDictionaries collect:[ :pool| pool name ]! ! !RGClassDefinition methodsFor: 'pool dictionaries' stamp: 'VeronicaUquillas 4/29/2011 09:25'! allPoolDictionaries "Answer a collection of the pools the receiver shares, including those defined in the superclasses of the receiver." ^self hasSuperclass ifFalse:[ poolDictionaries ] ifTrue:[ self superclass allPoolDictionaries, poolDictionaries ]! ! !RGClassDefinition methodsFor: 'pool dictionaries' stamp: 'VeronicaUquillas 4/29/2011 09:25'! poolDictNamed: poolName ^poolDictionaries detect:[ :v| v name = poolName asSymbol ] ifNone:[ nil ]! ! !RGClassDefinition methodsFor: 'pool dictionaries' stamp: 'VeronicaUquillas 4/29/2011 09:25'! poolDictNames ^poolDictionaries collect:[ :pool| pool name ]! ! !RGClassDefinition methodsFor: 'pool dictionaries' stamp: 'VeronicaUquillas 4/29/2011 13:40'! removePoolDictNamed: poolName self removeVariable: (self poolDictNamed: poolName) from: poolDictionaries! ! !RGClassDefinition methodsFor: 'pool dictionaries' stamp: 'VeronicaUquillas 4/29/2011 13:39'! removePoolDictionary: aRGPoolVariableDefinition self removeVariable: aRGPoolVariableDefinition from: poolDictionaries! ! !RGClassDefinition methodsFor: 'testing' stamp: 'VeronicaUquillas 5/12/2011 14:41'! hasComment ^comment isEmptyOrNil not! ! !RGClassDefinition methodsFor: 'testing' stamp: 'VeronicaUquillas 12/2/2010 18:26'! hasMetaclass ^metaClass notNil! ! !RGClassDefinition methodsFor: 'testing' stamp: 'VeronicaUquillas 5/12/2011 10:09'! hasStamp ^self stamp isEmptyOrNil not! ! !RGClassDefinition methodsFor: 'testing' stamp: 'CamilloBruni 10/23/2012 20:24'! 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 poolDictNames sorted = aRGClassDefinition poolDictNames 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: 'to be removed - compatibility for now' stamp: 'StephaneDucasse 7/26/2011 14:04'! classSymbol ^ self className! ! TestCase subclass: #RGClassDefinitionTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Ring-Tests-Kernel'! !RGClassDefinitionTest methodsFor: '*Manifest-Tests'! 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: '*Manifest-Tests'! 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: '*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: '*Ring-Tests-Monticello' stamp: 'VeronicaUquillas 9/19/2011 16:46'! 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 isNil. 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 isNil. self assert: rgClass subclasses first package isNil. rgClass := RGClassDefinition theMetaClass asFullRingDefinition. self assert: rgClass package = rgClass theNonMetaClass package.! ! !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: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: 'StephaneDucasse 7/19/2011 10:41'! 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 = 'TBehaviorCategorization'). self assert: (newClass theMetaClass isRingObject). self assert: (newClass theMetaClass isClass). self assert: (newClass theMetaClass traitCompositionSource = 'TBehaviorCategorization classTrait'). ! ! !RGClassDefinitionTest methodsFor: 'testing' stamp: 'StephaneDucasse 7/19/2011 10:43'! testAsClassDefinitionSourceDefinition | newClass | newClass:= Trait asRingDefinition. self assert: (newClass definitionSource = 'TraitDescription subclass: #Trait uses: TBehaviorCategorization instanceVariableNames: ''name environment classTrait category'' classVariableNames: '''' poolDictionaries: '''' category: ''Traits-Kernel'''). self assert: (newClass theMetaClass definitionSource = 'Trait class uses: TBehaviorCategorization classTrait instanceVariableNames: '''''). ! ! !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: '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: 'testing' stamp: 'VeronicaUquillas 4/28/2011 16:11'! testNonExistingClass | newClass | newClass:= RGFactory current createClassNamed: #Connection. self assert: (newClass isClass). self assert: (newClass instanceVariables isEmpty). self assert: (newClass classVariables isEmpty). self assert: (newClass poolDictionaries 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). ! ! !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 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:11'! 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 instVarNamed: #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 instVarNamed: #sizes) 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: 'testing' stamp: 'VeronicaUquillas 5/12/2011 19:34'! 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 authorAlias = '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: '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: 'VeronicaUquillas 4/28/2011 16:12'! 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 instVarNamed: #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 instVarNamed: #array) isNil). ! ! !RGClassDefinitionTest methodsFor: 'testing' stamp: 'VeronicaUquillas 5/23/2011 11:34'! testWithPoolDictionaries | newClass poolVar | newClass:= (RGFactory current createClassNamed: #Text) addPoolDictNamed: #TextConstants; yourself. self assert: (newClass poolDictionaries size = 1). self assert: (newClass poolDictNames size = 1). self assert: (newClass allPoolDictionaries size = 1). "no hierarchy" self assert: (newClass allPoolDictNames size = 1). poolVar:= newClass poolDictNamed: #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 allPoolDictNames size = 1). newClass removePoolDictNamed: #TextConstants. self assert: (newClass poolDictionaries isEmpty).! ! !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 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).! ! RGBehaviorDefinition subclass: #RGClassDescriptionDefinition instanceVariableNames: 'instanceVariables' classVariableNames: '' poolDictionaries: '' category: 'Ring-Core-Kernel'! !RGClassDescriptionDefinition commentStamp: 'VeronicaUquillas 4/19/2011 16:00' prior: 0! RGClassDescriptionDefinition is the common parent for classes and metaclasses defining instance variables! !RGClassDescriptionDefinition methodsFor: '*GroupManagerUI' stamp: 'BenjaminVanRyseghem 2/25/2012 16:01'! elementsToAddInAGroup ^ self methods! ! !RGClassDescriptionDefinition methodsFor: '*GroupManagerUI' stamp: 'BenjaminVanRyseghem 2/25/2012 16:36'! prettyName ^ self printString! ! !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: '*Manifest-Core'! storeOn: aStream aStream nextPutAll: '('; nextPutAll: self class name; nextPutAll: ' named: #'; nextPutAll: name; nextPut: $). ! ! !RGClassDescriptionDefinition methodsFor: '*NautilusCommon' stamp: 'BenjaminVanRyseghem 9/1/2011 14:39'! extendingPackages ^ self realClass extendingPackages! ! !RGClassDescriptionDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 11/16/2010 11:20'! instanceVariables ^instanceVariables! ! !RGClassDescriptionDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 2/26/2011 12:02'! instanceVariables: aCollection instanceVariables:= aCollection! ! !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: 'comparing' stamp: 'VeronicaUquillas 2/25/2011 20:17'! hash ^self name hash bitXor: self class hash! ! !RGClassDescriptionDefinition methodsFor: 'initialize-release' stamp: 'VeronicaUquillas 11/24/2010 14:00'! initialize super initialize. instanceVariables:= OrderedCollection new.! ! !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 4/28/2011 21:30'! addInstanceVariable: aRGVariableDefinition "aRGVariableDefinition is a instance variable or class instance variable" self addVariable: (aRGVariableDefinition parent: self) in: instanceVariables! ! !RGClassDescriptionDefinition methodsFor: 'instance variables' stamp: 'VeronicaUquillas 2/19/2011 00:42'! addInstanceVariables: aCollection aCollection do: [:var | self addInstVarNamed: var ]! ! !RGClassDescriptionDefinition methodsFor: 'instance variables' stamp: 'VeronicaUquillas 2/25/2011 20:38'! allInstVarNames ^self allInstanceVariables collect:[ :ivar| ivar name ]! ! !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 4/29/2011 09:24'! instVarNamed: aString ^instanceVariables detect:[ :v| v name = aString asSymbol ] ifNone:[ nil ]! ! !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: 'instance variables' stamp: 'VeronicaUquillas 4/29/2011 13:38'! removeInstVarNamed: aString self removeVariable: (self instVarNamed: aString) from: instanceVariables! ! !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: 'VeronicaUquillas 11/19/2010 11:59'! isClass ^true! ! !RGClassDescriptionDefinition methodsFor: 'testing' stamp: 'CamilloBruni 10/23/2012 20:23'! 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 sorted = aRGClassDescriptionDefinition instVarNames sorted ]! ! !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: '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 class instanceVariableNames: ''! !RGClassDescriptionDefinition class methodsFor: '*manifest-core' stamp: 'SimonAllier 8/22/2012 16:30'! manifestReadOn: aArray ^ self named:( aArray first)! ! RGVariableDefinition subclass: #RGClassInstanceVariableDefinition instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Ring-Core-Kernel'! !RGClassInstanceVariableDefinition methodsFor: 'initialize-release' stamp: 'VeronicaUquillas 2/15/2011 15:47'! initialize super initialize. self isMetaSide: true.! ! !RGClassInstanceVariableDefinition methodsFor: 'testing' stamp: 'VeronicaUquillas 11/16/2010 14:46'! isClassInstanceVariable ^true! ! RGVariableDefinition subclass: #RGClassVariableDefinition instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Ring-Core-Kernel'! !RGClassVariableDefinition methodsFor: 'testing' stamp: 'VeronicaUquillas 11/16/2010 14:46'! isClassVariable ^true! ! RGElementDefinition subclass: #RGCommentDefinition instanceVariableNames: 'content stamp' classVariableNames: '' poolDictionaries: '' category: 'Ring-Core-Kernel'! !RGCommentDefinition commentStamp: 'VeronicaUquillas 5/6/2011 10:54' prior: 0! RGCommentDefinition is a first-class representation of class's comments! !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: 'accessing' stamp: 'VeronicaUquillas 4/27/2011 16:02'! content: anObject content:= anObject! ! !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: 'accessing' stamp: 'VeronicaUquillas 8/26/2011 15:25'! name ^name ifNil:[ name := #Comment ]! ! !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 4/27/2011 10:42'! stamp: anObject stamp:= anObject! ! !RGCommentDefinition methodsFor: 'backward compatibility' stamp: 'VeronicaUquillas 8/25/2011 22:37'! sourceCode ^ self content ! ! !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: '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: '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 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: '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:33'! sourcePointer "Retrieves the sourcePointer for this definition if exists" ^self annotationNamed: self class sourcePointerKey ! ! !RGCommentDefinition methodsFor: 'source pointers' stamp: 'VeronicaUquillas 8/25/2011 14:32'! sourcePointer: aNumber self annotationNamed: self class sourcePointerKey put: aNumber ! ! !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 6/28/2011 15:22'! authorAlias ^self annotationNamed: self class authorAliasKey ifAbsentPut:[ self class parseAuthorAliasFrom: stamp ]! ! !RGCommentDefinition methodsFor: 'stamp values' stamp: 'VeronicaUquillas 6/28/2011 15:22'! authorAlias: aString self annotationNamed: self class authorAliasKey put: aString ! ! !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: 'stamp values' stamp: 'VeronicaUquillas 6/28/2011 15:22'! timeStamp: aTimestamp self annotationNamed: self class timeStampKey put: aTimestamp ! ! !RGCommentDefinition methodsFor: 'testing' stamp: 'VeronicaUquillas 5/17/2011 13:44'! hasAuthorAlias ^self hasStamp and:[ self authorAlias isEmptyOrNil not ]! ! !RGCommentDefinition methodsFor: 'testing' stamp: 'VeronicaUquillas 4/27/2011 10:48'! hasStamp ^stamp isEmptyOrNil not ! ! !RGCommentDefinition methodsFor: 'testing' stamp: 'VeronicaUquillas 4/27/2011 10:41'! isComment ^true! ! !RGCommentDefinition methodsFor: 'testing' stamp: 'VeronicaUquillas 5/17/2011 09:57'! isEmptyOrNil ^content isEmptyOrNil ! ! !RGCommentDefinition methodsFor: 'testing' stamp: 'MarcusDenker 10/6/2012 14:57'! isFromTrait ^false! ! !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: 'to remove as soon as possible' stamp: 'MarianoMartinezPeck 5/7/2012 11:31'! category ^self realClass category! ! !RGCommentDefinition methodsFor: 'to remove as soon as possible' stamp: 'StephaneDucasse 7/26/2011 14:09'! isCommentReference ^ true! ! !RGCommentDefinition methodsFor: 'to remove as soon as possible' stamp: 'StephaneDucasse 8/21/2011 18:01'! isValid "for compatibility with method definition" ^ true! ! !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: '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 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: '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: '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: '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: '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: '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: '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: '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 class instanceVariableNames: ''! !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! ! TestCase subclass: #RGCommentDefinitionTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Ring-Tests-Kernel'! !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: '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 4/28/2011 16:28'! testCommentWithoutAuthor | newComment | newComment:= RGFactory current createComment content: 'This is a comment for test'; stamp: '3/22/2011 14:51'; yourself. self assert: (newComment hasAuthorAlias not).! ! !RGCommentDefinitionTest methodsFor: 'testing' stamp: 'VeronicaUquillas 9/18/2011 16:06'! 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 hasAuthorAlias. self assert: newComment timeStamp notNil. self assert: (newComment authorAlias = '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/25/2011 22:42'! testSorting | rgComm1 rgComm2 | rgComm1 := RGCommentDefinition realClass: RGClassDefinition. rgComm2 := RGCommentDefinition realClass: RGElementDefinition. self assert: rgComm1 <= rgComm2! ! !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'! ! RGAbstractContainer subclass: #RGContainer instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Ring-Core-Containers'! !RGContainer commentStamp: 'VeronicaUquillas 9/6/2011 16:12' prior: 0! A concrete container already knows how to treat classes, methods and packages. ! !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: 'accessing' stamp: 'VeronicaUquillas 9/6/2011 16:48'! definedClasses: aCollection "Set the classes collection" self elements at: #definedClasses put: aCollection! ! !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:20'! methods: aCollection "Set the methods collection" self elements at: #methods put: aCollection! ! !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: 'accessing' stamp: 'VeronicaUquillas 7/27/2011 15:18'! packages: aCollection self elementsCategorized: #packages with: aCollection! ! !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: '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 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: '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: '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'! addTrait: aRGTraitDefinition "convenient method" self addClass: 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: 'adding/removing' stamp: 'VeronicaUquillas 9/6/2011 16:49'! removeClass: aRGAbstractClassDefinition self removeElement: aRGAbstractClassDefinition from: self definedClasses! ! !RGContainer methodsFor: 'adding/removing' stamp: 'VeronicaUquillas 4/28/2011 15:52'! removeMethod: aRGMethodDefinition self removeElement: aRGMethodDefinition from: self methods! ! !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: 'adding/removing' stamp: 'VeronicaUquillas 4/28/2011 15:52'! removeTrait: aRGTraitDefinition "convenient method" self removeClass: aRGTraitDefinition! ! !RGContainer methodsFor: 'adding/removing' stamp: 'VeronicaUquillas 9/6/2011 16:49'! withoutClasses self removeElementsCategorized: #definedClasses! ! !RGContainer methodsFor: 'adding/removing' stamp: 'VeronicaUquillas 4/19/2011 14:23'! withoutMethods self removeElementsCategorized: #methods! ! !RGContainer methodsFor: 'adding/removing' stamp: 'VeronicaUquillas 9/6/2011 15:08'! withoutPackages self removeElementsCategorized: #packages! ! !RGContainer methodsFor: 'convenient accesses' stamp: 'VeronicaUquillas 9/6/2011 17:29'! allClasses "convenient method" ^self classes! ! !RGContainer methodsFor: 'convenient accesses' stamp: 'VeronicaUquillas 8/8/2011 10:21'! allMethods "convenient method" ^self methods! ! !RGContainer methodsFor: 'convenient accesses' stamp: 'VeronicaUquillas 9/6/2011 17:30'! allTraits "convenient method" ^self allClasses select:[ :each | each isTrait ]! ! !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: '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: '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: '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: '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: '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: '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: 'image class and method loading' stamp: 'VeronicaUquillas 9/19/2011 14:17'! loadTraitUsers "Set the users of a trait" | users traits traitNames rgTrait | traits := self traits. users := self classes select:[ :cls| cls hasTraitComposition ]. users do:[ :each| each traitNames do:[ :tname| rgTrait := self traitNamed: tname. rgTrait notNil ifTrue: [ rgTrait addUser: each. rgTrait theMetaClass addUser: each theMetaClass ] ] ]! ! !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: '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 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: '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: '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: '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: 'initialize-release' stamp: 'VeronicaUquillas 9/7/2011 13:53'! initialize super initialize. self definedClasses: IdentityDictionary new. self methods: IdentityDictionary new. self packages: IdentityDictionary new.! ! !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: '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: '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: '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: 'iterating' stamp: 'VeronicaUquillas 4/19/2011 14:13'! methodsDo: aBlock self methods do:[ :each| aBlock value: each ]! ! !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: '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: '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: 'lookup by name' stamp: 'VeronicaUquillas 4/19/2011 14:13'! methodNamed: fullSelectorName ^self elementNamed: fullSelectorName in: self methods! ! !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: '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 9/6/2011 17:22'! hasClasses ^self definedClasses notEmpty! ! !RGContainer methodsFor: 'testing' stamp: 'VeronicaUquillas 4/19/2011 14:13'! hasMethods ^self methods notEmpty! ! !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: '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: 'testing' stamp: 'VeronicaUquillas 4/28/2011 15:49'! includesMethod: aRGMethodDefinition ^self methods includes: aRGMethodDefinition! ! !RGContainer methodsFor: 'testing' stamp: 'VeronicaUquillas 4/19/2011 14:13'! includesMethodNamed: fullSelectorName ^self includesElementNamed: fullSelectorName in: self methods! ! !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: '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: '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: '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 class instanceVariableNames: ''! !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: '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: '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: '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'! packageOfClass: aRGBehaviorDefinition ^ self packageOfClass: aRGBehaviorDefinition using: self packageNames.! ! !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'! packageOfMethod: aRGMethodDefinition ^ self packageOfMethod: aRGMethodDefinition using: self packageKeys! ! !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 ]! ! TestCase subclass: #RGContainerTest instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Ring-Tests-Containers'! !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! ! RGObject subclass: #RGDefinition instanceVariableNames: '' classVariableNames: '' poolDictionaries: '' category: 'Ring-Core-Kernel'! !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 ]! ! !RGDefinition methodsFor: 'accessing' stamp: 'VeronicaUquillas 1/20/2012 10:05'! environment: namespace namespace = self class environment ifFalse:[ self annotationNamed: #environment put: namespace ]! ! !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! ! RGNamedDefinition subclass: #RGElementDefinition instanceVariableNames: 'parent' classVariableNames: '' poolDictionaries: '' category: 'Ring-Core-Kernel'! !RGElementDefinition commentStamp: 'StephaneDucasse 7/26/2011 14:02' prior: 0! 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: 'accessing' stamp: 'VeronicaUquillas 9/1/2011 15:50'! fullName: aString ^ self annotationNamed: self class fullNameKey put: aString asSymbol! ! !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: 'accessing' stamp: 'StephaneDucasse 7/26/2011 14:01'! isMetaSide: aBoolean self annotationNamed: self class isMetaSideKey put: aBoolean! ! !RGElementDefinition methodsFor: 'backward compatibility' stamp: 'VeronicaUquillas 9/1/2011 15:07'! actualClass "returns the Smalltalk class of the receiver" ^ self realClass! ! !RGElementDefinition methodsFor: 'class element specific api' stamp: 'StephaneDucasse 7/26/2011 14:02'! className ^ self parentName! ! !RGElementDefinition methodsFor: 'class element specific api' stamp: 'StephaneDucasse 7/26/2011 14:21'! className: aName ^ self parentName: aName! ! !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: '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 methodsFor: 'class element specific api' stamp: 'VeronicaUquillas 8/25/2011 22:47'! theNonMetaClassName ^self theNonMetaParentName ! ! !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: '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: '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: '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: '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: 'generic parent api' stamp: 'VeronicaUquillas 8/31/2011 17:31'! parentName: aString self annotationNamed: self class classNameKey put: aString asSymbol! ! !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: '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: '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: '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: 'tools' stamp: 'BenjaminVanRyseghem 2/8/2012 17:10'! browse ^ self systemNavigation browseClass: self realClass! ! !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 class instanceVariableNames: ''! !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: 'class initialization' stamp: 'VeronicaUquillas 8/16/2011 14:38'! 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 setParentInfo: aClass; yourself! ! !RGElementDefinition class methodsFor: 'elements-annotations' stamp: 'VeronicaUquillas 6/28/2011 15:17'! classNameKey ^#className! ! !RGElementDefinition class methodsFor: 'elements-annotations' stamp: 'VeronicaUquillas 6/28/2011 15:17'! isMetaSideKey ^#isMetaSide! ! !RGElementDefinition class methodsFor: 'elements-annotations' stamp: 'VeronicaUquillas 8/25/2011 22:09'! sourcePointerKey ^#sourcePointer! ! !RGElementDefinition class methodsFor: 'elements-annotations' stamp: 'VeronicaUquillas 9/17/2011 18:04'! statusKey ^#statusKey! ! !RGElementDefinition class methodsFor: 'parsing stamp' stamp: 'VeronicaUquillas 8/22/2012 15:12'! basicParseAuthorAliasFrom: aString "Parse an alias/name of the author from a string that is extracted from a source file. If there is no alias/name we return emtpy string." | tokens dateStartIndex unknown | "The following timestamp strings are supported (source: squeak sources archeological survey):